summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore2
-rw-r--r--Makefile2
-rw-r--r--README_contribute36
-rw-r--r--README_maintainer204
-rw-r--r--contrib/README10
-rw-r--r--contrib/lisp/htmlize.el1945
-rw-r--r--contrib/lisp/ob-csharp.el83
-rw-r--r--contrib/lisp/ob-eukleides.el12
-rw-r--r--contrib/lisp/ob-fomus.el12
-rw-r--r--contrib/lisp/ob-julia.el41
-rw-r--r--contrib/lisp/ob-mathematica.el81
-rw-r--r--contrib/lisp/ob-mathomatic.el68
-rw-r--r--contrib/lisp/ob-oz.el18
-rw-r--r--contrib/lisp/ob-sclang.el92
-rw-r--r--contrib/lisp/ob-stata.el312
-rw-r--r--contrib/lisp/ob-tcl.el18
-rw-r--r--contrib/lisp/ob-vbnet.el84
-rw-r--r--contrib/lisp/org-annotate-file.el116
-rw-r--r--contrib/lisp/org-bibtex-extras.el38
-rw-r--r--contrib/lisp/org-bookmark.el7
-rw-r--r--contrib/lisp/org-bullets.el122
-rw-r--r--contrib/lisp/org-checklist.el2
-rw-r--r--contrib/lisp/org-choose.el2
-rw-r--r--contrib/lisp/org-collector.el2
-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.el51
-rw-r--r--contrib/lisp/org-drill.el964
-rw-r--r--contrib/lisp/org-effectiveness.el223
-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
-rw-r--r--contrib/lisp/org-git-link.el67
-rw-r--r--contrib/lisp/org-index.el5220
-rw-r--r--contrib/lisp/org-interactive-query.el4
-rw-r--r--contrib/lisp/org-invoice.el42
-rw-r--r--contrib/lisp/org-jira.el64
-rw-r--r--contrib/lisp/org-learn.el2
-rw-r--r--contrib/lisp/org-license.el99
-rw-r--r--contrib/lisp/org-link-edit.el390
-rw-r--r--contrib/lisp/org-mac-iCal.el2
-rw-r--r--contrib/lisp/org-mac-link.el859
-rw-r--r--contrib/lisp/org-mairix.el9
-rw-r--r--contrib/lisp/org-man.el6
-rw-r--r--contrib/lisp/org-mew.el26
-rw-r--r--contrib/lisp/org-mime.el340
-rw-r--r--contrib/lisp/org-mtags.el255
-rw-r--r--contrib/lisp/org-notify.el10
-rw-r--r--contrib/lisp/org-notmuch.el58
-rw-r--r--contrib/lisp/org-passwords.el384
-rw-r--r--contrib/lisp/org-registry.el2
-rw-r--r--contrib/lisp/org-screen.el2
-rw-r--r--contrib/lisp/org-screenshot.el13
-rw-r--r--contrib/lisp/org-secretary.el2
-rw-r--r--contrib/lisp/org-sudoku.el2
-rw-r--r--contrib/lisp/org-toc.el12
-rw-r--r--contrib/lisp/org-track.el3
-rw-r--r--contrib/lisp/org-velocity.el604
-rw-r--r--contrib/lisp/org-vm.el26
-rw-r--r--contrib/lisp/org-wikinodes.el32
-rw-r--r--contrib/lisp/org-wl.el23
-rw-r--r--contrib/lisp/orgtbl-sqlinsert.el2
-rw-r--r--contrib/lisp/ox-bibtex.el364
-rw-r--r--contrib/lisp/ox-confluence.el93
-rw-r--r--contrib/lisp/ox-deck.el25
-rw-r--r--contrib/lisp/ox-extra.el211
-rw-r--r--contrib/lisp/ox-freemind.el5
-rw-r--r--contrib/lisp/ox-groff.el82
-rw-r--r--contrib/lisp/ox-koma-letter.el867
-rw-r--r--contrib/lisp/ox-rss.el135
-rw-r--r--contrib/lisp/ox-s5.el33
-rw-r--r--contrib/lisp/ox-taskjuggler.el71
-rw-r--r--contrib/orgmanual.org19580
-rw-r--r--contrib/scripts/org-docco.org2
-rw-r--r--doc/Makefile16
-rw-r--r--doc/doclicense.texi2
-rw-r--r--doc/docstyle.texi10
-rw-r--r--doc/htmlxref.cnf2
-rw-r--r--doc/library-of-babel.org584
-rw-r--r--doc/org.texi9763
-rw-r--r--doc/orgcard.tex43
-rw-r--r--doc/orgguide.texi173
-rw-r--r--doc/texinfo.tex3161
-rw-r--r--etc/ORG-NEWS2027
-rw-r--r--etc/schema/od-manifest-schema-v1.2-os.rnc10
-rw-r--r--etc/schema/od-schema-v1.2-os.rnc10
-rw-r--r--etc/styles/OrgOdtStyles.xml20
-rw-r--r--etc/styles/README4
-rw-r--r--lisp/ob-C.el452
-rw-r--r--lisp/ob-J.el186
-rw-r--r--lisp/ob-R.el267
-rw-r--r--lisp/ob-abc.el40
-rw-r--r--lisp/ob-asymptote.el49
-rw-r--r--lisp/ob-awk.el48
-rw-r--r--lisp/ob-calc.el24
-rw-r--r--lisp/ob-clojure.el205
-rw-r--r--lisp/ob-comint.el37
-rw-r--r--lisp/ob-coq.el78
-rw-r--r--lisp/ob-core.el2733
-rw-r--r--lisp/ob-css.el12
-rw-r--r--lisp/ob-ditaa.el40
-rw-r--r--lisp/ob-dot.el23
-rw-r--r--lisp/ob-ebnf.el32
-rw-r--r--lisp/ob-emacs-lisp.el78
-rw-r--r--lisp/ob-eval.el38
-rw-r--r--lisp/ob-exp.el577
-rw-r--r--lisp/ob-forth.el87
-rw-r--r--lisp/ob-fortran.el72
-rw-r--r--lisp/ob-gnuplot.el91
-rw-r--r--lisp/ob-groovy.el116
-rw-r--r--lisp/ob-haskell.el65
-rw-r--r--lisp/ob-hledger.el70
-rw-r--r--lisp/ob-io.el50
-rw-r--r--lisp/ob-java.el50
-rw-r--r--lisp/ob-js.el32
-rw-r--r--lisp/ob-keys.el11
-rw-r--r--lisp/ob-latex.el166
-rw-r--r--lisp/ob-ledger.el11
-rw-r--r--lisp/ob-lilypond.el354
-rw-r--r--lisp/ob-lisp.el100
-rw-r--r--lisp/ob-lob.el200
-rw-r--r--lisp/ob-lua.el403
-rw-r--r--lisp/ob-makefile.el15
-rw-r--r--lisp/ob-matlab.el6
-rw-r--r--lisp/ob-maxima.el32
-rw-r--r--lisp/ob-mscgen.el14
-rw-r--r--lisp/ob-ocaml.el89
-rw-r--r--lisp/ob-octave.el90
-rw-r--r--lisp/ob-org.el12
-rw-r--r--lisp/ob-perl.el35
-rw-r--r--lisp/ob-picolisp.el18
-rw-r--r--lisp/ob-plantuml.el59
-rw-r--r--lisp/ob-processing.el195
-rw-r--r--lisp/ob-python.el133
-rw-r--r--lisp/ob-ref.el248
-rw-r--r--lisp/ob-ruby.el134
-rw-r--r--lisp/ob-sass.el13
-rw-r--r--lisp/ob-scala.el124
-rw-r--r--lisp/ob-scheme.el195
-rw-r--r--lisp/ob-screen.el28
-rw-r--r--lisp/ob-sed.el105
-rw-r--r--lisp/ob-sh.el212
-rw-r--r--lisp/ob-shell.el283
-rw-r--r--lisp/ob-shen.el13
-rw-r--r--lisp/ob-sql.el268
-rw-r--r--lisp/ob-sqlite.el34
-rw-r--r--lisp/ob-stan.el84
-rw-r--r--lisp/ob-table.el52
-rw-r--r--lisp/ob-tangle.el421
-rw-r--r--lisp/ob-vala.el117
-rw-r--r--lisp/ob.el6
-rw-r--r--lisp/org-agenda.el4776
-rw-r--r--lisp/org-archive.el449
-rw-r--r--lisp/org-attach.el231
-rw-r--r--lisp/org-bbdb.el158
-rw-r--r--lisp/org-bibtex.el195
-rw-r--r--lisp/org-capture.el1450
-rw-r--r--lisp/org-clock.el2227
-rw-r--r--lisp/org-colview.el2355
-rw-r--r--lisp/org-compat.el1210
-rw-r--r--lisp/org-crypt.el156
-rw-r--r--lisp/org-ctags.el122
-rw-r--r--lisp/org-datetree.el299
-rw-r--r--lisp/org-docview.el38
-rw-r--r--lisp/org-duration.el448
-rw-r--r--lisp/org-element.el6083
-rw-r--r--lisp/org-entities.el1022
-rw-r--r--lisp/org-eshell.el13
-rw-r--r--lisp/org-eww.el175
-rw-r--r--lisp/org-faces.el559
-rw-r--r--lisp/org-feed.el166
-rw-r--r--lisp/org-footnote.el1200
-rw-r--r--lisp/org-gnus.el310
-rw-r--r--lisp/org-goto.el312
-rw-r--r--lisp/org-habit.el139
-rw-r--r--lisp/org-id.el37
-rw-r--r--lisp/org-indent.el299
-rw-r--r--lisp/org-info.el109
-rw-r--r--lisp/org-inlinetask.el78
-rw-r--r--lisp/org-irc.el54
-rw-r--r--lisp/org-lint.el1242
-rw-r--r--lisp/org-list.el1573
-rw-r--r--lisp/org-macro.el324
-rw-r--r--lisp/org-macs.el867
-rw-r--r--lisp/org-mhe.el47
-rw-r--r--lisp/org-mobile.el312
-rw-r--r--lisp/org-mouse.el199
-rw-r--r--lisp/org-pcomplete.el97
-rw-r--r--lisp/org-plot.el239
-rw-r--r--lisp/org-protocol.el386
-rw-r--r--lisp/org-rmail.el38
-rw-r--r--lisp/org-src.el1587
-rw-r--r--lisp/org-table.el5294
-rw-r--r--lisp/org-timer.el390
-rw-r--r--lisp/org-w3m.el20
-rw-r--r--lisp/org.el20616
-rw-r--r--lisp/ox-ascii.el1252
-rw-r--r--lisp/ox-beamer.el440
-rw-r--r--lisp/ox-html.el2594
-rw-r--r--lisp/ox-icalendar.el562
-rw-r--r--lisp/ox-latex.el2642
-rw-r--r--lisp/ox-man.el492
-rw-r--r--lisp/ox-md.el479
-rw-r--r--lisp/ox-odt.el1969
-rw-r--r--lisp/ox-org.el180
-rw-r--r--lisp/ox-publish.el1239
-rw-r--r--lisp/ox-texinfo.el2179
-rw-r--r--lisp/ox.el4973
-rw-r--r--mk/default.mk52
-rw-r--r--mk/eldo.el6
-rwxr-xr-xmk/guidesplit.pl32
-rwxr-xr-xmk/mansplit.pl44
-rw-r--r--mk/org-fixup.el22
-rw-r--r--mk/server.mk14
-rw-r--r--mk/targets.mk41
-rw-r--r--request-assign-future.txt2
-rw-r--r--testing/README103
-rw-r--r--testing/examples/agenda-file.org5
-rw-r--r--testing/examples/babel.org88
-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/pub/a.org9
-rw-r--r--testing/examples/pub/b.org6
-rw-r--r--testing/examples/pub/file.txt1
-rw-r--r--testing/examples/pub/noextension1
-rw-r--r--testing/examples/pub/sub/c.org2
-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.el22
-rw-r--r--testing/lisp/test-ob-awk.el11
-rw-r--r--testing/lisp/test-ob-emacs-lisp.el26
-rw-r--r--testing/lisp/test-ob-exp.el391
-rw-r--r--testing/lisp/test-ob-fortran.el2
-rw-r--r--testing/lisp/test-ob-header-arg-defaults.el68
-rw-r--r--testing/lisp/test-ob-lilypond.el376
-rw-r--r--testing/lisp/test-ob-lob.el172
-rw-r--r--testing/lisp/test-ob-lua.el141
-rw-r--r--testing/lisp/test-ob-maxima.el6
-rw-r--r--testing/lisp/test-ob-octave.el2
-rw-r--r--testing/lisp/test-ob-perl.el2
-rw-r--r--testing/lisp/test-ob-plantuml.el73
-rw-r--r--testing/lisp/test-ob-python.el6
-rw-r--r--testing/lisp/test-ob-ruby.el39
-rw-r--r--testing/lisp/test-ob-scheme.el91
-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.el107
-rw-r--r--testing/lisp/test-ob-sqlite.el45
-rw-r--r--testing/lisp/test-ob-table.el4
-rw-r--r--testing/lisp/test-ob-tangle.el181
-rw-r--r--testing/lisp/test-ob-vala.el104
-rw-r--r--testing/lisp/test-ob.el1258
-rw-r--r--testing/lisp/test-org-agenda.el128
-rw-r--r--testing/lisp/test-org-archive.el63
-rw-r--r--testing/lisp/test-org-attach-annex.el95
-rw-r--r--testing/lisp/test-org-capture.el150
-rw-r--r--testing/lisp/test-org-clock.el953
-rw-r--r--testing/lisp/test-org-colview.el1514
-rw-r--r--testing/lisp/test-org-datetree.el209
-rw-r--r--testing/lisp/test-org-duration.el160
-rw-r--r--testing/lisp/test-org-element.el1920
-rw-r--r--testing/lisp/test-org-feed.el112
-rw-r--r--testing/lisp/test-org-footnote.el655
-rw-r--r--testing/lisp/test-org-info.el64
-rw-r--r--testing/lisp/test-org-inlinetask.el67
-rw-r--r--testing/lisp/test-org-lint.el503
-rw-r--r--testing/lisp/test-org-list.el715
-rw-r--r--testing/lisp/test-org-macro.el296
-rw-r--r--testing/lisp/test-org-macs.el75
-rw-r--r--testing/lisp/test-org-open-at-point.el61
-rw-r--r--testing/lisp/test-org-pcomplete.el61
-rw-r--r--testing/lisp/test-org-protocol.el196
-rw-r--r--testing/lisp/test-org-src.el399
-rw-r--r--testing/lisp/test-org-table.el1652
-rw-r--r--testing/lisp/test-org-timer.el299
-rw-r--r--testing/lisp/test-org.el5764
-rw-r--r--testing/lisp/test-ox-publish.el516
-rw-r--r--testing/lisp/test-ox.el2931
-rw-r--r--testing/lisp/test-property-inheritance.el24
-rw-r--r--testing/org-batch-test-init.el20
-rw-r--r--testing/org-test.el100
296 files changed, 107507 insertions, 55899 deletions
diff --git a/.gitignore b/.gitignore
index a9d73ad..68d94d5 100644
--- a/.gitignore
+++ b/.gitignore
@@ -33,6 +33,7 @@ org
org-loaddefs.el
org-version.el
doc/org-version.inc
+doc/org-version.tex
org-*.tar*
orgplus-*.tar*
org-*.zip
@@ -43,6 +44,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..bc1324c 100644
--- a/README_contribute
+++ b/README_contribute
@@ -1,9 +1,9 @@
-*- mode: org; fill-column:65 -*-
-This is the GIT repository for the development of Org-mode, an
+This is the GIT repository for the development of Org mode, an
Emacs mode for organizing your life.
-The text below explains the rules for participating in Org-mode
+The text below explains the rules for participating in Org mode
development.
* Main rules
@@ -23,14 +23,14 @@ development.
git clone git://repo.or.cz/org-mode.git
-3. People who are interested to participate in the Org-mode
- development can to so by sending patches to this address:
+3. People who are interested to participate in the Org mode
+ development can do so by sending patches to this address:
[[mailto:emacs-orgmode@gnu.org][emacs-orgmode@gnu.org]]
4. An interested developer can also request push access to the
central repository by sending her/his user-info to the
- maintainer of Org-mode or the webmaster of orgmode.org.
+ maintainer of Org mode or the webmaster of orgmode.org.
After you have been added as a user with push privileges,
clone the repository through ssh using
@@ -40,8 +40,8 @@ development.
By requesting push access, you acknowledge that you have read
and agreed with the following rules:
- - Org-mode is part of GNU Emacs. Therefore, we need to be
- very conscious about changes moving into the Org-mode core.
+ - Org mode is part of GNU Emacs. Therefore, we need to be
+ very conscious about changes moving into the Org mode core.
These can originate only from people who have signed the
appropriate papers with the Free Software Foundation. The
files to which this applies are:
@@ -54,16 +54,16 @@ development.
discuss them on the mailing list emacs-orgmode@gnu.org.
This does obviously not apply to people who are maintaining
- their own contributions to Org-mode. Please, just use the
+ their own contributions to Org mode. Please, just use the
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
+ - Among other things, Org mode is widely appreciated because
of its simplicity, cleanness and consistency. We should try
hard to preserve this and I would like to ask everyone to
keep this in mind when developing changes.
@@ -74,15 +74,15 @@ The git repository contains a contrib directory. This directory
is the playing field for any developer, also people who have not
(yet) signed the papers with the FSF. You are free to add files
to this directory, implementing extensions, new link types etc.
-Also non-Lisp extensions like scripts to process Org-mode files
-in different ways are welcome in this directory. You should
-provide documentation with your extensions, at least in the form
-of commentary in the file, better on worg. Please discuss your
+Also non-Lisp extensions like scripts to process Org files in
+different ways are welcome in this directory. You should provide
+documentation with your extensions, at least in the form of
+commentary in the file, better on worg. Please discuss your
extensions on [[mailto:emacs-orgmode@gnu.org][emacs-orgmode@gnu.org]].
After files have been tested in contrib and found to be generally
useful, we may decide to clarify copyright questions and then
-move the file into the Org-mode core. This means they will be
+move the file into the Org mode core. This means they will be
moved up to the root directory and will also eventually be added
to GNU Emacs bzr repository. The final decision about this rests
with the maintainer.
diff --git a/README_maintainer b/README_maintainer
index 04dc2c0..6cf2bb2 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.
@@ -87,125 +88,110 @@ Org and contributed libraries.
org-latest* snapshots are built from the *master* branch.
-* Synchronization with Emacs
-
-** Updating etc/ORG-NEWS
-
-Latest changes in Emacs are described in Emacs =etc/NEWS=, and latest
-changes in major Emacs packages are described in =etc/ORG-NEWS=.
-
-If a major release is meant to be merged with the Emacs trunk (as it
-always should), you need to update Org's =etc/ORG-NEWS= file so that
-you can merge it with that of Emacs. There is one top-level section
-for each release that is merged with Emacs.
-
-** Merging with Emacs trunk branch
-
-This is still a significant headache. Some hand work is needed here.
-
-Emacs uses bzr. A useful introduction to bzr for Emacs developers can
-be found [[http://www.emacswiki.org/emacs/BzrForEmacsDevs][here]]. While I see all the advantages this would have, I
-cannot bring myself to switch away from git for my day-to-day work,
-because I know git so well, and because git seems to me as being much
-more powerful, conceptionally simple (once you have [[http://newartisans.com/2008/04/git-from-the-bottom-up/][bent your head
-around it]]), and so much faster.
-
-So the way I have been doing things with Emacs is this:
-
-1. I do not update the version in Emacs too often. Just once every
- few months - this is frequently enough for the Emacs release cycle.
- Care must be taken to get in a *new and stable* version shortly
- before Emacs goes into feature freeze and pretest, because that
- version is going to be in the wild for a long time.
-
-2. I watch the Emacs diffs for changes made by the maintainers of
- Emacs in the org-mode files in Emacs. Any changes that come up
- there, I merge into the development version of Org-mode.
- Occasionally I do not do this, if I do not agree with a change.
- The changes go into Org /without/ a ChangeLog-like entry in the
- commit message. The reason for this is that we will later generate
- a ChangeLog file from our commit messages, and I do not want double
- ChangeLog entries in the Emacs ChangeLog file.
-
-3. When I have made a release (usually I wait for the minor releases
- to stabilize), I *copy* org files into the Emacs repository. Yes,
- I do not merge, I copy. This has been the source of some problems
- in the past - Emacs developers are not happy when I accidentally
- overwrite changes they made. But I have not had the patience to
- work out a better mechanism, and I really dislike the idea that the
- version in Emacs starts diverging from my own.
-
- Careful: Copy /org.texi/ and /orgcard.tex/ into the right places,
- and also copy the lisp files with *one exception*: Do *not* copy
- /org-loaddefs.el/, Emacs generates its own autoloads.
-
-4. Generate the ChangeLog entries
-
- For this, I do in the org-mode git repository
-
- : mk/make_emacs_changelog release_7.02.05..release_7.03.02
-
- This will spit out ChangeLog entries (for the given commit range)
- that need to go into the ChangeLog files in Emacs. Org-mode
- contributes to 3 different ChangeLog files in Emacs:
-
- : lisp/org/ChangeLog (for lisp changes)
- : doc/misc/ChangeLog (for org.texi changes)
- : etc/ChangeLog (for refcard changes)
-
- When you run the =make_emacs_changelog= program, you will be
- prompted for a date in ISO format YYYY-MM-DD, this date will be
- used in the ChangeLog entries - Emacs developers want these dates
- to be the time when the change has been installed into Emacs, not
- the time when we made the change in our own repository. So all the
- ChangeLog entries will get the same date. You will also be
- prompted for the kind of ChangeLog you want to make, possible
- answers are =lisp=, =texi=, and =card=. The program will then
- select the correct entries for the specified ChangeLog file. If
- you don't like being prompted, you can give the date and type as
- second and third command line arguments to =make_emacs_changelog=,
- for example
-
- : mk/make_emacs_changelog release_7.02.05..release_7.03.02 2010-12-11 lisp
-
- These entries need to be added to the ChangeLog files in Emacs.
- You should, in the ChangeLog file, select the inserted region of
- new entries and do =M-x fill-region=, so that the entries are
- formatted correctly. I then do look through the entries quickly to
- make sure they are formatted properly, that the email addresses
- look right etc.
-
-5. Commit the changes into the bzr repository and you are done. Emacs
- developers often look throught the commit and make minor changes -
- these need to be merged back into our own repo.
+* Synchronization Org and upstream Emacs
+
+Below it is described how Org is kept in sync with the upstream Emacs.
+
+** Backporting changes from upstream Emacs
+
+Sometimes Emacs maintainers make changes to Org files. The process of
+propagating the changes back to the Org repository is called
+/backporting/ for historical reasons.
+
+To find changes that need to be backported from the Emacs repository,
+the following =git= command, courtesy of [[http://permalink.gmane.org/gmane.emacs.devel/215861][Kyle Meyer]], can be used:
+
+#+begin_src shell
+ git log $rev..origin/emacs-25 -- lisp/org doc/misc/org.texi \
+ etc/refcards/orgcard.tex etc/ORG-NEWS etc/org \
+ etc/schema/od-manifest-schema-v1.2-os.rnc \
+ etc/schema/od-schema-v1.2-os.rnc
+#+end_src
+
+here, =$rev= is the last commit from the =emacs-25= branch that was
+backported. The should also be done for the =master= branch.
+
+There is also a [[http://git.savannah.gnu.org/cgit/emacs.git/atom/lisp/org/][feed]] to keep track of new changes in the =lisp/org=
+folder in the Emacs repository.
+
+** Updating the Org version in upstream Emacs
+
+New releases of Org should be added to the [[https://git.savannah.gnu.org/cgit/emacs.git][Emacs repository]].
+
+Typically, Org can be synchronized by copying over files from the
+=emacs-sync= branch of the Org repository to the =master= branch of Emacs
+repository. The =emacs-sync= branch has a few extra changes compared with
+the =maint= branch. If the Emacs maintainers are planning a new release
+of Emacs soon, it is possible that another branch should be used.
+
+If the new release of Org contains many changes, it may be useful to
+use a separate branch before merging, e.g. =scratch/org-mode-merge=.
+This branch can then be merged with the =master= branch, when everything
+has been tested.
+
+Please see [[http://git.savannah.gnu.org/cgit/emacs.git/tree/CONTRIBUTE][CONTRIBUTE]] in the Emacs repository for guidelines on
+contributing to the Emacs repository.
+
+*** Where to files go
+
+The following list shows where files in Org repository are copied to in
+the Emacs repository, folder by folder.
+
+**** =org-mode/doc=
+
+- =org.texi= :: Copy to =emacs/doc/misc=. It may be necessary to replace,
+ ~@include org-version.inc~ with ~@set VERSION 9.0.9~ or similar.
+
+- =orgcard.tex= :: Copy to =emacs/etc/refcards=. Make sure that
+ ~\def\orgversionnumber~ and ~\def\versionyear~ are up to date.
+
+**** =org-mode/etc=
+
+- =styles/*= :: Copy to =emacs/etc/org=.
+
+- =schema/*.rnc= :: Copy to =emacs/etc/schema=.
+
+- =schema/schemas.xml= :: Any new entries in this file should be added
+ to =emacs/etc/schema/schemas.xml=.
+
+- =ORG-NEWS= :: Copy to =emacs/etc=
+
+**** =org-mode/lisp=
+
+- Copy =*.el= files to =emacs/lisp/org=, except =org-loaddefs.el=!
+
+- You should create =org-version.el= in =emacs/lisp/org=. The file is
+ created when you =make= Org.
+
+**** TODO =org-mode/testing=
* Updating the list of hooks/commands/options on Worg
- Load the =mk/eldo.el= file then =M-x eldo-make-doc RET=.
+Load the =mk/eldo.el= file then =M-x eldo-make-doc RET=.
- This will produce an org file with the documentation.
+This will produce an org file with the documentation.
- Import this file into =worg/doc.org=, leaving the header untouched
- (except for the release number).
+Import this file into =worg/doc.org=, leaving the header untouched
+(except for the release number).
- Then commit and push the change on the =worg.git= repository.
+Then commit and push the change on the =worg.git= repository.
* Copyright assignments
- The maintainer needs to keep track of copyright assignments.
- Even better, find a volunteer to do this.
+The maintainer needs to keep track of copyright assignments. Even
+better, find a volunteer to do this.
- The assignment form is included in the repository as a file that
- you can send to contributors: =request-assign-future.txt=
+The assignment form is included in the repository as a file that you
+can send to contributors: =request-assign-future.txt=
- The list of all contributors from who we have the papers is kept on
- Worg at http://orgmode.org/worg/org-contribute.html, so that
- committers can check if a patch can go into the core.
+The list of all contributors from who we have the papers is kept on
+Worg at http://orgmode.org/worg/org-contribute.html, so that
+committers can check if a patch can go into the core.
- The assignment process does not allways go smoothly, and it has
- happened several times that it gets stuck or forgotten at the FSF.
- The contact at the FSF for this is: mailto:copyright-clerk@fsf.org
+The assignment process does not allways go smoothly, and it has
+happened several times that it gets stuck or forgotten at the FSF.
+The contact at the FSF for this is: mailto:copyright-clerk@fsf.org
- Emails from the paper submitter have been ignored in the past, but
- an email from me (Carsten) as the maintainer of Org mode has usually
- fixed such cases within a few days.
+Emails from the paper submitter have been ignored in the past, but an
+email from me (Carsten) as the maintainer of Org mode has usually
+fixed such cases within a few days.
diff --git a/contrib/README b/contrib/README
index 15df87c..ae4f96b 100644
--- a/contrib/README
+++ b/contrib/README
@@ -15,7 +15,6 @@ Org utils
org-annotate-file.el --- Annotate a file with org syntax
org-bibtex-extras.el --- Extras for working with org-bibtex entries
org-bookmark.el --- Links to bookmarks
-org-bullets.el --- Show bullets in org-mode as UTF-8 characters
org-checklist.el --- org functions for checklist handling
org-choose.el --- Use TODO keywords to mark decision states
org-collector.el --- Collect properties into tables
@@ -24,7 +23,9 @@ 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
@@ -34,11 +35,11 @@ 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 +80,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
deleted file mode 100644
index 3bf5949..0000000
--- a/contrib/lisp/htmlize.el
+++ b/dev/null
@@ -1,1945 +0,0 @@
-;;; htmlize.el --- Convert buffer text and decorations to HTML.
-
-;; Copyright (C) 1997-2013 Hrvoje Niksic
-
-;; Author: Hrvoje Niksic <hniksic@xemacs.org>
-;; Keywords: hypermedia, extensions
-;; Version: 1.43
-
-;; 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 2, or (at your option)
-;; any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Commentary:
-
-;; This package converts the buffer text and the associated
-;; decorations to HTML. Mail to <hniksic@xemacs.org> to discuss
-;; features and additions. All suggestions are more than welcome.
-
-;; To use it, just switch to the buffer you want HTML-ized and type
-;; `M-x htmlize-buffer'. You will be switched to a new buffer that
-;; contains the resulting HTML code. You can edit and inspect this
-;; buffer, or you can just save it with C-x C-w. `M-x htmlize-file'
-;; will find a file, fontify it, and save the HTML version in
-;; FILE.html, without any additional intervention. `M-x
-;; htmlize-many-files' allows you to htmlize any number of files in
-;; the same manner. `M-x htmlize-many-files-dired' does the same for
-;; files marked in a dired buffer.
-
-;; htmlize supports three types of HTML output, selected by setting
-;; `htmlize-output-type': `css', `inline-css', and `font'. In `css'
-;; mode, htmlize uses cascading style sheets to specify colors; it
-;; generates classes that correspond to Emacs faces and uses <span
-;; class=FACE>...</span> to color parts of text. In this mode, the
-;; produced HTML is valid under the 4.01 strict DTD, as confirmed by
-;; the W3C validator. `inline-css' is like `css', except the CSS is
-;; put directly in the STYLE attribute of the SPAN element, making it
-;; possible to paste the generated HTML into existing HTML documents.
-;; In `font' mode, htmlize uses <font color="...">...</font> to
-;; colorize HTML, which is not standard-compliant, but works better in
-;; older browsers. `css' mode is the default.
-
-;; You can also use htmlize from your Emacs Lisp code. When called
-;; non-interactively, `htmlize-buffer' and `htmlize-region' will
-;; return the resulting HTML buffer, but will not change current
-;; buffer or move the point. htmlize will do its best to work on
-;; non-windowing Emacs sessions but the result will be limited to
-;; colors supported by the terminal.
-
-;; htmlize aims for compatibility with Emacsen version 21 and later.
-;; Please let me know if it doesn't work on the version of XEmacs or
-;; GNU Emacs that you are using. The package relies on the presence
-;; of CL extensions, especially for cross-emacs compatibility; please
-;; don't try to remove that dependency. I see no practical problems
-;; with using the full power of the CL extensions, except that one
-;; might learn to like them too much.
-
-;; The latest version is available as a git repository at:
-;;
-;; <http://fly.srk.fer.hr/~hniksic/emacs/htmlize.git>
-;;
-;; The snapshot of the latest release can be obtained at:
-;;
-;; <http://fly.srk.fer.hr/~hniksic/emacs/htmlize.el.cgi>
-;;
-;; You can find a sample of htmlize's output (possibly generated with
-;; an older version) at:
-;;
-;; <http://fly.srk.fer.hr/~hniksic/emacs/htmlize.el.html>
-
-;; Thanks go to the many people who have sent reports and contributed
-;; comments, suggestions, and fixes. They include Ron Gut, Bob
-;; Weiner, Toni Drabik, Peter Breton, Ville Skytta, Thomas Vogels,
-;; Juri Linkov, Maciek Pasternacki, and many others.
-
-;; User quotes: "You sir, are a sick, sick, _sick_ person. :)"
-;; -- Bill Perry, author of Emacs/W3
-
-
-;;; Code:
-
-(require 'cl)
-(eval-when-compile
- (defvar unresolved)
- (if (string-match "XEmacs" emacs-version)
- (byte-compiler-options
- (warnings (- unresolved))))
- (defvar font-lock-auto-fontify)
- (defvar font-lock-support-mode)
- (defvar global-font-lock-mode))
-
-(defconst htmlize-version "1.43")
-
-(defgroup htmlize nil
- "Convert buffer text and faces to HTML."
- :group 'hypermedia)
-
-(defcustom htmlize-head-tags ""
- "Additional tags to insert within HEAD of the generated document."
- :type 'string
- :group 'htmlize)
-
-(defcustom htmlize-output-type 'css
- "Output type of generated HTML, one of `css', `inline-css', or `font'.
-When set to `css' (the default), htmlize will generate a style sheet
-with description of faces, and use it in the HTML document, specifying
-the faces in the actual text with <span class=\"FACE\">.
-
-When set to `inline-css', the style will be generated as above, but
-placed directly in the STYLE attribute of the span ELEMENT: <span
-style=\"STYLE\">. This makes it easier to paste the resulting HTML to
-other documents.
-
-When set to `font', the properties will be set using layout tags
-<font>, <b>, <i>, <u>, and <strike>.
-
-`css' output is normally preferred, but `font' is still useful for
-supporting old, pre-CSS browsers, and both `inline-css' and `font' for
-easier embedding of colorized text in foreign HTML documents (no style
-sheet to carry around)."
- :type '(choice (const css) (const inline-css) (const font))
- :group 'htmlize)
-
-(defcustom htmlize-use-images t
- "Whether htmlize generates `img' for images attached to buffer contents."
- :type 'boolean
- :group 'htmlize)
-
-(defcustom htmlize-force-inline-images nil
- "Non-nil means generate all images inline using data URLs.
-Normally htmlize converts image descriptors with :file properties to
-relative URIs, and those with :data properties to data URIs. With this
-flag set, the images specified as a file name are loaded into memory and
-embedded in the HTML as data URIs."
- :type 'boolean
- :group 'htmlize)
-
-(defcustom htmlize-max-alt-text 100
- "Maximum size of text to use as ALT text in images.
-
-Normally when htmlize encounters text covered by the `display' property
-that specifies an image, it generates an `alt' attribute containing the
-original text. If the text is larger than `htmlize-max-alt-text' characters,
-this will not be done.")
-
-(defcustom htmlize-transform-image 'htmlize-default-transform-image
- "Function called to modify the image descriptor.
-
-The function is called with the image descriptor found in the buffer and
-the text the image is supposed to replace. It should return a (possibly
-different) image descriptor property list or a replacement string to use
-instead of of the original buffer text.
-
-Returning nil is the same as returning the original text."
- :type 'boolean
- :group 'htmlize)
-
-(defcustom htmlize-generate-hyperlinks t
- "Non-nil means auto-generate the links from URLs and mail addresses in buffer.
-
-This is on by default; set it to nil if you don't want htmlize to
-autogenerate such links. Note that this option only turns off automatic
-search for contents that looks like URLs and converting them to links.
-It has no effect on whether htmlize respects the `htmlize-link' property."
- :type 'boolean
- :group 'htmlize)
-
-(defcustom htmlize-hyperlink-style "
- a {
- color: inherit;
- background-color: inherit;
- font: inherit;
- text-decoration: inherit;
- }
- a:hover {
- text-decoration: underline;
- }
-"
- "The CSS style used for hyperlinks when in CSS mode."
- :type 'string
- :group 'htmlize)
-
-(defcustom htmlize-replace-form-feeds t
- "Non-nil means replace form feeds in source code with HTML separators.
-Form feeds are the ^L characters at line beginnings that are sometimes
-used to separate sections of source code. If this variable is set to
-`t', form feed characters are replaced with the <hr> separator. If this
-is a string, it specifies the replacement to use. Note that <pre> is
-temporarily closed before the separator is inserted, so the default
-replacement is effectively \"</pre><hr /><pre>\". If you specify
-another replacement, don't forget to close and reopen the <pre> if you
-want the output to remain valid HTML.
-
-If you need more elaborate processing, set this to nil and use
-htmlize-after-hook."
- :type 'boolean
- :group 'htmlize)
-
-(defcustom htmlize-html-charset nil
- "The charset declared by the resulting HTML documents.
-When non-nil, causes htmlize to insert the following in the HEAD section
-of the generated HTML:
-
- <meta http-equiv=\"Content-Type\" content=\"text/html; charset=CHARSET\">
-
-where CHARSET is the value you've set for htmlize-html-charset. Valid
-charsets are defined by MIME and include strings like \"iso-8859-1\",
-\"iso-8859-15\", \"utf-8\", etc.
-
-If you are using non-Latin-1 charsets, you might need to set this for
-your documents to render correctly. Also, the W3C validator requires
-submitted HTML documents to declare a charset. So if you care about
-validation, you can use this to prevent the validator from bitching.
-
-Needless to say, if you set this, you should actually make sure that
-the buffer is in the encoding you're claiming it is in. (This is
-normally achieved by using the correct file coding system for the
-buffer.) If you don't understand what that means, you should probably
-leave this option in its default setting."
- :type '(choice (const :tag "Unset" nil)
- string)
- :group 'htmlize)
-
-(defcustom htmlize-convert-nonascii-to-entities t
- "Whether non-ASCII characters should be converted to HTML entities.
-
-When this is non-nil, characters with codes in the 128-255 range will be
-considered Latin 1 and rewritten as \"&#CODE;\". Characters with codes
-above 255 will be converted to \"&#UCS;\", where UCS denotes the Unicode
-code point of the character. If the code point cannot be determined,
-the character will be copied unchanged, as would be the case if the
-option were nil.
-
-When the option is nil, the non-ASCII characters are copied to HTML
-without modification. In that case, the web server and/or the browser
-must be set to understand the encoding that was used when saving the
-buffer. (You might also want to specify it by setting
-`htmlize-html-charset'.)
-
-Note that in an HTML entity \"&#CODE;\", CODE is always a UCS code point,
-which has nothing to do with the charset the page is in. For example,
-\"&#169;\" *always* refers to the copyright symbol, regardless of charset
-specified by the META tag or the charset sent by the HTTP server. In
-other words, \"&#169;\" is exactly equivalent to \"&copy;\".
-
-For most people htmlize will work fine with this option left at the
-default setting; don't change it unless you know what you're doing."
- :type 'sexp
- :group 'htmlize)
-
-(defcustom htmlize-ignore-face-size 'absolute
- "Whether face size should be ignored when generating HTML.
-If this is nil, face sizes are used. If set to t, sizes are ignored
-If set to `absolute', only absolute size specifications are ignored.
-Please note that font sizes only work with CSS-based output types."
- :type '(choice (const :tag "Don't ignore" nil)
- (const :tag "Ignore all" t)
- (const :tag "Ignore absolute" absolute))
- :group 'htmlize)
-
-(defcustom htmlize-css-name-prefix ""
- "The prefix used for CSS names.
-The CSS names that htmlize generates from face names are often too
-generic for CSS files; for example, `font-lock-type-face' is transformed
-to `type'. Use this variable to add a prefix to the generated names.
-The string \"htmlize-\" is an example of a reasonable prefix."
- :type 'string
- :group 'htmlize)
-
-(defcustom htmlize-use-rgb-txt t
- "Whether `rgb.txt' should be used to convert color names to RGB.
-
-This conversion means determining, for instance, that the color
-\"IndianRed\" corresponds to the (205, 92, 92) RGB triple. `rgb.txt'
-is the X color database that maps hundreds of color names to such RGB
-triples. When this variable is non-nil, `htmlize' uses `rgb.txt' to
-look up color names.
-
-If this variable is nil, htmlize queries Emacs for RGB components of
-colors using `color-instance-rgb-components' and `color-values'.
-This can yield incorrect results on non-true-color displays.
-
-If the `rgb.txt' file is not found (which will be the case if you're
-running Emacs on non-X11 systems), this option is ignored."
- :type 'boolean
- :group 'htmlize)
-
-(defcustom htmlize-html-major-mode nil
- "The mode the newly created HTML buffer will be put in.
-Set this to nil if you prefer the default (fundamental) mode."
- :type '(radio (const :tag "No mode (fundamental)" nil)
- (function-item html-mode)
- (function :tag "User-defined major mode"))
- :group 'htmlize)
-
-(defvar htmlize-before-hook nil
- "Hook run before htmlizing a buffer.
-The hook functions are run in the source buffer (not the resulting HTML
-buffer).")
-
-(defvar htmlize-after-hook nil
- "Hook run after htmlizing a buffer.
-Unlike `htmlize-before-hook', these functions are run in the generated
-HTML buffer. You may use them to modify the outlook of the final HTML
-output.")
-
-(defvar htmlize-file-hook nil
- "Hook run by `htmlize-file' after htmlizing a file, but before saving it.")
-
-(defvar htmlize-buffer-places)
-
-;;; Some cross-Emacs compatibility.
-
-;; I try to conditionalize on features rather than Emacs version, but
-;; in some cases checking against the version *is* necessary.
-(defconst htmlize-running-xemacs (string-match "XEmacs" emacs-version))
-
-;; We need a function that efficiently finds the next change of a
-;; property regardless of whether the change occurred because of a
-;; text property or an extent/overlay.
-(cond
- (htmlize-running-xemacs
- (defun htmlize-next-change (pos prop &optional limit)
- (if prop
- (next-single-char-property-change pos prop nil (or limit (point-max)))
- (next-property-change pos nil (or limit (point-max)))))
- (defun htmlize-next-face-change (pos &optional limit)
- (htmlize-next-change pos 'face limit)))
- ((fboundp 'next-single-char-property-change)
- ;; GNU Emacs 21+
- (defun htmlize-next-change (pos prop &optional limit)
- (if prop
- (next-single-char-property-change pos prop nil limit)
- (next-char-property-change pos limit)))
- (defun htmlize-overlay-faces-at (pos)
- (delq nil (mapcar (lambda (o) (overlay-get o 'face)) (overlays-at pos))))
- (defun htmlize-next-face-change (pos &optional limit)
- ;; (htmlize-next-change pos 'face limit) would skip over entire
- ;; overlays that specify the `face' property, even when they
- ;; contain smaller text properties that also specify `face'.
- ;; Emacs display engine merges those faces, and so must we.
- (or limit
- (setq limit (point-max)))
- (let ((next-prop (next-single-property-change pos 'face nil limit))
- (overlay-faces (htmlize-overlay-faces-at pos)))
- (while (progn
- (setq pos (next-overlay-change pos))
- (and (< pos next-prop)
- (equal overlay-faces (htmlize-overlay-faces-at pos)))))
- (setq pos (min pos next-prop))
- ;; Additionally, we include the entire region that specifies the
- ;; `display' property.
- (when (get-char-property pos 'display)
- (setq pos (next-single-char-property-change pos 'display nil limit)))
- pos)))
- (t
- (error "htmlize requires next-single-property-change or \
-next-single-char-property-change")))
-
-(defmacro htmlize-lexlet (&rest letforms)
- (declare (indent 1) (debug let))
- (if (and (boundp 'lexical-binding)
- lexical-binding)
- `(let ,@letforms)
- ;; cl extensions have a macro implementing lexical let
- `(lexical-let ,@letforms)))
-
-;; Simple overlay emulation for XEmacs
-
-(cond
- (htmlize-running-xemacs
- (defalias 'htmlize-make-overlay 'make-extent)
- (defalias 'htmlize-overlay-put 'set-extent-property)
- (defalias 'htmlize-overlay-get 'extent-property)
- (defun htmlize-overlays-in (beg end) (extent-list nil beg end))
- (defalias 'htmlize-delete-overlay 'detach-extent))
- (t
- (defalias 'htmlize-make-overlay 'make-overlay)
- (defalias 'htmlize-overlay-put 'overlay-put)
- (defalias 'htmlize-overlay-get 'overlay-get)
- (defalias 'htmlize-overlays-in 'overlays-in)
- (defalias 'htmlize-delete-overlay 'delete-overlay)))
-
-
-;;; Transformation of buffer text: HTML escapes, untabification, etc.
-
-(defvar htmlize-basic-character-table
- ;; Map characters in the 0-127 range to either one-character strings
- ;; or to numeric entities.
- (let ((table (make-vector 128 ?\0)))
- ;; Map characters in the 32-126 range to themselves, others to
- ;; &#CODE entities;
- (dotimes (i 128)
- (setf (aref table i) (if (and (>= i 32) (<= i 126))
- (char-to-string i)
- (format "&#%d;" i))))
- ;; Set exceptions manually.
- (setf
- ;; Don't escape newline, carriage return, and TAB.
- (aref table ?\n) "\n"
- (aref table ?\r) "\r"
- (aref table ?\t) "\t"
- ;; Escape &, <, and >.
- (aref table ?&) "&amp;"
- (aref table ?<) "&lt;"
- (aref table ?>) "&gt;"
- ;; Not escaping '"' buys us a measurable speedup. It's only
- ;; necessary to quote it for strings used in attribute values,
- ;; which htmlize doesn't typically do.
- ;(aref table ?\") "&quot;"
- )
- table))
-
-;; A cache of HTML representation of non-ASCII characters. Depending
-;; on the setting of `htmlize-convert-nonascii-to-entities', this maps
-;; non-ASCII characters to either "&#<code>;" or "<char>" (mapconcat's
-;; mapper must always return strings). It's only filled as characters
-;; are encountered, so that in a buffer with e.g. French text, it will
-;; only ever contain French accented characters as keys. It's cleared
-;; on each entry to htmlize-buffer-1 to allow modifications of
-;; `htmlize-convert-nonascii-to-entities' to take effect.
-(defvar htmlize-extended-character-cache (make-hash-table :test 'eq))
-
-(defun htmlize-protect-string (string)
- "HTML-protect string, escaping HTML metacharacters and I18N chars."
- ;; Only protecting strings that actually contain unsafe or non-ASCII
- ;; chars removes a lot of unnecessary funcalls and consing.
- (if (not (string-match "[^\r\n\t -%'-;=?-~]" string))
- string
- (mapconcat (lambda (char)
- (cond
- ((< char 128)
- ;; ASCII: use htmlize-basic-character-table.
- (aref htmlize-basic-character-table char))
- ((gethash char htmlize-extended-character-cache)
- ;; We've already seen this char; return the cached
- ;; string.
- )
- ((not htmlize-convert-nonascii-to-entities)
- ;; If conversion to entities is not desired, always
- ;; copy the char literally.
- (setf (gethash char htmlize-extended-character-cache)
- (char-to-string char)))
- ((< char 256)
- ;; Latin 1: no need to call encode-char.
- (setf (gethash char htmlize-extended-character-cache)
- (format "&#%d;" char)))
- ((encode-char char 'ucs)
- ;; Must check if encode-char works for CHAR;
- ;; it fails for Arabic and possibly elsewhere.
- (setf (gethash char htmlize-extended-character-cache)
- (format "&#%d;" (encode-char char 'ucs))))
- (t
- ;; encode-char doesn't work for this char. Copy it
- ;; unchanged and hope for the best.
- (setf (gethash char htmlize-extended-character-cache)
- (char-to-string char)))))
- string "")))
-
-(defun htmlize-attr-escape (string)
- ;; Like htmlize-protect-string, but also escapes double-quoted
- ;; strings to make it usable in attribute values.
- (setq string (htmlize-protect-string string))
- (if (not (string-match "\"" string))
- string
- (mapconcat (lambda (char)
- (if (eql char ?\")
- "&quot;"
- (char-to-string char)))
- string "")))
-
-(defsubst htmlize-concat (list)
- (if (and (consp list) (null (cdr list)))
- ;; Don't create a new string in the common case where the list only
- ;; consists of one element.
- (car list)
- (apply #'concat list)))
-
-(defun htmlize-format-link (linkprops text)
- (let ((uri (if (stringp linkprops)
- linkprops
- (plist-get linkprops :uri)))
- (escaped-text (htmlize-protect-string text)))
- (if uri
- (format "<a href=\"%s\">%s</a>" (htmlize-attr-escape uri) escaped-text)
- escaped-text)))
-
-(defun htmlize-escape-or-link (string)
- ;; Escape STRING and/or add hyperlinks. STRING comes from a
- ;; `display' property.
- (let ((pos 0) (end (length string)) outlist)
- (while (< pos end)
- (let* ((link (get-char-property pos 'htmlize-link string))
- (next-link-change (next-single-property-change
- pos 'htmlize-link string end))
- (chunk (substring string pos next-link-change)))
- (push
- (cond (link
- (htmlize-format-link link chunk))
- ((get-char-property 0 'htmlize-literal chunk)
- chunk)
- (t
- (htmlize-protect-string chunk)))
- outlist)
- (setq pos next-link-change)))
- (htmlize-concat (nreverse outlist))))
-
-(defun htmlize-display-prop-to-html (display text)
- (let (desc)
- (cond ((stringp display)
- ;; Emacs ignores recursive display properties.
- (htmlize-escape-or-link display))
- ((not (eq (car-safe display) 'image))
- (htmlize-protect-string text))
- ((null (setq desc (funcall htmlize-transform-image
- (cdr display) text)))
- (htmlize-escape-or-link text))
- ((stringp desc)
- (htmlize-escape-or-link desc))
- (t
- (htmlize-generate-image desc text)))))
-
-(defun htmlize-string-to-html (string)
- ;; Convert the string to HTML, including images attached as
- ;; `display' property and links as `htmlize-link' property. In a
- ;; string without images or links, this is equivalent to
- ;; `htmlize-protect-string'.
- (let ((pos 0) (end (length string)) outlist)
- (while (< pos end)
- (let* ((display (get-char-property pos 'display string))
- (next-display-change (next-single-property-change
- pos 'display string end))
- (chunk (substring string pos next-display-change)))
- (push
- (if display
- (htmlize-display-prop-to-html display chunk)
- (htmlize-escape-or-link chunk))
- outlist)
- (setq pos next-display-change)))
- (htmlize-concat (nreverse outlist))))
-
-(defun htmlize-default-transform-image (imgprops _text)
- "Default transformation of image descriptor to something usable in HTML.
-
-If `htmlize-use-images' is nil, the function always returns nil, meaning
-use original text. Otherwise, it tries to find the image for images that
-specify a file name. If `htmlize-force-inline-images' is non-nil, it also
-converts the :file attribute to :data and returns the modified property
-list."
- (when htmlize-use-images
- (when (plist-get imgprops :file)
- (let ((location (plist-get (cdr (find-image (list imgprops))) :file)))
- (when location
- (setq imgprops (plist-put (copy-list imgprops) :file location)))))
- (if htmlize-force-inline-images
- (let ((location (plist-get imgprops :file))
- data)
- (when location
- (with-temp-buffer
- (condition-case nil
- (progn
- (insert-file-contents-literally location)
- (setq data (buffer-string)))
- (error nil))))
- ;; if successful, return the new plist, otherwise return
- ;; nil, which will use the original text
- (and data
- (plist-put (plist-put imgprops :file nil)
- :data data)))
- imgprops)))
-
-(defun htmlize-alt-text (_imgprops origtext)
- (and (/= (length origtext) 0)
- (<= (length origtext) htmlize-max-alt-text)
- (not (string-match "[\0-\x1f]" origtext))
- origtext))
-
-(defun htmlize-generate-image (imgprops origtext)
- (let* ((alt-text (htmlize-alt-text imgprops origtext))
- (alt-attr (if alt-text
- (format " alt=\"%s\"" (htmlize-attr-escape alt-text))
- "")))
- (cond ((plist-get imgprops :file)
- ;; Try to find the image in image-load-path
- (let* ((found-props (cdr (find-image (list imgprops))))
- (file (or (plist-get found-props :file)
- (plist-get imgprops :file))))
- (format "<img src=\"%s\"%s />"
- (htmlize-attr-escape (file-relative-name file))
- alt-attr)))
- ((plist-get imgprops :data)
- (if (equalp (plist-get imgprops :type) 'svg)
- (plist-get imgprops :data)
- (format "<img src=\"data:image/%s;base64,%s\"%s />"
- (or (plist-get imgprops :type) "")
- (base64-encode-string (plist-get imgprops :data))
- alt-attr))))))
-
-(defconst htmlize-ellipsis "...")
-(put-text-property 0 (length htmlize-ellipsis) 'htmlize-ellipsis t htmlize-ellipsis)
-
-(defun htmlize-match-inv-spec (inv)
- (member* inv buffer-invisibility-spec
- :key (lambda (i)
- (if (symbolp i) i (car i)))))
-
-(defun htmlize-decode-invisibility-spec (invisible)
- ;; Return t, nil, or `ellipsis', depending on how invisible text should be inserted.
-
- (if (not (listp buffer-invisibility-spec))
- ;; If buffer-invisibility-spec is not a list, then all
- ;; characters with non-nil `invisible' property are visible.
- (not invisible)
-
- ;; Otherwise, the value of a non-nil `invisible' property can be:
- ;; 1. a symbol -- make the text invisible if it matches
- ;; buffer-invisibility-spec.
- ;; 2. a list of symbols -- make the text invisible if
- ;; any symbol in the list matches
- ;; buffer-invisibility-spec.
- ;; If the match of buffer-invisibility-spec has a non-nil
- ;; CDR, replace the invisible text with an ellipsis.
- (let ((match (if (symbolp invisible)
- (htmlize-match-inv-spec invisible)
- (some #'htmlize-match-inv-spec invisible))))
- (cond ((null match) t)
- ((cdr-safe (car match)) 'ellipsis)
- (t nil)))))
-
-(defun htmlize-add-before-after-strings (beg end text)
- ;; Find overlays specifying before-string and after-string in [beg,
- ;; pos). If any are found, splice them into TEXT and return the new
- ;; text.
- (let (additions)
- (dolist (overlay (overlays-in beg end))
- (let ((before (overlay-get overlay 'before-string))
- (after (overlay-get overlay 'after-string)))
- (when after
- (push (cons (- (overlay-end overlay) beg)
- after)
- additions))
- (when before
- (push (cons (- (overlay-start overlay) beg)
- before)
- additions))))
- (if additions
- (let ((textlist nil)
- (strpos 0))
- (dolist (add (stable-sort additions #'< :key #'car))
- (let ((addpos (car add))
- (addtext (cdr add)))
- (push (substring text strpos addpos) textlist)
- (push addtext textlist)
- (setq strpos addpos)))
- (push (substring text strpos) textlist)
- (apply #'concat (nreverse textlist)))
- text)))
-
-(defun htmlize-copy-prop (prop beg end string)
- ;; Copy the specified property from the specified region of the
- ;; buffer to the target string. We cannot rely on Emacs to copy the
- ;; property because we want to handle properties coming from both
- ;; text properties and overlays.
- (let ((pos beg))
- (while (< pos end)
- (let ((value (get-char-property pos prop))
- (next-change (htmlize-next-change pos prop end)))
- (when value
- (put-text-property (- pos beg) (- next-change beg)
- prop value string))
- (setq pos next-change)))))
-
-(defun htmlize-get-text-with-display (beg end)
- ;; Like buffer-substring-no-properties, except it copies the
- ;; `display' property from the buffer, if found.
- (let ((text (buffer-substring-no-properties beg end)))
- (htmlize-copy-prop 'display beg end text)
- (htmlize-copy-prop 'htmlize-link beg end text)
- (unless htmlize-running-xemacs
- (setq text (htmlize-add-before-after-strings beg end text)))
- text))
-
-(defun htmlize-buffer-substring-no-invisible (beg end)
- ;; Like buffer-substring-no-properties, but don't copy invisible
- ;; parts of the region. Where buffer-substring-no-properties
- ;; mandates an ellipsis to be shown, htmlize-ellipsis is inserted.
- (let ((pos beg)
- visible-list invisible show last-show next-change)
- ;; Iterate over the changes in the `invisible' property and filter
- ;; out the portions where it's non-nil, i.e. where the text is
- ;; invisible.
- (while (< pos end)
- (setq invisible (get-char-property pos 'invisible)
- next-change (htmlize-next-change pos 'invisible end)
- show (htmlize-decode-invisibility-spec invisible))
- (cond ((eq show t)
- (push (htmlize-get-text-with-display pos next-change)
- visible-list))
- ((and (eq show 'ellipsis)
- (not (eq last-show 'ellipsis))
- ;; Conflate successive ellipses.
- (push htmlize-ellipsis visible-list))))
- (setq pos next-change last-show show))
- (htmlize-concat (nreverse visible-list))))
-
-(defun htmlize-trim-ellipsis (text)
- ;; Remove htmlize-ellipses ("...") from the beginning of TEXT if it
- ;; starts with it. It checks for the special property of the
- ;; ellipsis so it doesn't work on ordinary text that begins with
- ;; "...".
- (if (get-text-property 0 'htmlize-ellipsis text)
- (substring text (length htmlize-ellipsis))
- text))
-
-(defconst htmlize-tab-spaces
- ;; A table of strings with spaces. (aref htmlize-tab-spaces 5) is
- ;; like (make-string 5 ?\ ), except it doesn't cons.
- (let ((v (make-vector 32 nil)))
- (dotimes (i (length v))
- (setf (aref v i) (make-string i ?\ )))
- v))
-
-(defun htmlize-untabify (text start-column)
- "Untabify TEXT, assuming it starts at START-COLUMN."
- (let ((column start-column)
- (last-match 0)
- (chunk-start 0)
- chunks match-pos tab-size)
- (while (string-match "[\t\n]" text last-match)
- (setq match-pos (match-beginning 0))
- (cond ((eq (aref text match-pos) ?\t)
- ;; Encountered a tab: create a chunk of text followed by
- ;; the expanded tab.
- (push (substring text chunk-start match-pos) chunks)
- ;; Increase COLUMN by the length of the text we've
- ;; skipped since last tab or newline. (Encountering
- ;; newline resets it.)
- (incf column (- match-pos last-match))
- ;; Calculate tab size based on tab-width and COLUMN.
- (setq tab-size (- tab-width (% column tab-width)))
- ;; Expand the tab, carefully recreating the `display'
- ;; property if one was on the TAB.
- (let ((display (get-text-property match-pos 'display text))
- (expanded-tab (aref htmlize-tab-spaces tab-size)))
- (when display
- (put-text-property 0 tab-size 'display display expanded-tab))
- (push expanded-tab chunks))
- (incf column tab-size)
- (setq chunk-start (1+ match-pos)))
- (t
- ;; Reset COLUMN at beginning of line.
- (setq column 0)))
- (setq last-match (1+ match-pos)))
- ;; If no chunks have been allocated, it means there have been no
- ;; tabs to expand. Return TEXT unmodified.
- (if (null chunks)
- text
- (when (< chunk-start (length text))
- ;; Push the remaining chunk.
- (push (substring text chunk-start) chunks))
- ;; Generate the output from the available chunks.
- (htmlize-concat (nreverse chunks)))))
-
-(defun htmlize-extract-text (beg end trailing-ellipsis)
- ;; Extract buffer text, sans the invisible parts. Then
- ;; untabify it and escape the HTML metacharacters.
- (let ((text (htmlize-buffer-substring-no-invisible beg end)))
- (when trailing-ellipsis
- (setq text (htmlize-trim-ellipsis text)))
- ;; If TEXT ends up empty, don't change trailing-ellipsis.
- (when (> (length text) 0)
- (setq trailing-ellipsis
- (get-text-property (1- (length text))
- 'htmlize-ellipsis text)))
- (setq text (htmlize-untabify text (current-column)))
- (setq text (htmlize-string-to-html text))
- (values text trailing-ellipsis)))
-
-(defun htmlize-despam-address (string)
- "Replace every occurrence of '@' in STRING with %40.
-This is used to protect mailto links without modifying their meaning."
- ;; Suggested by Ville Skytta.
- (while (string-match "@" string)
- (setq string (replace-match "%40" nil t string)))
- string)
-
-(defun htmlize-make-tmp-overlay (beg end props)
- (let ((overlay (htmlize-make-overlay beg end)))
- (htmlize-overlay-put overlay 'htmlize-tmp-overlay t)
- (while props
- (htmlize-overlay-put overlay (pop props) (pop props)))
- overlay))
-
-(defun htmlize-delete-tmp-overlays ()
- (dolist (overlay (htmlize-overlays-in (point-min) (point-max)))
- (when (htmlize-overlay-get overlay 'htmlize-tmp-overlay)
- (htmlize-delete-overlay overlay))))
-
-(defun htmlize-make-link-overlay (beg end uri)
- (htmlize-make-tmp-overlay beg end `(htmlize-link (:uri ,uri))))
-
-(defun htmlize-create-auto-links ()
- "Add `htmlize-link' property to all mailto links in the buffer."
- (save-excursion
- (goto-char (point-min))
- (while (re-search-forward
- "<\\(\\(mailto:\\)?\\([-=+_.a-zA-Z0-9]+@[-_.a-zA-Z0-9]+\\)\\)>"
- nil t)
- (let* ((address (match-string 3))
- (beg (match-beginning 0)) (end (match-end 0))
- (uri (concat "mailto:" (htmlize-despam-address address))))
- (htmlize-make-link-overlay beg end uri)))
- (goto-char (point-min))
- (while (re-search-forward "<\\(\\(URL:\\)?\\([a-zA-Z]+://[^;>]+\\)\\)>"
- nil t)
- (htmlize-make-link-overlay
- (match-beginning 0) (match-end 0) (match-string 3)))))
-
-;; Tests for htmlize-create-auto-links:
-
-;; <mailto:hniksic@xemacs.org>
-;; <http://fly.srk.fer.hr>
-;; <URL:http://www.xemacs.org>
-;; <http://www.mail-archive.com/bbdb-info@xemacs.org/>
-;; <hniksic@xemacs.org>
-;; <xalan-dev-sc.10148567319.hacuhiucknfgmpfnjcpg-john=doe.com@xml.apache.org>
-
-(defun htmlize-shadow-form-feeds ()
- (let ((s "\n<hr />"))
- (put-text-property 0 (length s) 'htmlize-literal t s)
- (let ((disp `(display ,s)))
- (while (re-search-forward "\n\^L" nil t)
- (htmlize-make-tmp-overlay (match-beginning 0) (match-end 0) disp)))))
-
-(defun htmlize-defang-local-variables ()
- ;; Juri Linkov reports that an HTML-ized "Local variables" can lead
- ;; visiting the HTML to fail with "Local variables list is not
- ;; properly terminated". He suggested changing the phrase to
- ;; syntactically equivalent HTML that Emacs doesn't recognize.
- (goto-char (point-min))
- (while (search-forward "Local Variables:" nil t)
- (replace-match "Local Variables&#58;" nil t)))
-
-
-;;; Color handling.
-
-(defvar htmlize-x-library-search-path
- `(,data-directory
- "/etc/X11/rgb.txt"
- "/usr/share/X11/rgb.txt"
- ;; the remainder of this list really belongs in a museum
- "/usr/X11R6/lib/X11/"
- "/usr/X11R5/lib/X11/"
- "/usr/lib/X11R6/X11/"
- "/usr/lib/X11R5/X11/"
- "/usr/local/X11R6/lib/X11/"
- "/usr/local/X11R5/lib/X11/"
- "/usr/local/lib/X11R6/X11/"
- "/usr/local/lib/X11R5/X11/"
- "/usr/X11/lib/X11/"
- "/usr/lib/X11/"
- "/usr/local/lib/X11/"
- "/usr/X386/lib/X11/"
- "/usr/x386/lib/X11/"
- "/usr/XFree86/lib/X11/"
- "/usr/unsupported/lib/X11/"
- "/usr/athena/lib/X11/"
- "/usr/local/x11r5/lib/X11/"
- "/usr/lpp/Xamples/lib/X11/"
- "/usr/openwin/lib/X11/"
- "/usr/openwin/share/lib/X11/"))
-
-(defun htmlize-get-color-rgb-hash (&optional rgb-file)
- "Return a hash table mapping X color names to RGB values.
-The keys in the hash table are X11 color names, and the values are the
-#rrggbb RGB specifications, extracted from `rgb.txt'.
-
-If RGB-FILE is nil, the function will try hard to find a suitable file
-in the system directories.
-
-If no rgb.txt file is found, return nil."
- (let ((rgb-file (or rgb-file (locate-file
- "rgb.txt"
- htmlize-x-library-search-path)))
- (hash nil))
- (when rgb-file
- (with-temp-buffer
- (insert-file-contents rgb-file)
- (setq hash (make-hash-table :test 'equal))
- (while (not (eobp))
- (cond ((looking-at "^\\s-*\\([!#]\\|$\\)")
- ;; Skip comments and empty lines.
- )
- ((looking-at
- "[ \t]*\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\(.*\\)")
- (setf (gethash (downcase (match-string 4)) hash)
- (format "#%02x%02x%02x"
- (string-to-number (match-string 1))
- (string-to-number (match-string 2))
- (string-to-number (match-string 3)))))
- (t
- (error
- "Unrecognized line in %s: %s"
- rgb-file
- (buffer-substring (point) (progn (end-of-line) (point))))))
- (forward-line 1))))
- hash))
-
-;; Compile the RGB map when loaded. On systems where rgb.txt is
-;; missing, the value of the variable will be nil, and rgb.txt will
-;; not be used.
-(defvar htmlize-color-rgb-hash (htmlize-get-color-rgb-hash))
-
-;;; Face handling.
-
-(defun htmlize-face-specifies-property (face prop)
- ;; Return t if face specifies PROP, as opposed to it being inherited
- ;; from the default face. The problem with e.g.
- ;; `face-foreground-instance' is that it returns an instance for
- ;; EVERY face because every face inherits from the default face.
- ;; However, we'd like htmlize-face-{fore,back}ground to return nil
- ;; when called with a face that doesn't specify its own foreground
- ;; or background.
- (or (eq face 'default)
- (assq 'global (specifier-spec-list (face-property face prop)))))
-
-(defun htmlize-face-color-internal (face fg)
- ;; Used only under GNU Emacs. Return the color of FACE, but don't
- ;; return "unspecified-fg" or "unspecified-bg". If the face is
- ;; `default' and the color is unspecified, look up the color in
- ;; 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))))
- (when (and (eq face 'default) (null color))
- (setq color (cdr (assq (if fg 'foreground-color 'background-color)
- (frame-parameters)))))
- (when (or (eq color 'unspecified)
- (equal color "unspecified-fg")
- (equal color "unspecified-bg"))
- (setq color nil))
- (when (and (eq face 'default)
- (null color))
- ;; Assuming black on white doesn't seem right, but I can't think
- ;; of anything better to do.
- (setq color (if fg "black" "white")))
- color))
-
-(defun htmlize-face-foreground (face)
- ;; Return the name of the foreground color of FACE. If FACE does
- ;; not specify a foreground color, return nil.
- (cond (htmlize-running-xemacs
- ;; XEmacs.
- (and (htmlize-face-specifies-property face 'foreground)
- (color-instance-name (face-foreground-instance face))))
- (t
- ;; GNU Emacs.
- (htmlize-face-color-internal face t))))
-
-(defun htmlize-face-background (face)
- ;; Return the name of the background color of FACE. If FACE does
- ;; not specify a background color, return nil.
- (cond (htmlize-running-xemacs
- ;; XEmacs.
- (and (htmlize-face-specifies-property face 'background)
- (color-instance-name (face-background-instance face))))
- (t
- ;; GNU Emacs.
- (htmlize-face-color-internal face nil))))
-
-;; Convert COLOR to the #RRGGBB string. If COLOR is already in that
-;; format, it's left unchanged.
-
-(defun htmlize-color-to-rgb (color)
- (let ((rgb-string nil))
- (cond ((null color)
- ;; Ignore nil COLOR because it means that the face is not
- ;; specifying any color. Hence (htmlize-color-to-rgb nil)
- ;; returns nil.
- )
- ((string-match "\\`#" color)
- ;; The color is already in #rrggbb format.
- (setq rgb-string color))
- ((and htmlize-use-rgb-txt
- htmlize-color-rgb-hash)
- ;; Use of rgb.txt is requested, and it's available on the
- ;; system. Use it.
- (setq rgb-string (gethash (downcase color) htmlize-color-rgb-hash)))
- (t
- ;; We're getting the RGB components from Emacs.
- (let ((rgb
- (if (fboundp 'color-instance-rgb-components)
- (mapcar (lambda (arg)
- (/ arg 256))
- (color-instance-rgb-components
- (make-color-instance color)))
- (mapcar (lambda (arg)
- (/ arg 256))
- (color-values color)))))
- (when rgb
- (setq rgb-string (apply #'format "#%02x%02x%02x" rgb))))))
- ;; If RGB-STRING is still nil, it means the color cannot be found,
- ;; for whatever reason. In that case just punt and return COLOR.
- ;; Most browsers support a decent set of color names anyway.
- (or rgb-string color)))
-
-;; We store the face properties we care about into an
-;; `htmlize-fstruct' type. That way we only have to analyze face
-;; properties, which can be time consuming, once per each face. The
-;; mapping between Emacs faces and htmlize-fstructs is established by
-;; htmlize-make-face-map. The name "fstruct" refers to variables of
-;; type `htmlize-fstruct', while the term "face" is reserved for Emacs
-;; faces.
-
-(defstruct htmlize-fstruct
- foreground ; foreground color, #rrggbb
- background ; background color, #rrggbb
- size ; size
- boldp ; whether face is bold
- italicp ; whether face is italic
- underlinep ; whether face is underlined
- overlinep ; whether face is overlined
- strikep ; whether face is struck through
- css-name ; CSS name of face
- )
-
-(defun htmlize-face-emacs21-attr (fstruct attr value)
- ;; For ATTR and VALUE, set the equivalent value in FSTRUCT.
- (case attr
- (:foreground
- (setf (htmlize-fstruct-foreground fstruct) (htmlize-color-to-rgb value)))
- (:background
- (setf (htmlize-fstruct-background fstruct) (htmlize-color-to-rgb value)))
- (:height
- (setf (htmlize-fstruct-size fstruct) value))
- (:weight
- (when (string-match (symbol-name value) "bold")
- (setf (htmlize-fstruct-boldp fstruct) t)))
- (:slant
- (setf (htmlize-fstruct-italicp fstruct) (or (eq value 'italic)
- (eq value 'oblique))))
- (:bold
- (setf (htmlize-fstruct-boldp fstruct) value))
- (:italic
- (setf (htmlize-fstruct-italicp fstruct) value))
- (:underline
- (setf (htmlize-fstruct-underlinep fstruct) value))
- (:overline
- (setf (htmlize-fstruct-overlinep fstruct) value))
- (:strike-through
- (setf (htmlize-fstruct-strikep fstruct) value))))
-
-(defun htmlize-face-size (face)
- ;; The size (height) of FACE, taking inheritance into account.
- ;; Only works in Emacs 21 and later.
- (let ((size-list
- (loop
- for f = face then (face-attribute f :inherit)
- until (or (not f) (eq f 'unspecified))
- for h = (face-attribute f :height)
- collect (if (eq h 'unspecified) nil h))))
- (reduce 'htmlize-merge-size (cons nil size-list))))
-
-(defun htmlize-face-css-name (face)
- ;; Generate the css-name property for the given face. Emacs places
- ;; no restrictions on the names of symbols that represent faces --
- ;; any characters may be in the name, even control chars. We try
- ;; hard to beat the face name into shape, both esthetically and
- ;; according to CSS1 specs.
- (let ((name (downcase (symbol-name face))))
- (when (string-match "\\`font-lock-" name)
- ;; font-lock-FOO-face -> FOO.
- (setq name (replace-match "" t t name)))
- (when (string-match "-face\\'" name)
- ;; Drop the redundant "-face" suffix.
- (setq name (replace-match "" t t name)))
- (while (string-match "[^-a-zA-Z0-9]" name)
- ;; Drop the non-alphanumerics.
- (setq name (replace-match "X" t t name)))
- (when (string-match "\\`[-0-9]" name)
- ;; CSS identifiers may not start with a digit.
- (setq name (concat "X" name)))
- ;; After these transformations, the face could come out empty.
- (when (equal name "")
- (setq name "face"))
- ;; Apply the prefix.
- (concat htmlize-css-name-prefix name)))
-
-(defun htmlize-face-to-fstruct (face)
- "Convert Emacs face FACE to fstruct."
- (let ((fstruct (make-htmlize-fstruct
- :foreground (htmlize-color-to-rgb
- (htmlize-face-foreground face))
- :background (htmlize-color-to-rgb
- (htmlize-face-background face)))))
- (if htmlize-running-xemacs
- ;; XEmacs doesn't provide a way to detect whether a face is
- ;; bold or italic, so we need to examine the font instance.
- (let* ((font-instance (face-font-instance face))
- (props (font-instance-properties font-instance)))
- (when (equalp (cdr (assq 'WEIGHT_NAME props)) "bold")
- (setf (htmlize-fstruct-boldp fstruct) t))
- (when (or (equalp (cdr (assq 'SLANT props)) "i")
- (equalp (cdr (assq 'SLANT props)) "o"))
- (setf (htmlize-fstruct-italicp fstruct) t))
- (setf (htmlize-fstruct-strikep fstruct)
- (face-strikethru-p face))
- (setf (htmlize-fstruct-underlinep fstruct)
- (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)))))
- (when (and value (not (eq value 'unspecified)))
- (htmlize-face-emacs21-attr fstruct attr value))))
- (let ((size (htmlize-face-size face)))
- (unless (eql size 1.0) ; ignore non-spec
- (setf (htmlize-fstruct-size fstruct) size))))
- (setf (htmlize-fstruct-css-name fstruct) (htmlize-face-css-name face))
- fstruct))
-
-(defmacro htmlize-copy-attr-if-set (attr-list dest source)
- ;; Generate code with the following pattern:
- ;; (progn
- ;; (when (htmlize-fstruct-ATTR source)
- ;; (setf (htmlize-fstruct-ATTR dest) (htmlize-fstruct-ATTR source)))
- ;; ...)
- ;; for the given list of boolean attributes.
- (cons 'progn
- (loop for attr in attr-list
- for attr-sym = (intern (format "htmlize-fstruct-%s" attr))
- collect `(when (,attr-sym ,source)
- (setf (,attr-sym ,dest) (,attr-sym ,source))))))
-
-(defun htmlize-merge-size (merged next)
- ;; Calculate the size of the merge of MERGED and NEXT.
- (cond ((null merged) next)
- ((integerp next) next)
- ((null next) merged)
- ((floatp merged) (* merged next))
- ((integerp merged) (round (* merged next)))))
-
-(defun htmlize-merge-two-faces (merged next)
- (htmlize-copy-attr-if-set
- (foreground background boldp italicp underlinep overlinep strikep)
- merged next)
- (setf (htmlize-fstruct-size merged)
- (htmlize-merge-size (htmlize-fstruct-size merged)
- (htmlize-fstruct-size next)))
- merged)
-
-(defun htmlize-merge-faces (fstruct-list)
- (cond ((null fstruct-list)
- ;; Nothing to do, return a dummy face.
- (make-htmlize-fstruct))
- ((null (cdr fstruct-list))
- ;; Optimize for the common case of a single face, simply
- ;; return it.
- (car fstruct-list))
- (t
- (reduce #'htmlize-merge-two-faces
- (cons (make-htmlize-fstruct) fstruct-list)))))
-
-;; GNU Emacs 20+ supports attribute lists in `face' properties. For
-;; example, you can use `(:foreground "red" :weight bold)' as an
-;; overlay's "face", or you can even use a list of such lists, etc.
-;; We call those "attrlists".
-;;
-;; htmlize supports attrlist by converting them to fstructs, the same
-;; as with regular faces.
-
-(defun htmlize-attrlist-to-fstruct (attrlist)
- ;; Like htmlize-face-to-fstruct, but accepts an ATTRLIST as input.
- (let ((fstruct (make-htmlize-fstruct)))
- (cond ((eq (car attrlist) 'foreground-color)
- ;; ATTRLIST is (foreground-color . COLOR)
- (setf (htmlize-fstruct-foreground fstruct)
- (htmlize-color-to-rgb (cdr attrlist))))
- ((eq (car attrlist) 'background-color)
- ;; ATTRLIST is (background-color . COLOR)
- (setf (htmlize-fstruct-background fstruct)
- (htmlize-color-to-rgb (cdr attrlist))))
- (t
- ;; ATTRLIST is a plist.
- (while attrlist
- (let ((attr (pop attrlist))
- (value (pop attrlist)))
- (when (and value (not (eq value 'unspecified)))
- (htmlize-face-emacs21-attr fstruct attr value))))))
- (setf (htmlize-fstruct-css-name fstruct) "ATTRLIST")
- fstruct))
-
-(defun htmlize-decode-face-prop (prop)
- "Turn face property PROP into a list of face-like objects."
- ;; PROP can be a symbol naming a face, a string naming such a
- ;; symbol, a cons (foreground-color . COLOR) or (background-color
- ;; COLOR), a property list (:attr1 val1 :attr2 val2 ...), or a list
- ;; of any of those.
- ;;
- ;; (htmlize-decode-face-prop 'face) -> (face)
- ;; (htmlize-decode-face-prop '(face1 face2)) -> (face1 face2)
- ;; (htmlize-decode-face-prop '(:attr "val")) -> ((:attr "val"))
- ;; (htmlize-decode-face-prop '((:attr "val") face (foreground-color "red")))
- ;; -> ((:attr "val") face (foreground-color "red"))
- ;;
- ;; Unrecognized atoms or non-face symbols/strings are silently
- ;; stripped away.
- (cond ((null prop)
- nil)
- ((symbolp prop)
- (and (facep prop)
- (list prop)))
- ((stringp prop)
- (and (facep (intern-soft prop))
- (list prop)))
- ((atom prop)
- nil)
- ((and (symbolp (car prop))
- (eq ?: (aref (symbol-name (car prop)) 0)))
- (list prop))
- ((or (eq (car prop) 'foreground-color)
- (eq (car prop) 'background-color))
- (list prop))
- (t
- (apply #'nconc (mapcar #'htmlize-decode-face-prop prop)))))
-
-(defun htmlize-make-face-map (faces)
- ;; Return a hash table mapping Emacs faces to htmlize's fstructs.
- ;; The keys are either face symbols or attrlists, so the test
- ;; function must be `equal'.
- (let ((face-map (make-hash-table :test 'equal))
- css-names)
- (dolist (face faces)
- (unless (gethash face face-map)
- ;; Haven't seen FACE yet; convert it to an fstruct and cache
- ;; it.
- (let ((fstruct (if (symbolp face)
- (htmlize-face-to-fstruct face)
- (htmlize-attrlist-to-fstruct face))))
- (setf (gethash face face-map) fstruct)
- (let* ((css-name (htmlize-fstruct-css-name fstruct))
- (new-name css-name)
- (i 0))
- ;; Uniquify the face's css-name by using NAME-1, NAME-2,
- ;; etc.
- (while (member new-name css-names)
- (setq new-name (format "%s-%s" css-name (incf i))))
- (unless (equal new-name css-name)
- (setf (htmlize-fstruct-css-name fstruct) new-name))
- (push new-name css-names)))))
- face-map))
-
-(defun htmlize-unstringify-face (face)
- "If FACE is a string, return it interned, otherwise return it unchanged."
- (if (stringp face)
- (intern face)
- face))
-
-(defun htmlize-faces-in-buffer ()
- "Return a list of faces used in the current buffer.
-Under XEmacs, this returns the set of faces specified by the extents
-with the `face' property. (This covers text properties as well.) Under
-GNU Emacs, it returns the set of faces specified by the `face' text
-property and by buffer overlays that specify `face'."
- (let (faces)
- ;; Testing for (fboundp 'map-extents) doesn't work because W3
- ;; defines `map-extents' under FSF.
- (if htmlize-running-xemacs
- (let (face-prop)
- (map-extents (lambda (extent ignored)
- (setq face-prop (extent-face extent)
- ;; FACE-PROP can be a face or a list of
- ;; faces.
- faces (if (listp face-prop)
- (union face-prop faces)
- (adjoin face-prop faces)))
- nil)
- nil
- ;; Specify endpoints explicitly to respect
- ;; narrowing.
- (point-min) (point-max) nil nil 'face))
- ;; FSF Emacs code.
- ;; Faces used by text properties.
- (let ((pos (point-min)) face-prop next)
- (while (< pos (point-max))
- (setq face-prop (get-text-property pos 'face)
- next (or (next-single-property-change pos 'face) (point-max)))
- (setq faces (nunion (htmlize-decode-face-prop face-prop)
- faces :test 'equal))
- (setq pos next)))
- ;; Faces used by overlays.
- (dolist (overlay (overlays-in (point-min) (point-max)))
- (let ((face-prop (overlay-get overlay 'face)))
- (setq faces (nunion (htmlize-decode-face-prop face-prop)
- faces :test 'equal)))))
- faces))
-
-;; htmlize-faces-at-point returns the faces in use at point. The
-;; faces are sorted by increasing priority, i.e. the last face takes
-;; precedence.
-;;
-;; Under XEmacs, this returns all the faces in all the extents at
-;; point. Under GNU Emacs, this returns all the faces in the `face'
-;; property and all the faces in the overlays at point.
-
-(cond (htmlize-running-xemacs
- (defun htmlize-faces-at-point ()
- (let (extent extent-list face-list face-prop)
- (while (setq extent (extent-at (point) nil 'face extent))
- (push extent extent-list))
- ;; extent-list is in reverse display order, meaning that
- ;; smallest ones come last. That is the order we want,
- ;; except it can be overridden by the `priority' property.
- (setq extent-list (stable-sort extent-list #'<
- :key #'extent-priority))
- (dolist (extent extent-list)
- (setq face-prop (extent-face extent))
- ;; extent's face-list is in reverse order from what we
- ;; want, but the `nreverse' below will take care of it.
- (setq face-list (if (listp face-prop)
- (append face-prop face-list)
- (cons face-prop face-list))))
- (nreverse face-list))))
- (t
- (defun htmlize-faces-at-point ()
- (let (all-faces)
- ;; Faces from text properties.
- (let ((face-prop (get-text-property (point) 'face)))
- (setq all-faces (htmlize-decode-face-prop face-prop)))
- ;; Faces from overlays.
- (let ((overlays
- ;; Collect overlays at point that specify `face'.
- (delete-if-not (lambda (o)
- (overlay-get o 'face))
- (overlays-at (point))))
- list face-prop)
- ;; Sort the overlays so the smaller (more specific) ones
- ;; come later. The number of overlays at each one
- ;; position should be very small, so the sort shouldn't
- ;; slow things down.
- (setq overlays (sort* overlays
- ;; Sort by ascending...
- #'<
- ;; ...overlay size.
- :key (lambda (o)
- (- (overlay-end o)
- (overlay-start o)))))
- ;; Overlay priorities, if present, override the above
- ;; established order. Larger overlay priority takes
- ;; precedence and therefore comes later in the list.
- (setq overlays (stable-sort
- overlays
- ;; Reorder (stably) by acending...
- #'<
- ;; ...overlay priority.
- :key (lambda (o)
- (or (overlay-get o 'priority) 0))))
- (dolist (overlay overlays)
- (setq face-prop (overlay-get overlay 'face)
- list (nconc (htmlize-decode-face-prop face-prop) list)))
- ;; Under "Merging Faces" the manual explicitly states
- ;; that faces specified by overlays take precedence over
- ;; faces specified by text properties.
- (setq all-faces (nconc all-faces list)))
- all-faces))))
-
-;; htmlize supports generating HTML in several flavors, some of which
-;; use CSS, and others the <font> element. We take an OO approach and
-;; define "methods" that indirect to the functions that depend on
-;; `htmlize-output-type'. The currently used methods are `doctype',
-;; `insert-head', `body-tag', and `text-markup'. Not all output types
-;; define all methods.
-;;
-;; Methods are called either with (htmlize-method METHOD ARGS...)
-;; special form, or by accessing the function with
-;; (htmlize-method-function 'METHOD) and calling (funcall FUNCTION).
-;; The latter form is useful in tight loops because `htmlize-method'
-;; conses.
-
-(defmacro htmlize-method (method &rest args)
- ;; Expand to (htmlize-TYPE-METHOD ...ARGS...). TYPE is the value of
- ;; `htmlize-output-type' at run time.
- `(funcall (htmlize-method-function ',method) ,@args))
-
-(defun htmlize-method-function (method)
- ;; Return METHOD's function definition for the current output type.
- ;; The returned object can be safely funcalled.
- (let ((sym (intern (format "htmlize-%s-%s" htmlize-output-type method))))
- (indirect-function (if (fboundp sym)
- sym
- (let ((default (intern (concat "htmlize-default-"
- (symbol-name method)))))
- (if (fboundp default)
- default
- 'ignore))))))
-
-(defvar htmlize-memoization-table (make-hash-table :test 'equal))
-
-(defmacro htmlize-memoize (key generator)
- "Return the value of GENERATOR, memoized as KEY.
-That means that GENERATOR will be evaluated and returned the first time
-it's called with the same value of KEY. All other times, the cached
-\(memoized) value will be returned."
- (let ((value (gensym)))
- `(let ((,value (gethash ,key htmlize-memoization-table)))
- (unless ,value
- (setq ,value ,generator)
- (setf (gethash ,key htmlize-memoization-table) ,value))
- ,value)))
-
-;;; Default methods.
-
-(defun htmlize-default-doctype ()
- nil ; no doc-string
- ;; Note that the `font' output is technically invalid under this DTD
- ;; because the DTD doesn't allow embedding <font> in <pre>.
- "<!DOCTYPE html PUBLIC \"-//W3C//DTD HTML 4.01//EN\">"
- )
-
-(defun htmlize-default-body-tag (face-map)
- nil ; no doc-string
- face-map ; shut up the byte-compiler
- "<body>")
-
-;;; CSS based output support.
-
-;; Internal function; not a method.
-(defun htmlize-css-specs (fstruct)
- (let (result)
- (when (htmlize-fstruct-foreground fstruct)
- (push (format "color: %s;" (htmlize-fstruct-foreground fstruct))
- result))
- (when (htmlize-fstruct-background fstruct)
- (push (format "background-color: %s;"
- (htmlize-fstruct-background fstruct))
- result))
- (let ((size (htmlize-fstruct-size fstruct)))
- (when (and size (not (eq htmlize-ignore-face-size t)))
- (cond ((floatp size)
- (push (format "font-size: %d%%;" (* 100 size)) result))
- ((not (eq htmlize-ignore-face-size 'absolute))
- (push (format "font-size: %spt;" (/ size 10.0)) result)))))
- (when (htmlize-fstruct-boldp fstruct)
- (push "font-weight: bold;" result))
- (when (htmlize-fstruct-italicp fstruct)
- (push "font-style: italic;" result))
- (when (htmlize-fstruct-underlinep fstruct)
- (push "text-decoration: underline;" result))
- (when (htmlize-fstruct-overlinep fstruct)
- (push "text-decoration: overline;" result))
- (when (htmlize-fstruct-strikep fstruct)
- (push "text-decoration: line-through;" result))
- (nreverse result)))
-
-(defun htmlize-css-insert-head (buffer-faces face-map)
- (insert " <style type=\"text/css\">\n <!--\n")
- (insert " body {\n "
- (mapconcat #'identity
- (htmlize-css-specs (gethash 'default face-map))
- "\n ")
- "\n }\n")
- (dolist (face (sort* (copy-list buffer-faces) #'string-lessp
- :key (lambda (f)
- (htmlize-fstruct-css-name (gethash f face-map)))))
- (let* ((fstruct (gethash face face-map))
- (cleaned-up-face-name
- (let ((s
- ;; Use `prin1-to-string' rather than `symbol-name'
- ;; to get the face name because the "face" can also
- ;; be an attrlist, which is not a symbol.
- (prin1-to-string face)))
- ;; If the name contains `--' or `*/', remove them.
- (while (string-match "--" s)
- (setq s (replace-match "-" t t s)))
- (while (string-match "\\*/" s)
- (setq s (replace-match "XX" t t s)))
- s))
- (specs (htmlize-css-specs fstruct)))
- (insert " ." (htmlize-fstruct-css-name fstruct))
- (if (null specs)
- (insert " {")
- (insert " {\n /* " cleaned-up-face-name " */\n "
- (mapconcat #'identity specs "\n ")))
- (insert "\n }\n")))
- (insert htmlize-hyperlink-style
- " -->\n </style>\n"))
-
-(defun htmlize-css-text-markup (fstruct-list buffer)
- ;; Open the markup needed to insert text colored with FACES into
- ;; BUFFER. Return the function that closes the markup.
-
- ;; In CSS mode, this is easy: just nest the text in one <span
- ;; class=...> tag for each face in FSTRUCT-LIST.
- (dolist (fstruct fstruct-list)
- (princ "<span class=\"" buffer)
- (princ (htmlize-fstruct-css-name fstruct) buffer)
- (princ "\">" buffer))
- (htmlize-lexlet ((fstruct-list fstruct-list) (buffer buffer))
- (lambda ()
- (dolist (fstruct fstruct-list)
- (ignore fstruct) ; shut up the byte-compiler
- (princ "</span>" buffer)))))
-
-;; `inline-css' output support.
-
-(defun htmlize-inline-css-body-tag (face-map)
- (format "<body style=\"%s\">"
- (mapconcat #'identity (htmlize-css-specs (gethash 'default face-map))
- " ")))
-
-(defun htmlize-inline-css-text-markup (fstruct-list buffer)
- (let* ((merged (htmlize-merge-faces fstruct-list))
- (style (htmlize-memoize
- merged
- (let ((specs (htmlize-css-specs merged)))
- (and specs
- (mapconcat #'identity (htmlize-css-specs merged) " "))))))
- (when style
- (princ "<span style=\"" buffer)
- (princ style buffer)
- (princ "\">" buffer))
- (htmlize-lexlet ((style style) (buffer buffer))
- (lambda ()
- (when style
- (princ "</span>" buffer))))))
-
-;;; `font' tag based output support.
-
-(defun htmlize-font-body-tag (face-map)
- (let ((fstruct (gethash 'default face-map)))
- (format "<body text=\"%s\" bgcolor=\"%s\">"
- (htmlize-fstruct-foreground fstruct)
- (htmlize-fstruct-background fstruct))))
-
-(defun htmlize-font-text-markup (fstruct-list buffer)
- ;; In `font' mode, we use the traditional HTML means of altering
- ;; presentation: <font> tag for colors, <b> for bold, <u> for
- ;; underline, and <strike> for strike-through.
- (let* ((merged (htmlize-merge-faces fstruct-list))
- (markup (htmlize-memoize
- merged
- (cons (concat
- (and (htmlize-fstruct-foreground merged)
- (format "<font color=\"%s\">" (htmlize-fstruct-foreground merged)))
- (and (htmlize-fstruct-boldp merged) "<b>")
- (and (htmlize-fstruct-italicp merged) "<i>")
- (and (htmlize-fstruct-underlinep merged) "<u>")
- (and (htmlize-fstruct-strikep merged) "<strike>"))
- (concat
- (and (htmlize-fstruct-strikep merged) "</strike>")
- (and (htmlize-fstruct-underlinep merged) "</u>")
- (and (htmlize-fstruct-italicp merged) "</i>")
- (and (htmlize-fstruct-boldp merged) "</b>")
- (and (htmlize-fstruct-foreground merged) "</font>"))))))
- (princ (car markup) buffer)
- (htmlize-lexlet ((markup markup) (buffer buffer))
- (lambda ()
- (princ (cdr markup) buffer)))))
-
-(defun htmlize-buffer-1 ()
- ;; Internal function; don't call it from outside this file. Htmlize
- ;; current buffer, writing the resulting HTML to a new buffer, and
- ;; return it. Unlike htmlize-buffer, this doesn't change current
- ;; buffer or use switch-to-buffer.
- (save-excursion
- ;; Protect against the hook changing the current buffer.
- (save-excursion
- (run-hooks 'htmlize-before-hook))
- ;; Convince font-lock support modes to fontify the entire buffer
- ;; in advance.
- (htmlize-ensure-fontified)
- (clrhash htmlize-extended-character-cache)
- (clrhash htmlize-memoization-table)
- ;; It's important that the new buffer inherits default-directory
- ;; from the current buffer.
- (let ((htmlbuf (generate-new-buffer (if (buffer-file-name)
- (htmlize-make-file-name
- (file-name-nondirectory
- (buffer-file-name)))
- "*html*")))
- (completed nil))
- (unwind-protect
- (let* ((buffer-faces (htmlize-faces-in-buffer))
- (face-map (htmlize-make-face-map (adjoin 'default buffer-faces)))
- (places (gensym))
- (title (if (buffer-file-name)
- (file-name-nondirectory (buffer-file-name))
- (buffer-name))))
- (when htmlize-generate-hyperlinks
- (htmlize-create-auto-links))
- (when htmlize-replace-form-feeds
- (htmlize-shadow-form-feeds))
-
- ;; Initialize HTMLBUF and insert the HTML prolog.
- (with-current-buffer htmlbuf
- (buffer-disable-undo)
- (insert (htmlize-method doctype) ?\n
- (format "<!-- Created by htmlize-%s in %s mode. -->\n"
- htmlize-version htmlize-output-type)
- "<html>\n ")
- (put places 'head-start (point-marker))
- (insert "<head>\n"
- " <title>" (htmlize-protect-string title) "</title>\n"
- (if htmlize-html-charset
- (format (concat " <meta http-equiv=\"Content-Type\" "
- "content=\"text/html; charset=%s\">\n")
- htmlize-html-charset)
- "")
- htmlize-head-tags)
- (htmlize-method insert-head buffer-faces face-map)
- (insert " </head>")
- (put places 'head-end (point-marker))
- (insert "\n ")
- (put places 'body-start (point-marker))
- (insert (htmlize-method body-tag face-map)
- "\n ")
- (put places 'content-start (point-marker))
- (insert "<pre>\n"))
- (let ((text-markup
- ;; Get the inserter method, so we can funcall it inside
- ;; the loop. Not calling `htmlize-method' in the loop
- ;; body yields a measurable speed increase.
- (htmlize-method-function 'text-markup))
- ;; Declare variables used in loop body outside the loop
- ;; because it's faster to establish `let' bindings only
- ;; once.
- next-change text face-list trailing-ellipsis
- fstruct-list last-fstruct-list
- (close-markup (lambda ())))
- ;; This loop traverses and reads the source buffer, appending
- ;; the resulting HTML to HTMLBUF. This method is fast
- ;; because: 1) it doesn't require examining the text
- ;; properties char by char (htmlize-next-face-change is used
- ;; to move between runs with the same face), and 2) it doesn't
- ;; require frequent buffer switches, which are slow because
- ;; they rebind all buffer-local vars.
- (goto-char (point-min))
- (while (not (eobp))
- (setq next-change (htmlize-next-face-change (point)))
- ;; Get faces in use between (point) and NEXT-CHANGE, and
- ;; convert them to fstructs.
- (setq face-list (htmlize-faces-at-point)
- fstruct-list (delq nil (mapcar (lambda (f)
- (gethash f face-map))
- face-list)))
- (multiple-value-setq (text trailing-ellipsis)
- (htmlize-extract-text (point) next-change trailing-ellipsis))
- ;; Don't bother writing anything if there's no text (this
- ;; happens in invisible regions).
- (when (> (length text) 0)
- ;; Open the new markup if necessary and insert the text.
- (when (not (equalp fstruct-list last-fstruct-list))
- (funcall close-markup)
- (setq last-fstruct-list fstruct-list
- close-markup (funcall text-markup fstruct-list htmlbuf)))
- (princ text htmlbuf))
- (goto-char next-change))
-
- ;; We've gone through the buffer; close the markup from
- ;; the last run, if any.
- (funcall close-markup))
-
- ;; Insert the epilog and post-process the buffer.
- (with-current-buffer htmlbuf
- (insert "</pre>")
- (put places 'content-end (point-marker))
- (insert "\n </body>")
- (put places 'body-end (point-marker))
- (insert "\n</html>\n")
- (htmlize-defang-local-variables)
- (goto-char (point-min))
- (when htmlize-html-major-mode
- ;; What sucks about this is that the minor modes, most notably
- ;; font-lock-mode, won't be initialized. Oh well.
- (funcall htmlize-html-major-mode))
- (set (make-local-variable 'htmlize-buffer-places)
- (symbol-plist places))
- (run-hooks 'htmlize-after-hook)
- (buffer-enable-undo))
- (setq completed t)
- htmlbuf)
-
- (when (not completed)
- (kill-buffer htmlbuf))
- (htmlize-delete-tmp-overlays)))))
-
-;; Utility functions.
-
-(defmacro htmlize-with-fontify-message (&rest body)
- ;; When forcing fontification of large buffers in
- ;; htmlize-ensure-fontified, inform the user that he is waiting for
- ;; font-lock, not for htmlize to finish.
- `(progn
- (if (> (buffer-size) 65536)
- (message "Forcing fontification of %s..."
- (buffer-name (current-buffer))))
- ,@body
- (if (> (buffer-size) 65536)
- (message "Forcing fontification of %s...done"
- (buffer-name (current-buffer))))))
-
-(defun htmlize-ensure-fontified ()
- ;; If font-lock is being used, ensure that the "support" modes
- ;; actually fontify the buffer. If font-lock is not in use, we
- ;; don't care because, except in htmlize-file, we don't force
- ;; font-lock on the user.
- (when (and (boundp 'font-lock-mode)
- font-lock-mode)
- ;; In part taken from ps-print-ensure-fontified in GNU Emacs 21.
- (cond
- ((and (boundp 'jit-lock-mode)
- (symbol-value 'jit-lock-mode))
- (htmlize-with-fontify-message
- (jit-lock-fontify-now (point-min) (point-max))))
- ((and (boundp 'lazy-lock-mode)
- (symbol-value 'lazy-lock-mode))
- (htmlize-with-fontify-message
- (lazy-lock-fontify-region (point-min) (point-max))))
- ((and (boundp 'lazy-shot-mode)
- (symbol-value 'lazy-shot-mode))
- (htmlize-with-fontify-message
- ;; lazy-shot is amazing in that it must *refontify* the region,
- ;; even if the whole buffer has already been fontified. <sigh>
- (lazy-shot-fontify-region (point-min) (point-max))))
- ;; There's also fast-lock, but we don't need to handle specially,
- ;; I think. fast-lock doesn't really defer fontification, it
- ;; just saves it to an external cache so it's not done twice.
- )))
-
-
-;;;###autoload
-(defun htmlize-buffer (&optional buffer)
- "Convert BUFFER to HTML, preserving colors and decorations.
-
-The generated HTML is available in a new buffer, which is returned.
-When invoked interactively, the new buffer is selected in the current
-window. The title of the generated document will be set to the buffer's
-file name or, if that's not available, to the buffer's name.
-
-Note that htmlize doesn't fontify your buffers, it only uses the
-decorations that are already present. If you don't set up font-lock or
-something else to fontify your buffers, the resulting HTML will be
-plain. Likewise, if you don't like the choice of colors, fix the mode
-that created them, or simply alter the faces it uses."
- (interactive)
- (let ((htmlbuf (with-current-buffer (or buffer (current-buffer))
- (htmlize-buffer-1))))
- (when (interactive-p)
- (switch-to-buffer htmlbuf))
- htmlbuf))
-
-;;;###autoload
-(defun htmlize-region (beg end)
- "Convert the region to HTML, preserving colors and decorations.
-See `htmlize-buffer' for details."
- (interactive "r")
- ;; Don't let zmacs region highlighting end up in HTML.
- (when (fboundp 'zmacs-deactivate-region)
- (zmacs-deactivate-region))
- (let ((htmlbuf (save-restriction
- (narrow-to-region beg end)
- (htmlize-buffer-1))))
- (when (interactive-p)
- (switch-to-buffer htmlbuf))
- htmlbuf))
-
-(defun htmlize-region-for-paste (beg end)
- "Htmlize the region and return just the HTML as a string.
-This forces the `inline-css' style and only returns the HTML body,
-but without the BODY tag. This should make it useful for inserting
-the text to another HTML buffer."
- (let* ((htmlize-output-type 'inline-css)
- (htmlbuf (htmlize-region beg end)))
- (unwind-protect
- (with-current-buffer htmlbuf
- (buffer-substring (plist-get htmlize-buffer-places 'content-start)
- (plist-get htmlize-buffer-places 'content-end)))
- (kill-buffer htmlbuf))))
-
-(defun htmlize-make-file-name (file)
- "Make an HTML file name from FILE.
-
-In its default implementation, this simply appends `.html' to FILE.
-This function is called by htmlize to create the buffer file name, and
-by `htmlize-file' to create the target file name.
-
-More elaborate transformations are conceivable, such as changing FILE's
-extension to `.html' (\"file.c\" -> \"file.html\"). If you want them,
-overload this function to do it and htmlize will comply."
- (concat file ".html"))
-
-;; Older implementation of htmlize-make-file-name that changes FILE's
-;; extension to ".html".
-;(defun htmlize-make-file-name (file)
-; (let ((extension (file-name-extension file))
-; (sans-extension (file-name-sans-extension file)))
-; (if (or (equal extension "html")
-; (equal extension "htm")
-; (equal sans-extension ""))
-; (concat file ".html")
-; (concat sans-extension ".html"))))
-
-;;;###autoload
-(defun htmlize-file (file &optional target)
- "Load FILE, fontify it, convert it to HTML, and save the result.
-
-Contents of FILE are inserted into a temporary buffer, whose major mode
-is set with `normal-mode' as appropriate for the file type. The buffer
-is subsequently fontified with `font-lock' and converted to HTML. Note
-that, unlike `htmlize-buffer', this function explicitly turns on
-font-lock. If a form of highlighting other than font-lock is desired,
-please use `htmlize-buffer' directly on buffers so highlighted.
-
-Buffers currently visiting FILE are unaffected by this function. The
-function does not change current buffer or move the point.
-
-If TARGET is specified and names a directory, the resulting file will be
-saved there instead of to FILE's directory. If TARGET is specified and
-does not name a directory, it will be used as output file name."
- (interactive (list (read-file-name
- "HTML-ize file: "
- nil nil nil (and (buffer-file-name)
- (file-name-nondirectory
- (buffer-file-name))))))
- (let ((output-file (if (and target (not (file-directory-p target)))
- target
- (expand-file-name
- (htmlize-make-file-name (file-name-nondirectory file))
- (or target (file-name-directory file)))))
- ;; Try to prevent `find-file-noselect' from triggering
- ;; font-lock because we'll fontify explicitly below.
- (font-lock-mode nil)
- (font-lock-auto-fontify nil)
- (global-font-lock-mode nil)
- ;; Ignore the size limit for the purposes of htmlization.
- (font-lock-maximum-size nil)
- ;; Disable font-lock support modes. This will only work in
- ;; more recent Emacs versions, so htmlize-buffer-1 still needs
- ;; to call htmlize-ensure-fontified.
- (font-lock-support-mode nil))
- (with-temp-buffer
- ;; Insert FILE into the temporary buffer.
- (insert-file-contents file)
- ;; Set the file name so normal-mode and htmlize-buffer-1 pick it
- ;; up. Restore it afterwards so with-temp-buffer's kill-buffer
- ;; doesn't complain about killing a modified buffer.
- (let ((buffer-file-name file))
- ;; Set the major mode for the sake of font-lock.
- (normal-mode)
- (font-lock-mode 1)
- (unless font-lock-mode
- ;; In GNU Emacs (font-lock-mode 1) doesn't force font-lock,
- ;; contrary to the documentation. This seems to work.
- (font-lock-fontify-buffer))
- ;; htmlize the buffer and save the HTML.
- (with-current-buffer (htmlize-buffer-1)
- (unwind-protect
- (progn
- (run-hooks 'htmlize-file-hook)
- (write-region (point-min) (point-max) output-file))
- (kill-buffer (current-buffer)))))))
- ;; I haven't decided on a useful return value yet, so just return
- ;; nil.
- nil)
-
-;;;###autoload
-(defun htmlize-many-files (files &optional target-directory)
- "Convert FILES to HTML and save the corresponding HTML versions.
-
-FILES should be a list of file names to convert. This function calls
-`htmlize-file' on each file; see that function for details. When
-invoked interactively, you are prompted for a list of files to convert,
-terminated with RET.
-
-If TARGET-DIRECTORY is specified, the HTML files will be saved to that
-directory. Normally, each HTML file is saved to the directory of the
-corresponding source file."
- (interactive
- (list
- (let (list file)
- ;; Use empty string as DEFAULT because setting DEFAULT to nil
- ;; defaults to the directory name, which is not what we want.
- (while (not (equal (setq file (read-file-name
- "HTML-ize file (RET to finish): "
- (and list (file-name-directory
- (car list)))
- "" t))
- ""))
- (push file list))
- (nreverse list))))
- ;; Verify that TARGET-DIRECTORY is indeed a directory. If it's a
- ;; file, htmlize-file will use it as target, and that doesn't make
- ;; sense.
- (and target-directory
- (not (file-directory-p target-directory))
- (error "target-directory must name a directory: %s" target-directory))
- (dolist (file files)
- (htmlize-file file target-directory)))
-
-;;;###autoload
-(defun htmlize-many-files-dired (arg &optional target-directory)
- "HTMLize dired-marked files."
- (interactive "P")
- (htmlize-many-files (dired-get-marked-files nil arg) target-directory))
-
-(provide 'htmlize)
-
-;; Local Variables:
-;; byte-compile-warnings: (not cl-functions lexical unresolved obsolete)
-;; lexical-binding: t
-;; End:
-
-;;; htmlize.el ends here
diff --git a/contrib/lisp/ob-csharp.el b/contrib/lisp/ob-csharp.el
new file mode 100644
index 0000000..c4aa046
--- 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-2017 Free Software Foundation, Inc.
+
+;; Author: thomas "at" friendlyvillagers.com based on ob-java.el by Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+
+;; This file is not part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Currently this only supports the external compilation and execution
+;; of csharp code blocks (i.e., no session support).
+
+;;; Code:
+(require 'ob)
+
+(defvar org-babel-tangle-lang-exts)
+(add-to-list 'org-babel-tangle-lang-exts '("csharp" . "cs"))
+
+(defcustom org-babel-csharp-command "mono"
+ "Name of the csharp command.
+May be either a command in the path, like mono
+or an absolute path name, like /usr/local/bin/mono
+parameters may be used, like mono -verbose"
+ :group 'org-babel
+ :version "24.3"
+ :type 'string)
+
+(defcustom org-babel-csharp-compiler "mcs"
+ "Name of the csharp compiler.
+May be either a command in the path, like mcs
+or an absolute path name, like /usr/local/bin/mcs
+parameters may be used, like mcs -warnaserror+"
+ :group 'org-babel
+ :version "24.3"
+ :type 'string)
+
+(defun org-babel-execute:csharp (body params)
+ (let* ((full-body (org-babel-expand-body:generic body params))
+ (cmpflag (or (cdr (assq :cmpflag params)) ""))
+ (cmdline (or (cdr (assq :cmdline params)) ""))
+ (src-file (org-babel-temp-file "csharp-src-" ".cs"))
+ (exe-file (concat (file-name-sans-extension src-file) ".exe"))
+ (compile
+ (progn (with-temp-file src-file (insert full-body))
+ (org-babel-eval
+ (concat org-babel-csharp-compiler " " cmpflag " " src-file) ""))))
+ (let ((results (org-babel-eval (concat org-babel-csharp-command " " cmdline " " exe-file) "")))
+ (org-babel-reassemble-table
+ (org-babel-result-cond (cdr (assq :result-params params))
+ (org-babel-read results)
+ (let ((tmp-file (org-babel-temp-file "c-")))
+ (with-temp-file tmp-file (insert results))
+ (org-babel-import-elisp-from-file tmp-file)))
+ (org-babel-pick-name
+ (cdr (assq :colname-names params)) (cdr (assq :colnames params)))
+ (org-babel-pick-name
+ (cdr (assq :rowname-names params)) (cdr (assq :rownames params)))))))
+
+(defun org-babel-prep-session:csharp (session params)
+ "Return an error because csharp does not support sessions."
+ (error "Sessions are not supported for CSharp"))
+
+(provide 'ob-csharp)
+
+
+
+;;; ob-csharp.el ends here
diff --git a/contrib/lisp/ob-eukleides.el b/contrib/lisp/ob-eukleides.el
index e25ed1c..d3ad993 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-2013 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
;; Author: Luis Anaya
;; Keywords: literate programming, reproducible research
@@ -58,12 +58,12 @@
(defun org-babel-execute:eukleides (body params)
"Execute a block of eukleides code with org-babel.
This function is called by `org-babel-execute-src-block'."
- (let* ((result-params (split-string (or (cdr (assoc :results params)) "")))
- (out-file (or (cdr (assoc :file params))
+ (let* ((result-params (split-string (or (cdr (assq :results params)) "")))
+ (out-file (or (cdr (assq :file params))
(error "Eukleides requires a \":file\" header argument")))
- (cmdline (cdr (assoc :cmdline params)))
+ (cmdline (cdr (assq :cmdline params)))
(in-file (org-babel-temp-file "eukleides-"))
- (java (or (cdr (assoc :java params)) ""))
+ (java (or (cdr (assq :java params)) ""))
(cmd (if (not org-eukleides-path)
(error "`org-eukleides-path' is not set")
(concat (expand-file-name org-eukleides-path)
@@ -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 58183fb..30f292f 100644
--- a/contrib/lisp/ob-fomus.el
+++ b/contrib/lisp/ob-fomus.el
@@ -1,6 +1,6 @@
;;; ob-fomus.el --- Org-babel functions for fomus evaluation
-;; Copyright (C) 2011-2013 Torsten Anders
+;; Copyright (C) 2011-2014 Torsten Anders
;; Author: Torsten Anders
;; Keywords: literate programming, reproducible research
@@ -48,7 +48,7 @@
(defun org-babel-expand-body:fomus (body params)
"Expand BODY according to PARAMS, return the expanded body."
- (let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
+ (let ((vars (org-babel--get-vars params)))
(mapc
(lambda (pair)
(let ((name (symbol-name (car pair)))
@@ -64,10 +64,10 @@
(defun org-babel-execute:fomus (body params)
"Execute a block of Fomus code with org-babel.
This function is called by `org-babel-execute-src-block'."
- (let* ((result-params (cdr (assoc :result-params params)))
- (out-file (cdr (assoc :file params)))
- (cmdline (cdr (assoc :cmdline params)))
- (cmd (or (cdr (assoc :cmd params)) "fomus"))
+ (let* ((result-params (cdr (assq :result-params params)))
+ (out-file (cdr (assq :file params)))
+ (cmdline (cdr (assq :cmdline params)))
+ (cmd (or (cdr (assq :cmd params)) "fomus"))
(in-file (org-babel-temp-file "fomus-" ".fms")))
(with-temp-file in-file
(insert (org-babel-expand-body:fomus body params)))
diff --git a/contrib/lisp/ob-julia.el b/contrib/lisp/ob-julia.el
index 3aed818..41c8b5a 100644
--- a/contrib/lisp/ob-julia.el
+++ b/contrib/lisp/ob-julia.el
@@ -1,6 +1,6 @@
;;; ob-julia.el --- org-babel functions for julia code evaluation
-;; Copyright (C) 2013 G. Jay Kerns
+;; Copyright (C) 2013, 2014 G. Jay Kerns
;; Author: G. Jay Kerns, based on ob-R.el by Eric Schulte and Dan Davison
;; This file is not part of GNU Emacs.
@@ -30,7 +30,7 @@
;;; Code:
(require 'ob)
-(eval-when-compile (require 'cl))
+(require 'cl-lib)
(declare-function orgtbl-to-csv "org-table" (table params))
(declare-function julia "ext:ess-julia" (&optional start-args))
@@ -38,7 +38,6 @@
(declare-function ess-make-buffer-current "ext:ess-inf" ())
(declare-function ess-eval-buffer "ext:ess-inf" (vis))
(declare-function org-number-sequence "org-compat" (from &optional to inc))
-(declare-function org-remove-if-not "org" (predicate seq))
(defconst org-babel-header-args:julia
'((width . :any)
@@ -62,7 +61,7 @@
(defvar ess-local-process-name) ; dynamically scoped
(defun org-babel-edit-prep:julia (info)
- (let ((session (cdr (assoc :session (nth 2 info)))))
+ (let ((session (cdr (assq :session (nth 2 info)))))
(when (and session (string-match "^\\*\\(.+?\\)\\*$" session))
(save-match-data (org-babel-julia-initiate-session session nil)))))
@@ -83,12 +82,12 @@
"Execute a block of julia code.
This function is called by `org-babel-execute-src-block'."
(save-excursion
- (let* ((result-params (cdr (assoc :result-params params)))
- (result-type (cdr (assoc :result-type params)))
+ (let* ((result-params (cdr (assq :result-params params)))
+ (result-type (cdr (assq :result-type params)))
(session (org-babel-julia-initiate-session
- (cdr (assoc :session params)) params))
- (colnames-p (cdr (assoc :colnames params)))
- (rownames-p (cdr (assoc :rownames params)))
+ (cdr (assq :session params)) params))
+ (colnames-p (cdr (assq :colnames params)))
+ (rownames-p (cdr (assq :rownames params)))
(graphics-file (org-babel-julia-graphical-output-file params))
(full-body (org-babel-expand-body:julia body params graphics-file))
(result
@@ -96,10 +95,10 @@ This function is called by `org-babel-execute-src-block'."
session full-body result-type result-params
(or (equal "yes" colnames-p)
(org-babel-pick-name
- (cdr (assoc :colname-names params)) colnames-p))
+ (cdr (assq :colname-names params)) colnames-p))
(or (equal "yes" rownames-p)
(org-babel-pick-name
- (cdr (assoc :rowname-names params)) rownames-p)))))
+ (cdr (assq :rowname-names params)) rownames-p)))))
(if graphics-file nil result))))
(defun org-babel-prep-session:julia (session params)
@@ -125,20 +124,20 @@ This function is called by `org-babel-execute-src-block'."
(defun org-babel-variable-assignments:julia (params)
"Return list of julia statements assigning the block's variables."
- (let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
+ (let ((vars (org-babel--get-vars params)))
(mapcar
(lambda (pair)
(org-babel-julia-assign-elisp
(car pair) (cdr pair)
- (equal "yes" (cdr (assoc :colnames params)))
- (equal "yes" (cdr (assoc :rownames params)))))
+ (equal "yes" (cdr (assq :colnames params)))
+ (equal "yes" (cdr (assq :rownames params)))))
(mapcar
(lambda (i)
(cons (car (nth i vars))
(org-babel-reassemble-table
(cdr (nth i vars))
- (cdr (nth i (cdr (assoc :colname-names params))))
- (cdr (nth i (cdr (assoc :rowname-names params)))))))
+ (cdr (nth i (cdr (assq :colname-names params))))
+ (cdr (nth i (cdr (assq :rowname-names params)))))))
(org-number-sequence 0 (1- (length vars)))))))
(defun org-babel-julia-quote-csv-field (s)
@@ -150,9 +149,9 @@ This function is called by `org-babel-execute-src-block'."
(defun org-babel-julia-assign-elisp (name value colnames-p rownames-p)
"Construct julia code assigning the elisp VALUE to a variable named NAME."
(if (listp value)
- (let ((max (apply #'max (mapcar #'length (org-remove-if-not
+ (let ((max (apply #'max (mapcar #'length (cl-remove-if-not
#'sequencep value))))
- (min (apply #'min (mapcar #'length (org-remove-if-not
+ (min (apply #'min (mapcar #'length (cl-remove-if-not
#'sequencep value))))
(transition-file (org-babel-temp-file "julia-import-")))
;; ensure VALUE has an orgtbl structure (depth of at least 2)
@@ -179,7 +178,7 @@ This function is called by `org-babel-execute-src-block'."
(let ((session (or session "*julia*"))
(ess-ask-for-ess-directory
(and (and (boundp 'ess-ask-for-ess-directory) ess-ask-for-ess-directory)
- (not (cdr (assoc :dir params))))))
+ (not (cdr (assq :dir params))))))
(if (org-babel-comint-buffer-livep session)
session
(save-window-excursion
@@ -229,7 +228,7 @@ current code buffer."
If RESULT-TYPE equals 'output then return standard output as a
string. If RESULT-TYPE equals 'value then return the value of the
last statement in BODY, as elisp."
- (case result-type
+ (cl-case result-type
(value
(let ((tmp-file (org-babel-temp-file "julia-")))
(org-babel-eval org-babel-julia-command
@@ -251,7 +250,7 @@ last statement in BODY, as elisp."
If RESULT-TYPE equals 'output then return standard output as a
string. If RESULT-TYPE equals 'value then return the value of the
last statement in BODY, as elisp."
- (case result-type
+ (cl-case result-type
(value
(with-temp-buffer
(insert (org-babel-chomp body))
diff --git a/contrib/lisp/ob-mathematica.el b/contrib/lisp/ob-mathematica.el
new file mode 100644
index 0000000..cb35dec
--- a/dev/null
+++ b/contrib/lisp/ob-mathematica.el
@@ -0,0 +1,81 @@
+;;; 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 (assq :result-params params)))
+ (full-body (org-babel-expand-body:mathematica body params))
+ (tmp-script-file (org-babel-temp-file "mathematica-"))
+ (cmd org-babel-mathematica-command))
+ ;; actually execute the source-code block
+ (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 585604e..c62e181 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-2013 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
;; Author: Eric S Fraga
;; Eric Schulte
@@ -49,45 +49,45 @@
(defun org-babel-mathomatic-expand (body params)
"Expand a block of Mathomatic code according to its header arguments."
- (let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
- (mapconcat 'identity
- (list
- ;; graphic output
- (let ((graphic-file (org-babel-mathomatic-graphical-output-file params)))
- (if graphic-file
- (cond
- ((string-match ".\.eps$" graphic-file)
- (format ;; Need to add command to send to file.
- "set plot set terminal postscript eps\\;set output %S "
- graphic-file))
- ((string-match ".\.ps$" graphic-file)
- (format ;; Need to add command to send to file.
- "set plot set terminal postscript\\;set output %S "
- graphic-file))
-
- ((string-match ".\.pic$" graphic-file)
- (format ;; Need to add command to send to file.
- "set plot set terminal gpic\\;set output %S "
- graphic-file))
- (t
- (format ;; Need to add command to send to file.
- "set plot set terminal png\\;set output %S "
- graphic-file)))
- ""))
- ;; variables
- (mapconcat 'org-babel-mathomatic-var-to-mathomatic vars "\n")
- ;; body
- body
- "")
- "\n")))
+ (let ((vars (org-babel--get-vars params)))
+ (mapconcat 'identity
+ (list
+ ;; graphic output
+ (let ((graphic-file (org-babel-mathomatic-graphical-output-file params)))
+ (if graphic-file
+ (cond
+ ((string-match ".\.eps$" graphic-file)
+ (format ;; Need to add command to send to file.
+ "set plot set terminal postscript eps\\;set output %S "
+ graphic-file))
+ ((string-match ".\.ps$" graphic-file)
+ (format ;; Need to add command to send to file.
+ "set plot set terminal postscript\\;set output %S "
+ graphic-file))
+
+ ((string-match ".\.pic$" graphic-file)
+ (format ;; Need to add command to send to file.
+ "set plot set terminal gpic\\;set output %S "
+ graphic-file))
+ (t
+ (format ;; Need to add command to send to file.
+ "set plot set terminal png\\;set output %S "
+ graphic-file)))
+ ""))
+ ;; variables
+ (mapconcat 'org-babel-mathomatic-var-to-mathomatic vars "\n")
+ ;; body
+ body
+ "")
+ "\n")))
(defun org-babel-execute:mathomatic (body params)
"Execute a block of Mathomatic entries with org-babel. This function is
called by `org-babel-execute-src-block'."
(message "executing Mathomatic source code block")
- (let ((result-params (split-string (or (cdr (assoc :results params)) "")))
+ (let ((result-params (split-string (or (cdr (assq :results params)) "")))
(result
- (let* ((cmdline (or (cdr (assoc :cmdline params)) ""))
+ (let* ((cmdline (or (cdr (assq :cmdline params)) ""))
(in-file (org-babel-temp-file "mathomatic-" ".math"))
(cmd (format "%s -t -c -q %s %s"
org-babel-mathomatic-command in-file cmdline)))
diff --git a/contrib/lisp/ob-oz.el b/contrib/lisp/ob-oz.el
index ce8e8a6..9beadeb 100644
--- a/contrib/lisp/ob-oz.el
+++ b/contrib/lisp/ob-oz.el
@@ -1,6 +1,6 @@
;;; ob-oz.el --- Org-babel functions for Oz evaluation
-;; Copyright (C) 2009-2013 Torsten Anders and Eric Schulte
+;; Copyright (C) 2009-2014 Torsten Anders and Eric Schulte
;; Author: Torsten Anders and Eric Schulte
;; Keywords: literate programming, reproducible research
@@ -90,7 +90,7 @@
(require 'ob)
;;; major mode for editing Oz programs
-(require 'mozart)
+(require 'mozart nil t)
;;
;; Interface to communicate with Oz.
@@ -197,7 +197,7 @@ StartOzServer.oz is located.")
result))
(defun org-babel-expand-body:oz (body params)
- (let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
+ (let ((vars (org-babel--get-vars params)))
(if vars
;; prepend code to define all arguments passed to the code block
(let ((var-string (mapcar (lambda (pair)
@@ -214,7 +214,7 @@ StartOzServer.oz is located.")
(defun org-babel-execute:oz (body params)
"Execute a block of Oz code with org-babel. This function is
called by `org-babel-execute-src-block' via multiple-value-bind."
- (let* ((result-params (cdr (assoc :result-params params)))
+ (let* ((result-params (cdr (assq :result-params params)))
(full-body (org-babel-expand-body:oz body params))
(wait-time (plist-get params :wait-time)))
;; actually execute the source-code block
@@ -226,11 +226,11 @@ 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.")))
- (org-babel-pick-name (cdr (assoc :colname-names params))
- (cdr (assoc :colnames params)))
- (org-babel-pick-name (cdr (assoc :roname-names params))
- (cdr (assoc :rownames params))))))
+ (t (error "either 'output' or 'results' must be members of :results")))
+ (org-babel-pick-name (cdr (assq :colname-names params))
+ (cdr (assq :colnames params)))
+ (org-babel-pick-name (cdr (assq :roname-names params))
+ (cdr (assq :rownames params))))))
;; This function should be used to assign any variables in params in
;; the context of the session environment.
diff --git a/contrib/lisp/ob-sclang.el b/contrib/lisp/ob-sclang.el
new file mode 100644
index 0000000..d2d1b71
--- a/dev/null
+++ b/contrib/lisp/ob-sclang.el
@@ -0,0 +1,92 @@
+;;; ob-sclang.el --- SCLang support for Org-mode Babel
+;;; -*- coding: utf-8 -*-
+
+;; Copyright (C) 2017 Free Software Foundation, Inc.
+
+;; Authors: stardiviner <numbchild@gmail.com>
+;; Package-Version: 0.1
+;; Keywords: babel sclang
+
+;; 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:
+
+;; `ob-sclang' requires `sclang-interp' from SuperCollider.
+;; Usually SuperCollider dependencies for Emacs are at /usr/share/emacs/site-lisp/SuperCollider/
+;; You can install SuperCollider following this article:
+;; https://github.com/supercollider/supercollider#building-the-source-code
+
+;; Usage:
+
+;; Support to evaluate sclang Org-mode src block with function `sclang-eval-string'.
+
+;; For example:
+
+;; #+BEGIN_SRC sclang :results none
+;; "Hello World".postln;
+;; #+END_SRC
+;;
+;; *NOTE* Temporary output to org-babel result output is not supported.
+;; Because `sclang-eval-string' will send output to Sclang Post Buffer.
+;; And command line `sclang' execute will not automatically stop after finished execution.
+;;
+;; #+BEGIN_SRC sclang :results none
+;; // modulate a sine frequency and a noise amplitude with another sine
+;; // whose frequency depends on the horizontal mouse pointer position
+;; {
+;; var x = SinOsc.ar(MouseX.kr(1, 100));
+;; SinOsc.ar(300 * x + 800, 0, 0.1)
+;; +
+;; PinkNoise.ar(0.1 * x + 0.1)
+;; }.play;
+;; #+END_SRC
+
+
+;;; Code:
+;;; ----------------------------------------------------------------------------
+(require 'org)
+(require 'ob)
+
+(require 'sclang-interp)
+
+(defgroup ob-sclang nil
+ "org-mode blocks for SuperCollider SCLang."
+ :group 'org)
+
+;;;###autoload
+(defun org-babel-execute:sclang (body params)
+ "Org-mode Babel sclang hook for evaluate `BODY' with `PARAMS'."
+ (unless (or (equal (buffer-name) sclang-post-buffer)
+ (sclang-get-process))
+ (sclang-start))
+ (sclang-eval-string body t))
+
+(defvar org-babel-default-header-args:sclang nil)
+
+(setq org-babel-default-header-args:sclang
+ '((:session . "*SCLang:Workspace*")
+ ;; TODO: temporary can't find way to let sclang output to stdout for org-babel.
+ (:output . "none")))
+
+(eval-after-load "org"
+ '(progn
+ (add-to-list 'org-src-lang-modes '("sclang" . sclang))))
+
+;;; ----------------------------------------------------------------------------
+
+(provide 'ob-sclang)
+
+;;; ob-sclang.el ends here
diff --git a/contrib/lisp/ob-stata.el b/contrib/lisp/ob-stata.el
new file mode 100644
index 0000000..d8cf52a
--- 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 (assq :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 (assq :result-params params)))
+ (result-type (cdr (assq :result-type params)))
+ (session (org-babel-stata-initiate-session
+ (cdr (assq :session params)) params))
+ (colnames-p (cdr (assq :colnames params)))
+ (rownames-p (cdr (assq :rownames params)))
+ (graphics-file (org-babel-stata-graphical-output-file params))
+ (full-body (org-babel-expand-body:stata body params graphics-file))
+ (result
+ (org-babel-stata-evaluate
+ session full-body result-type result-params
+ (or (equal "yes" colnames-p)
+ (org-babel-pick-name
+ (cdr (assq :colname-names params)) colnames-p))
+ (or (equal "yes" rownames-p)
+ (org-babel-pick-name
+ (cdr (assq :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 (assq :colnames params)))
+ (equal "yes" (cdr (assq :rownames params)))))
+ (mapcar
+ (lambda (i)
+ (cons (car (nth i vars))
+ (org-babel-reassemble-table
+ (cdr (nth i vars))
+ (cdr (nth i (cdr (assq :colname-names params))))
+ (cdr (nth i (cdr (assq :rowname-names params)))))))
+ (org-number-sequence 0 (1- (length vars)))))))
+
+(defun org-babel-stata-quote-csv-field (s)
+ "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 (assq :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 e8d735b..c76b138 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-2013 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
;; Authors: Dan Davison
;; Eric Schulte
@@ -47,22 +47,22 @@
(defun org-babel-execute:tcl (body params)
"Execute a block of Tcl code with Babel.
This function is called by `org-babel-execute-src-block'."
- (let* ((session (cdr (assoc :session params)))
- (result-params (cdr (assoc :result-params params)))
- (result-type (cdr (assoc :result-type params)))
+ (let* ((session (cdr (assq :session params)))
+ (result-params (cdr (assq :result-params params)))
+ (result-type (cdr (assq :result-type params)))
(full-body (org-babel-expand-body:generic
body params (org-babel-variable-assignments:tcl params)))
(session (org-babel-tcl-initiate-session session)))
(org-babel-reassemble-table
(org-babel-tcl-evaluate session full-body result-type)
(org-babel-pick-name
- (cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
+ (cdr (assq :colname-names params)) (cdr (assq :colnames params)))
(org-babel-pick-name
- (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params))))))
+ (cdr (assq :rowname-names params)) (cdr (assq :rownames params))))))
(defun org-babel-prep-session:tcl (session params)
"Prepare SESSION according to the header arguments in PARAMS."
- (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..b0f2688
--- 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-2017 Free Software Foundation, Inc.
+
+;; Author: thomas "at" friendlyvillagers.com based on ob-java.el by Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+
+;; This file is not part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Currently this only supports the external compilation and execution
+;; of VB.Net code blocks (i.e., no session support).
+
+;;; Code:
+(require 'ob)
+
+(defvar org-babel-tangle-lang-exts)
+(add-to-list 'org-babel-tangle-lang-exts '("vbnet" . "vb"))
+
+(defcustom org-babel-vbnet-command "mono"
+ "Name of the mono command.
+May be either a command in the path, like mono
+or an absolute path name, like /usr/local/bin/mono
+parameters may be used, like mono -verbose"
+ :group 'org-babel
+ :version "24.3"
+ :type 'string)
+
+(defcustom org-babel-vbnet-compiler "vbnc"
+ "Name of the VB.Net compiler.
+May be either a command in the path, like vbnc
+or an absolute path name, like /usr/local/bin/vbnc
+parameters may be used, like vbnc /warnaserror+"
+ :group 'org-babel
+ :version "24.3"
+ :type 'string)
+
+(defun org-babel-execute:vbnet (body params)
+ (let* ((full-body (org-babel-expand-body:generic body params))
+ (cmpflag (or (cdr (assq :cmpflag params)) ""))
+ (cmdline (or (cdr (assq :cmdline params)) ""))
+ (src-file (org-babel-temp-file "vbnet-src-" ".vb"))
+ (exe-file (concat (file-name-sans-extension src-file) ".exe"))
+ (compile
+ (progn (with-temp-file src-file (insert full-body))
+ (org-babel-eval
+ (concat org-babel-vbnet-compiler " " cmpflag " " src-file)
+ ""))))
+ (let ((results (org-babel-eval (concat org-babel-vbnet-command " " cmdline " " exe-file) "")))
+ (org-babel-reassemble-table
+ (org-babel-result-cond (cdr (assq :result-params params))
+ (org-babel-read results)
+ (let ((tmp-file (org-babel-temp-file "c-")))
+ (with-temp-file tmp-file (insert results))
+ (org-babel-import-elisp-from-file tmp-file)))
+ (org-babel-pick-name
+ (cdr (assq :colname-names params)) (cdr (assq :colnames params)))
+ (org-babel-pick-name
+ (cdr (assq :rowname-names params)) (cdr (assq :rownames params)))))))
+
+(defun org-babel-prep-session:vbnet (session params)
+ "Return an error because vbnet does not support sessions."
+ (error "Sessions are not supported for VB.Net"))
+
+(provide 'ob-vbnet)
+
+
+
+;;; ob-vbnet.el ends here
diff --git a/contrib/lisp/org-annotate-file.el b/contrib/lisp/org-annotate-file.el
index bdb9acb..b8e8bd9 100644
--- a/contrib/lisp/org-annotate-file.el
+++ b/contrib/lisp/org-annotate-file.el
@@ -1,6 +1,6 @@
;;; org-annotate-file.el --- Annotate a file with org syntax
-;; Copyright (C) 2008-2013 Philip Jackson
+;; Copyright (C) 2008-2014 Philip Jackson
;; Author: Philip Jackson <phil@shellarchive.co.uk>
;; Version: 0.2
@@ -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 93c97a9..c5b521a 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-2013 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2017 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)
@@ -131,12 +113,12 @@ For example, to point to your `obe-bibtex-file' use the following.
(add (remove-duplicates (col field) :test #'string=)))
;; build the links in the graph
(dolist (citation meta)
- (let ((dest (id (cdr (assoc :title citation)))))
- (dolist (author (mapcar #'id (cdr (assoc :authors citation))))
+ (let ((dest (id (cdr (assq :title citation)))))
+ (dolist (author (mapcar #'id (cdr (assq :authors citation))))
(when author (push (cons author dest) links)))
- (let ((jid (id (cdr (assoc :journal citation)))))
+ (let ((jid (id (cdr (assq :journal citation)))))
(when jid (push (cons jid dest) links)))
- (let ((cid (id (cdr (assoc :category citation)))))
+ (let ((cid (id (cdr (assq :category citation)))))
(when cid (push (cons cid dest) links)))))
;; build the json string
(format "{\"nodes\":[%s],\"links\":[%s]}"
diff --git a/contrib/lisp/org-bookmark.el b/contrib/lisp/org-bookmark.el
index 44588b6..04a473b 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-2013 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2017 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-bullets.el b/contrib/lisp/org-bullets.el
deleted file mode 100644
index 2951bf8..0000000
--- a/contrib/lisp/org-bullets.el
+++ b/dev/null
@@ -1,122 +0,0 @@
-;;; org-bullets.el --- Show bullets in org-mode as UTF-8 characters
-;; Version: 0.2.2
-;; Author: sabof
-;; URL: https://github.com/sabof/org-bullets
-
-;; 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 this program ; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Commentary:
-
-;; The project is hosted at https://github.com/sabof/org-bullets
-;; The latest version, and all the relevant information can be found there.
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-
-(defgroup org-bullets nil
- "Display bullets as UTF-8 characters."
- :group 'org-appearance)
-
-;; A nice collection of unicode bullets:
-;; http://nadeausoftware.com/articles/2007/11/latency_friendly_customized_bullets_using_unicode_characters
-(defcustom org-bullets-bullet-list
- '(;;; Large
- "◉"
- "○"
- "✸"
- "✿"
- ;; ♥ ● ◇ ✚ ✜ ☯ ◆ ♠ ♣ ♦ ☢ ❀ ◆ ◖ ▶
- ;;; Small
- ;; ► • ★ ▸
- )
- "This variable contains the list of bullets.
-It can contain any number of one-character strings.
-For levels beyond the size of the list, the stars will be
-displayed using the first items again."
- :group 'org-bullets
- :type '(repeat (string :tag "Bullet character")))
-
-(defcustom org-bullets-face-name nil
- "Allows to override `org-mode' bullets face.
-If set to a name of a face, that face will be used.
-Otherwise the face of the heading level will be used."
- :group 'org-bullets
- :type 'symbol)
-
-(defvar org-bullets-bullet-map
- '(keymap
- (mouse-1 . org-cycle)
- (mouse-2 . (lambda (e)
- (interactive "e")
- (mouse-set-point e)
- (org-cycle))))
- "Mouse events for bullets.
-If this is undesirable, one can remove them with
-
-\(setcdr org-bullets-bullet-map nil\)")
-
-(defun org-bullets-level-char (level)
- "Return a character corresponding to LEVEL."
- (string-to-char
- (nth (mod (1- level)
- (length org-bullets-bullet-list))
- org-bullets-bullet-list)))
-
-;;;###autoload
-(define-minor-mode org-bullets-mode
- "UTF-8 bullets for `org-mode'."
- nil nil nil
- (let* ((keyword
- `((,org-outline-regexp-bol
- (0 (let (( level (- (match-end 0) (match-beginning 0) 1)))
- (compose-region (- (match-end 0) 2)
- (- (match-end 0) 1)
- (org-bullets-level-char level))
- (when (facep org-bullets-face-name)
- (put-text-property (- (match-end 0) 2)
- (- (match-end 0) 1)
- 'face
- org-bullets-face-name))
- (put-text-property (match-beginning 0)
- (- (match-end 0) 2)
- 'face (list :foreground
- (face-attribute
- 'default :background)))
- (put-text-property (match-beginning 0)
- (match-end 0)
- 'keymap
- org-bullets-bullet-map)
- nil))))))
- (if org-bullets-mode
- (progn (font-lock-add-keywords nil keyword)
- (font-lock-fontify-buffer))
- (save-excursion
- (goto-char (point-min))
- (font-lock-remove-keywords nil keyword)
- (while (re-search-forward org-outline-regexp-bol nil t)
- (decompose-region (match-beginning 0) (match-end 0)))
- (font-lock-fontify-buffer)))))
-
-(provide 'org-bullets)
-
-;; Local Variables:
-;; coding: utf-8-emacs
-;; End:
-
-;;; org-bullets.el ends here
diff --git a/contrib/lisp/org-checklist.el b/contrib/lisp/org-checklist.el
index faa5998..2bc00c0 100644
--- a/contrib/lisp/org-checklist.el
+++ b/contrib/lisp/org-checklist.el
@@ -1,6 +1,6 @@
;;; org-checklist.el --- org functions for checklist handling
-;; Copyright (C) 2008-2013 James TD Smith
+;; Copyright (C) 2008-2014 James TD Smith
;; Author: James TD Smith (@ ahktenzero (. mohorovi cc))
;; Version: 1.0
diff --git a/contrib/lisp/org-choose.el b/contrib/lisp/org-choose.el
index 8e5935d..c1006d0 100644
--- a/contrib/lisp/org-choose.el
+++ b/contrib/lisp/org-choose.el
@@ -1,6 +1,6 @@
;;; org-choose.el --- decision management for org-mode
-;; Copyright (C) 2009-2013 Tom Breton (Tehom)
+;; Copyright (C) 2009-2014 Tom Breton (Tehom)
;; This file is not part of GNU Emacs.
diff --git a/contrib/lisp/org-collector.el b/contrib/lisp/org-collector.el
index d62a462..10ec0cb 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-2013 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2017 Free Software Foundation, Inc.
;; Author: Eric Schulte <schulte dot eric at gmail dot com>
;; Keywords: outlines, hypermedia, calendar, wp, experimentation,
diff --git a/contrib/lisp/org-colview-xemacs.el b/contrib/lisp/org-colview-xemacs.el
deleted file mode 100644
index f9b35d3..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-2013
-;; 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 dbbc057..2cadd1d 100644
--- a/contrib/lisp/org-contacts.el
+++ b/contrib/lisp/org-contacts.el
@@ -1,6 +1,6 @@
;;; org-contacts.el --- Contacts management
-;; Copyright (C) 2010-2013 Julien Danjou <julien@danjou.info>
+;; Copyright (C) 2010-2014 Julien Danjou <julien@danjou.info>
;; Author: Julien Danjou <julien@danjou.info>
;; Keywords: outlines, hypermedia, calendar
@@ -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)))
@@ -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 8132750..4ad3116 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-2013 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2017 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 dc99a1d..78a07cf 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-2013 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2017 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
@@ -207,11 +207,11 @@ This does two different kinds of triggers:
(org-refresh-properties org-effort-property 'org-effort)
;; Get information from the plist
(let* ((type (plist-get change-plist :type))
- (pos (plist-get change-plist :position))
+ (pos (plist-get change-plist :position))
(from (plist-get change-plist :from))
(to (plist-get change-plist :to))
(org-log-done nil) ; IMPROTANT!: no logging during automatic trigger!
- trigger triggers tr p1 kwd id)
+ trigger triggers tr p1 p2 kwd id)
(catch 'return
(unless (eq type 'todo-state-change)
;; We are only handling todo-state-change....
@@ -225,7 +225,7 @@ This does two different kinds of triggers:
;; Lets see if this entry has a TRIGGER property.
;; If yes, split it up on whitespace.
(setq trigger (org-entry-get pos "TRIGGER")
- triggers (and trigger (org-split-string trigger "[ \t]+")))
+ triggers (and trigger (split-string trigger)))
;; Go through all the triggers
(while (setq tr (pop triggers))
@@ -270,7 +270,7 @@ This does two different kinds of triggers:
(effort (when (or effort-up effort-down)
(let ((effort (get-text-property (point) 'org-effort)))
(when effort
- (org-duration-string-to-minutes effort))))))
+ (org-duration-to-minutes effort))))))
(push (list (point) todo-kwd priority tags effort)
items))
(unless (org-goto-sibling)
@@ -336,11 +336,17 @@ This does two different kinds of triggers:
(setq id (match-string 1 tr)
kwd (match-string 2 tr)
p1 (org-find-entry-with-id id))
- (when p1
- ;; there is an entry with this ID, mark it TODO
- (save-excursion
- (goto-char p1)
- (org-todo kwd))))
+ ;; First check current buffer, then all files.
+ (if p1
+ ;; There is an entry with this ID, mark it TODO.
+ (save-excursion
+ (goto-char p1)
+ (org-todo kwd))
+ (when (setq p2 (org-id-find id))
+ (save-excursion
+ (with-current-buffer (find-file-noselect (car p2))
+ (goto-char (cdr p2))
+ (org-todo kwd))))))
((string-match "\\`chain-siblings-scheduled\\'" tr)
(let ((time (org-get-scheduled-time pos)))
(when time
@@ -358,11 +364,11 @@ Any other words are treated as entry id's. If an entry exists with the
this ID property, that entry is also checked."
;; Get information from the plist
(let* ((type (plist-get change-plist :type))
- (pos (plist-get change-plist :position))
+ (pos (plist-get change-plist :position))
(from (plist-get change-plist :from))
(to (plist-get change-plist :to))
(org-log-done nil) ; IMPROTANT!: no logging during automatic trigger
- blocker blockers bl p1
+ blocker blockers bl p1 p2
(proceed-p
(catch 'return
;; If this is not a todo state change, or if this entry is
@@ -377,7 +383,7 @@ this ID property, that entry is also checked."
;; Lets see if we will allow it. Find the BLOCKER property
;; and split it on whitespace.
(setq blocker (org-entry-get pos "BLOCKER")
- blockers (and blocker (org-split-string blocker "[ \t]+")))
+ blockers (and blocker (split-string blocker)))
;; go through all the blockers
(while (setq bl (pop blockers))
@@ -388,15 +394,13 @@ this ID property, that entry is also checked."
(save-excursion
(goto-char pos)
;; find the older sibling, exit if no more siblings
- (condition-case nil
- (outline-backward-same-level 1)
- (error (throw 'ignore t)))
+ (unless (org-get-last-sibling)
+ (throw 'ignore t))
;; Check if this entry is not yet done and block
(unless (org-entry-is-done-p)
;; return nil, to indicate that we block the change!
(org-mark-ring-push)
(throw 'return nil)))))
-
((setq p1 (org-find-entry-with-id bl))
;; there is an entry with this ID, check it out
(save-excursion
@@ -404,9 +408,16 @@ this ID property, that entry is also checked."
(unless (org-entry-is-done-p)
;; return nil, to indicate that we block the change!
(org-mark-ring-push)
- (throw 'return nil))))))
- t ; return t to indicate that we are not blocking
- )))
+ (throw 'return nil))))
+ ((setq p2 (org-id-find bl))
+ (save-excursion
+ (with-current-buffer (find-file-noselect (car p2))
+ (goto-char (cdr p2))
+ (unless (org-entry-is-done-p)
+ (org-mark-ring-push)
+ (throw 'return nil)))))))
+ ;; Return t to indicate that we are not blocking.
+ t)))
(when org-depend-tag-blocked
(org-toggle-tag "blocked" (if proceed-p 'off 'on)))
diff --git a/contrib/lisp/org-drill.el b/contrib/lisp/org-drill.el
index 5bf6dd4..7c4a299 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.
@@ -104,62 +128,89 @@ Possible values:
but a warning message is printed when each leech item is
presented."
:group 'org-drill
- :type '(choice (const 'warn) (const 'skip) (const nil)))
+ :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:
@@ -256,18 +342,34 @@ directory All files with the extension '.org' in the same
;; 'file-no-restriction' means current file/buffer, ignoring restrictions
;; 'directory' means all *.org files in current directory
:group 'org-drill
- :type '(choice (const 'file) (const 'tree) (const 'file-no-restriction)
- (const 'file-with-archives) (const 'agenda)
- (const 'agenda-with-archives) (const 'directory)
- list))
+ :type '(choice (const :tag "The current buffer, respecting the restriction if any." file)
+ (const :tag "The subtree started with the entry at point" tree)
+ (const :tag "The current buffer, without restriction" file-no-restriction)
+ (const :tag "The current buffer, and any archives associated with it." file-with-archives)
+ (const :tag "All agenda files" agenda)
+ (const :tag "All agenda files with any archive files associated with them." agenda-with-archives)
+ (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-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
+
+(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
@@ -280,28 +382,55 @@ Available choices are:
adjusting intervals when items are reviewed early or late has been taken
from SM11, a later version of the algorithm, and included in Simple8."
:group 'org-drill
- :type '(choice (const 'sm2) (const 'sm5) (const 'simple8)))
+ :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.")
+
-(defcustom org-drill-sm5-initial-interval 4.0
+(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
"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
@@ -309,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
@@ -324,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
@@ -343,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
@@ -361,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
@@ -379,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
@@ -389,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
@@ -399,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)
@@ -427,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))))
@@ -454,17 +605,24 @@ 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)))
+ (let ((idx (cl-gensym)))
`(if (null ,place)
nil
(let ((,idx (random* (length ,place))))
@@ -472,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))
@@ -492,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)
@@ -523,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)
@@ -531,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)
@@ -539,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
@@ -549,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.
@@ -562,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."
@@ -573,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
@@ -582,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?"
@@ -593,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."
@@ -604,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*
@@ -626,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.
@@ -655,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
@@ -670,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
@@ -722,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))))
@@ -744,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.
@@ -763,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:
@@ -800,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)
@@ -815,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:
@@ -836,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
@@ -860,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
@@ -873,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)
@@ -892,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)
@@ -910,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)
@@ -938,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
@@ -949,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.
@@ -959,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."
@@ -968,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)
@@ -1034,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.
@@ -1042,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.
@@ -1083,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
@@ -1113,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))
@@ -1143,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.
@@ -1158,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)))
@@ -1179,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))
@@ -1187,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)
@@ -1209,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."
@@ -1224,7 +1455,7 @@ How well did you do? (0-5, ?=help, e=edit, t=tags, q=quit)"
;; (save-excursion
;; (org-map-entries
;; (lambda ()
-;; (when (and (not (outline-invisible-p))
+;; (when (and (not (org-invisible-p))
;; (> (org-current-level) drill-entry-level))
;; (setq drill-heading (org-get-heading t))
;; (unless (and (= (org-current-level) (1+ drill-entry-level))
@@ -1234,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
@@ -1247,7 +1480,7 @@ the current topic."
(save-excursion
(org-map-entries
(lambda ()
- (when (and (not (outline-invisible-p))
+ (when (and (not (org-invisible-p))
(> (org-current-level) drill-entry-level))
(when (or (/= (org-current-level) (1+ drill-entry-level))
(funcall test))
@@ -1256,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)
@@ -1275,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
@@ -1322,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)))
@@ -1333,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."))
@@ -1365,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
@@ -1377,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)))
@@ -1394,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
@@ -1407,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)
@@ -1416,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."
@@ -1426,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."
@@ -1436,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
@@ -1454,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
@@ -1480,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)
@@ -1492,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
@@ -1520,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
@@ -1535,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
@@ -1557,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
@@ -1573,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
@@ -1588,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
@@ -1628,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)))
@@ -1655,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)))))))
@@ -1666,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)
@@ -1673,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
@@ -1694,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)))
@@ -1708,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)
@@ -1720,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,
@@ -1767,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
@@ -1791,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
@@ -1816,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.
@@ -1874,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
@@ -1890,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
@@ -1907,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)
@@ -1928,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*
@@ -1961,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*)
@@ -1970,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."
@@ -1979,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."
@@ -1987,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))
@@ -2034,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.
@@ -2086,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)
@@ -2172,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
@@ -2190,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
@@ -2214,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
@@ -2252,7 +2580,7 @@ one of the following values:
:young)
(t
:old))
- due))))
+ due age))))
(defun org-drill-progress-message (collected scanned)
@@ -2261,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
@@ -2296,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))
@@ -2327,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*))))
@@ -2405,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 ()
@@ -2438,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
@@ -2453,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))))
@@ -2465,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.
@@ -2478,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)
@@ -2499,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 =================================================
@@ -2530,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)
@@ -2565,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)
@@ -2658,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
@@ -2726,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
@@ -2915,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-effectiveness.el b/contrib/lisp/org-effectiveness.el
index a872cb2..a07084c 100644
--- a/contrib/lisp/org-effectiveness.el
+++ b/contrib/lisp/org-effectiveness.el
@@ -1,6 +1,6 @@
;;; org-effectiveness.el --- Measuring the personal effectiveness
-;; Copyright (C) 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2017 Free Software Foundation, Inc.
;; Author: David Arroyo Menéndez <davidam@es.gnu.org>
;; Keywords: effectiveness, plot
@@ -33,6 +33,23 @@
(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: ")
@@ -43,10 +60,10 @@
(defun org-effectiveness-count-todo()
"Print a message with the number of todo tasks in the current buffer"
(interactive)
- (save-excursion
+ (save-excursion
(goto-char (point-min))
(message "Number of TODO: %d" (count-matches "* TODO"))))
-
+
(defun org-effectiveness-count-done()
"Print a message with the number of done tasks in the current buffer"
(interactive)
@@ -61,6 +78,13 @@
(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)
@@ -73,25 +97,41 @@
(setq effectiveness (* 100 (/ done (+ done canc)))))
(message "Effectiveness: %f" effectiveness))))
+
(defun org-effectiveness-keywords-in-date(keyword date)
(interactive "sKeyword: \nsDate: " keyword date)
(setq count (count-matches (concat keyword ".*\n.*" date)))
(message (concat "%sS: %d" keyword count)))
-(defun org-effectiveness-dones-in-date(date)
- (interactive "sGive me a date: " date)
- (setq count (count-matches (concat "DONE.*\n.*" date)))
- (message "DONES: %d" count))
+(defun org-effectiveness-dones-in-date(date &optional notmessage)
+ (interactive "sGive me a date: " date)
+ (save-excursion
+ (goto-char (point-min))
+ (let ((count (count-matches (concat "DONE.*\n.*" date))))
+ (if (eq notmessage 1)
+ (message "%d" count)
+ (message "DONES: %d " count)))))
-(defun org-effectivenes-todos-in-date(date)
- (interactive "sGive me a date: " date)
- (setq count (count-matches (concat "TODO.*\n.*" date)))
- (message "TODOS: %d" count))
+(defun org-effectiveness-todos-in-date(date)
+ (interactive "sGive me a date: " date)
+ (save-excursion
+ (goto-char (point-min))
+ (setq count (count-matches (concat "TODO.*\n.*" date)))
+ (message "TODOS: %d" count)))
(defun org-effectiveness-canceled-in-date(date)
- (interactive "sGive me a date: " date)
- (setq count (count-matches (concat "CANCEL+ED.*\n.*" date)))
- (message "CANCELEDS: %d" count))
+ (interactive "sGive me a date: " date)
+ (save-excursion
+ (goto-char (point-min))
+ (setq count (count-matches (concat "CANCEL+ED.*\n.*" date)))
+ (message "CANCELEDS: %d" count)))
+
+(defun org-effectiveness-ntasks-in-date(date &optional notmessage)
+ (interactive "sGive me a date: " date)
+ (save-excursion
+ (goto-char (point-min))
+ (let ((tasks (float (count-matches (concat "^*.*\n.*" date)))))
+ (message "%d" tasks))))
(defun org-effectiveness-in-date(date &optional notmessage)
(interactive "sGive me a date: " date)
@@ -111,17 +151,17 @@
(concat "0" (number-to-string m))
(number-to-string m)))
-(defun org-effectiveness-plot(startdate enddate)
+(defun org-effectiveness-plot(startdate enddate &optional save)
(interactive "sGive me the start date: \nsGive me the end date: " startdate enddate)
(setq dates (org-effectiveness-check-dates startdate enddate))
- (setq syear (cadr (assoc 'startyear dates)))
- (setq smonth (cadr (assoc 'startmonth dates)))
- (setq eyear (cadr (assoc 'endyear dates)))
- (setq emonth (assoc 'endmonth dates))
+ (setq syear (cadr (assq 'startyear dates)))
+ (setq smonth (cadr (assq 'startmonth dates)))
+ (setq eyear (cadr (assq 'endyear dates)))
+ (setq emonth (assq 'endmonth dates))
;; Checking the format of the dates
- (if (not (string-match "[0-9][0-9][0-9][0-9]-[0-9][0-9]" startdate))
+ (if (not (string-match "[0-9][0-9][0-9][0-9]-[0-9][0-9]" startdate))
(message "The start date must have the next format YYYY-MM"))
- (if (not (string-match "[0-9][0-9][0-9][0-9]-[0-9][0-9]" enddate))
+ (if (not (string-match "[0-9][0-9][0-9][0-9]-[0-9][0-9]" enddate))
(message "The end date must have the next format YYYY-MM"))
;; Checking if startdate < enddate
(if (string-match "^[0-9][0-9][0-9][0-9]" startdate)
@@ -136,23 +176,33 @@
(message "The start date must be before that end date"))
(if (and (= startyear endyear) (> startmonth endmonth))
(message "The start date must be before that end date"))
-;; Create a file
+;; Create a file
(let ((month startmonth)
(year startyear)
(str ""))
- (while (and (>= endyear year) (>= endmonth month))
+ (while (or (> endyear year) (and (= endyear year) (>= endmonth month)))
(setq str (concat str (number-to-string year) "-" (org-effectiveness-month-to-string month) " " (org-effectiveness-in-date (concat (number-to-string year) "-" (org-effectiveness-month-to-string month)) 1) "\n"))
(if (= month 12)
- (progn
+ (progn
(setq year (+ 1 year))
(setq month 1))
(setq month (+ 1 month))))
(write-region str nil "/tmp/org-effectiveness"))
-;; Create the bar graph
+;; Create the bar graph
+ (if (eq save t)
+ (setq strplot "/usr/bin/gnuplot -e 'set term png; set output \"/tmp/org-effectiveness.png\"; plot \"/tmp/org-effectiveness\" using 2:xticlabels(1) with histograms' -p")
+ (setq strplot "/usr/bin/gnuplot -e 'plot \"/tmp/org-effectiveness\" using 2:xticlabels(1) with histograms' -p"))
(if (file-exists-p "/usr/bin/gnuplot")
- (call-process "/bin/bash" nil t nil "-c" "/usr/bin/gnuplot -e 'plot \"/tmp/org-effectiveness\" using 2:xticlabels(1) with histograms' -p")
+ (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: ")
@@ -180,12 +230,24 @@
(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))
+ (if (not (string-match "[0-9][0-9][0-9][0-9]-[0-9][0-9]" startdate))
(setq str "The start date must have the next format YYYY-MM"))
- (if (not (string-match "[0-9][0-9][0-9][0-9]-[0-9][0-9]" enddate))
+ (if (not (string-match "[0-9][0-9][0-9][0-9]-[0-9][0-9]" enddate))
(setq str "The end date must have the next format YYYY-MM"))
;; Checking if startdate < enddate
(if (string-match "^[0-9][0-9][0-9][0-9]" startdate)
@@ -208,21 +270,100 @@
(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))
- (setq syear (cadr (assoc 'startyear dates)))
- (setq smonth (cadr (assoc 'startmonth dates)))
- (setq eyear (cadr (assoc 'endyear dates)))
- (setq emonth (cadr (assoc 'endmonth dates)))
-;; (switch-to-buffer "*org-effectiveness*")
- (let ((month smonth)
- (year syear)
+ (let ((syear (cadr (assq 'startyear dates)))
+ (smonth (cadr (assq 'startmonth dates)))
+ (year (cadr (assq 'startyear dates)))
+ (month (cadr (assq 'startmonth dates)))
+ (emonth (cadr (assq 'endmonth dates)))
+ (eyear (cadr (assq 'endyear dates)))
+ (buffer (current-buffer))
(str ""))
- (while (and (>= eyear year) (>= emonth month))
- (org-effectiveness-ascii-bar (string-to-number (org-effectiveness-in-date (concat (number-to-string year) "-" (org-effectiveness-month-to-string month)) 1)) (format "%s-%s" year month))
- (if (= month 12)
- (progn
+ (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))))))
+ (setq month (+ 1 month)))))
+ (switch-to-buffer "*org-effectiveness*"))
-(provide 'org-effectiveness)
+(defun org-effectiveness-plot-ascii-ntasks (startdate enddate)
+ (interactive "sGive me the start date: \nsGive me the end date: " startdate enddate)
+ (setq dates (org-effectiveness-check-dates startdate enddate))
+ (let ((syear (cadr (assq 'startyear dates)))
+ (smonth (cadr (assq 'startmonth dates)))
+ (year (cadr (assq 'startyear dates)))
+ (month (cadr (assq 'startmonth dates)))
+ (emonth (cadr (assq 'endmonth dates)))
+ (eyear (cadr (assq 'endyear dates)))
+ (buffer (current-buffer))
+ (str ""))
+ (while (or (> eyear year) (and (= eyear year) (>= emonth month)))
+ (setq str (org-effectiveness-ntasks-in-date (concat (number-to-string year) "-" (org-effectiveness-month-to-string month)) 1))
+ (switch-to-buffer "*org-effectiveness*")
+ (org-effectiveness-ascii-bar (string-to-number str) (format "%s-%s" year month))
+ (switch-to-buffer buffer)
+ (if (eq month 12)
+ (progn
+ (setq year (+ 1 year))
+ (setq month 1))
+ (setq month (+ 1 month)))))
+ (switch-to-buffer "*org-effectiveness*"))
+
+(defun org-effectiveness-plot-ascii-dones (startdate enddate)
+ (interactive "sGive me the start date: \nsGive me the end date: " startdate enddate)
+ (setq dates (org-effectiveness-check-dates startdate enddate))
+ (let ((syear (cadr (assq 'startyear dates)))
+ (smonth (cadr (assq 'startmonth dates)))
+ (year (cadr (assq 'startyear dates)))
+ (month (cadr (assq 'startmonth dates)))
+ (emonth (cadr (assq 'endmonth dates)))
+ (eyear (cadr (assq 'endyear dates)))
+ (buffer (current-buffer))
+ (str ""))
+ (while (or (> eyear year) (and (= eyear year) (>= emonth month)))
+ (setq str (org-effectiveness-dones-in-date (concat (number-to-string year) "-" (org-effectiveness-month-to-string month)) 1))
+ (switch-to-buffer "*org-effectiveness*")
+ (org-effectiveness-ascii-bar (string-to-number str) (format "%s-%s" year month))
+ (switch-to-buffer buffer)
+ (if (eq month 12)
+ (progn
+ (setq year (+ 1 year))
+ (setq month 1))
+ (setq month (+ 1 month)))))
+ (switch-to-buffer "*org-effectiveness*"))
+
+
+(defun org-effectiveness-plot-html (startdate enddate)
+ "Print html bars about the effectiveness in a buffer"
+ (interactive "sGive me the start date: \nsGive me the end date: " startdate enddate)
+ (setq dates (org-effectiveness-check-dates startdate enddate))
+ (let ((syear (cadr (assq 'startyear dates)))
+ (smonth (cadr (assq 'startmonth dates)))
+ (year (cadr (assq 'startyear dates)))
+ (month (cadr (assq 'startmonth dates)))
+ (emonth (cadr (assq 'endmonth dates)))
+ (eyear (cadr (assq 'endyear dates)))
+ (buffer (current-buffer))
+ (str ""))
+ (switch-to-buffer "*org-effectiveness-html*")
+ (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..74dc69b
--- 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-2017 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 e0bc284..a089914 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-2013 Free Software Foundation, Inc.
+;; Copyright 2007-2017 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 34a2e99..57ac290 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-2013 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2017 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 6cd7f78..ecea46a 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-2013 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2017 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 363bebe..2b8c050 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-2013 Free Software Foundation, Inc.
+;; Copyright 2007-2017 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,7 +239,7 @@ If FORCE is non-nil, don't require confirmation from the user.
Otherwise rely on `org-expiry-confirm-flag' to decide."
(interactive "P")
(save-excursion
- (when (org-called-interactively-p) (org-reveal))
+ (when (called-interactively-p) (org-reveal))
(when (org-expiry-expired-p)
(org-back-to-heading)
(looking-at org-complex-heading-regexp)
@@ -252,7 +253,7 @@ Otherwise rely on `org-expiry-confirm-flag' to decide."
(not (interactive)))
(and org-expiry-confirm-flag
(y-or-n-p (format "Entry expired by %d days. Process? " d))))
- (funcall 'org-expiry-handler-function))
+ (funcall org-expiry-handler-function))
(delete-overlay ov)))))
(defun org-expiry-process-entries (beg end)
@@ -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-git-link.el b/contrib/lisp/org-git-link.el
index b9e6a4e..0028daf 100644
--- a/contrib/lisp/org-git-link.el
+++ b/contrib/lisp/org-git-link.el
@@ -1,6 +1,6 @@
;;; org-git-link.el --- Provide org links to specific file version
-;; Copyright (C) 2009-2013 Reimar Finken
+;; Copyright (C) 2009-2014 Reimar Finken
;; Author: Reimar Finken <reimar.finken@gmx.de>
;; Keywords: files, calendar, hypermedia
@@ -69,12 +69,12 @@
;; 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))
- (gitdir (first strlist))
- (object (second strlist)))
+ (gitdir (nth 0 strlist))
+ (object (nth 1 strlist)))
(org-git-open-file-internal gitdir object)))
@@ -92,16 +92,22 @@
(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))
+ (filepath (nth 0 strlist))
+ (commit (nth 1 strlist))
+ (line (nth 2 strlist))
(dirlist (org-git-find-gitdir (file-truename filepath)))
- (gitdir (first dirlist))
- (relpath (second dirlist)))
- (org-git-open-file-internal gitdir (concat commit ":" relpath))))
+ (gitdir (nth 0 dirlist))
+ (relpath (nth 1 dirlist)))
+ (org-git-open-file-internal gitdir (concat commit ":" relpath))
+ (when line
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (forward-line (1- (string-to-number line)))))))
;; Utility functions (file names etc)
@@ -120,37 +126,38 @@
the path. Example: (org-git-find-gitdir
\"~/gitrepos/foo/bar.txt\") returns
'(\"/home/user/gitrepos/.git\" \"foo/bar.txt\"). When not in a git repository, return nil."
- (let ((dir (file-name-directory path))
+ (let ((dir (expand-file-name (file-name-directory path)))
(relpath (file-name-nondirectory path)))
(catch 'toplevel
(while (not (file-exists-p (expand-file-name ".git" dir)))
(let ((dirlist (org-git-split-dirpath dir)))
- (when (string= (second dirlist) "") ; at top level
+ (when (string= (nth 1 dirlist) "") ; at top level
(throw 'toplevel nil))
- (setq dir (first dirlist)
- relpath (concat (file-name-as-directory (second dirlist)) relpath))))
+ (setq dir (nth 0 dirlist)
+ relpath (concat (file-name-as-directory (nth 1 dirlist)) relpath))))
(list (expand-file-name ".git" dir) relpath))))
(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 +175,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))))
+ (let* ((gitdir (nth 0 (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
index a670cd6..1d37060 100644
--- a/contrib/lisp/org-index.el
+++ b/contrib/lisp/org-index.el
@@ -1,1943 +1,3277 @@
-;;; org-index.el --- A personal index for org and beyond
-
-;; Copyright (C) 2011-2013 Free Software Foundation, Inc.
-
-;; Author: Marc Ihm <org-index@2484.de>
-;; Keywords: outlines, hypermedia, matching
-;; Requires: org
-;; Version: 2.3.2.1
-
-;; 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 org-locations and other points of interest
-;; easily; create and update a lookup table of references and links. When
-;; searching, frequently used entries appear at the the top and entering
-;; some keywords narrows down to matching entries only, so that the
-;; right one can be spotted 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 org. Links are normal org-mode links.
-;;
-;; Setup:
-;;
-;; - Add these lines to your .emacs:
-;;
-;; (require 'org-index)
-;;
-;; ;; Optionally assign a key. Pick your own.
-;; (global-set-key (kbd "C-+") 'org-index)
-;;
-;; - Invoke `org-index', which will assist you to create your
-;; index table.
-;;
-;; - Do not forget to restart emacs to make these lines effective.
-;;
-;;
-;; Further reading:
-;;
-;; See the documentation of `org-index', which can also be read
-;; by invoking `org-index' and and choosing the help-command.
-;;
-;; For more documentation and working examples, see:
-;;
-;; http://orgmode.org/worg/org-contrib/org-index.html
-;;
-
-;;; Change Log:
-
-;; [2013-10-04 Fr] Version 2.3.2:
-;; - Bugfix: index-table created by assistant is found after
-;; restart of emacs instead of invoking assistent again
-;;
-;; [2013-07-20 Sa] Version 2.3.0:
-;; - Renamed from "org-favtable" to "org-index"
-;; - Added an assistent to set up the index table
-;; - occur is now incremental, searching as you type
-;; - simplified the documentation and help-system
-;; - Saving keystrokes, as "+g237" is now valid input
-;; - Many bugfixes
-;;
-;; [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-index--preferred-command nil)
-
-(defvar org-index--commands
- '(occur head ref link leave enter goto help + reorder fill sort update highlight unhighlight missing statistics)
- "List of commands known to org-index.")
-
-(defvar org-index--commands-some '(occur head ref link leave enter goto help +))
-
-
-(defvar org-index--columns nil)
-
-(defcustom org-index-id nil
- "Id of the Org-mode node, which contains the index table."
- :group 'org
- :group 'org-index)
-
-
-(defvar org-index--text-to-yank nil)
-(defvar org-index--last-action nil)
-(defvar org-index--ref-regex nil)
-(defvar org-index--ref-format nil)
-(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--point-before nil "point in buffer with index table")
-
-
-(defun org-index (&optional ARG)
- "Mark and find your favorite things and org-locations easily:
-Create and update a lookup table of references and links. Often
-used entries bubble to the top; entering some keywords narrows
-down to matching entries only, so that the right one can be
-spotted 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 normal org-mode links.
-
-This is version 2.3.2 of org-index.
-
-The function `org-index' operates on a dedicated table, the index
-table, which lives within its own Org-mode node. The table and
-its node will be created, when you first invoke org-index.
-
-Each line in the index table contains:
-
- - A reference
-
- - A link
-
- - A number; counting, how often each reference has been
- used. This number is updated automatically and the table can
- be sorted after it, so that most frequently used references
- appear at the top of the table and can be spotted easily.
-
- - The creation date of the line.
-
- - Date and time of last access. This column can alternatively be
- used to sort the table.
-
- - A column for your own comments, which allows lines to be selected by
- keywords.
-
-The index table is found through the id of the containing
-node; this id is stored within `org-index-id'.
-
-
-The function `org-index' 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).
-
-Commands known:
-
- occur: Incremental search, that after each keystroke shows
- matching lines from index table. You may enter a list of words
- seperated by comma (\",\"), to select lines that contain all
- of the given words.
-
- If you supply a number (e.g. \"237\"): Apply emacs standard
- multi-occur operation on all org-mode buffers to search for
- this specific reference.
-
- You may also read the note at the end of this help on saving
- the keystroke RET with this frequent default command.
-
- head: If invoked outside the index table, ask for a
- reference number and search for a heading containing it. If
- invoked within index table 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 index table, fill in ref-column.
-
- link: Create a new line in index table 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
- index table.
-
- leave: Leave the index table. 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. If you invoke org-index with a prefix argument,
- this command \"leave\" is executed without further questions.
-
- enter: Just enter the node with the index table.
-
- goto: Search for a specific reference within the index table.
-
- help: Show this text.
-
- +: 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 index table, 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
- index table.
-
- 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 \"ref\" is able to reuse
- them.
-
- statistics : Show some statistics (e.g. minimum and maximum
- reference) about index table.
-
-
-
-Two ways to save keystrokes:
-
-When prompting for a command, org-index puts the most likely
-one (e.g. \"occur\" or \"ref\") in 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, to do an occur for the string
-\"foo\", you can just enter \"foo\" RET, without even typing
-\"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.
-
-"
-
- (interactive "P")
-
- (org-index-1 (if (equal ARG '(4)) 'leave nil) )
-)
-
-
-(defun org-index-1 (&optional what search search-is-link)
-"Do the actual worg for org-index; its optional arguments 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-index \"237\" 'head) ;; find heading with ref 237
-"
- (let (within-node ; True, if we are within node of the index table
- active-window-index ; active window with index table (if any)
- 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")
- trailing-digits ; any digits, that are are appended to what-input
- 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 index table
- 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 index table
- )
-
- ;;
- ;; Examine current buffer and location, before turning to index table
- ;;
-
- (unless (boundp 'org-index-id)
- (setq org-index-id nil)
- (org-index--create-new-index
- t
- (format "No index table has been created yet." org-index-id)))
-
- ;; Bail out, if new index has been created
- (catch 'created-new-index
-
- ;; 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-index-id))
-
-
- ;;
- ;; Get decoration of references and highest reference from index table
- ;;
-
-
- ;; Save initial ref or link
- (if (and within-node
- (org-at-table-p))
- (setq initial-ref-or-link
- (or (org-index--get-field 'ref)
- (org-index--get-field 'link))))
-
- ;; Find node
- (let ((marker (org-id-find org-index-id 'marker)) initial)
- (if marker
- (progn
- (setq org-index--buffer (marker-buffer marker)
- org-index--point (marker-position marker))
- (move-marker marker nil))
- (org-index--create-new-index
- t
- (format "Cannot find node with id \"%s\"" org-index-id))))
-
- ;; Check and remember, if active window contains buffer with index table
- (if (eq (window-buffer) org-index--buffer)
- (setq active-window-index (selected-window)))
-
- ;; Get configuration of index table; catch errors
- (let ((error-message
- (catch 'content-error
-
- (with-current-buffer org-index--buffer
- (unless org-index--point-before
- (setq org-index--point-before (point)))
-
- (unless (string= (org-id-get) org-index-id)
- (goto-char org-index--point))
-
- ;; parse table while still within buffer
- (setq parts (org-index--parse-and-adjust-table))
-
- ;; go back
- (goto-char org-index--point-before)
-
- nil))))
-
- (when error-message
- (org-pop-to-buffer-same-window org-index--buffer)
- (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-index--ref-regex ref-regex)
- (setq org-index--ref-format (concat head "%d" tail))
-
- ;;
- ;; Find out, what we are supposed to do
- ;;
-
- ;; Set preferred action, that will be the default choice
- (setq org-index--preferred-command
- (if within-node
- (if (memq org-index--last-action '(ref link))
- 'leave
- 'goto)
- (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-index--commands-some))
- (while (let (completions starts-with-plus is-only-plus)
-
- (setq what-input
- (org-completing-read
- "Please choose: "
- (mapcar 'symbol-name
- ;; Construct unique list of commands with
- ;; preferred one at front
- (delq nil (delete-dups
- (append
- (list org-index--preferred-command)
- (copy-list commands)))))
- nil nil))
-
- ;; 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)
- ;; remember digits
- (setq trailing-digits (string-to-number (match-string 2 what-input)))
- ;; and use non-digits-part to find match
- (setq what-input (match-string 1 what-input)))
-
- ;; 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-index--commands))
- (setq what-input (substring what-input 1))
- (setq starts-with-plus (> (length what-input) 0))
- (setq is-only-plus (not starts-with-plus)))
-
- ;; get list of possible completions for what-input; i.e.
- ;; all commands, that start with what-input
- (setq completions (delq nil (mapcar
- (lambda (x)
- (let ((where (search what-input (symbol-name x))))
- (if (and where
- (= where 0))
- x
- nil))) commands)))
-
- ;; if input starts with "+" and not just "+"
- (when starts-with-plus
- ;; use first completion, if unambigously
- (if (= (length completions) 1)
- (setq what-input (symbol-name (car completions)))
- (if completions
- (error "Input \"+%s\" matches multiple commands: %s"
- what-input
- (mapconcat 'symbol-name completions ", "))
- (error "Input \"+%s\" matches no commands" what-input))))
-
- ;; if input ends in digits, use first completion, even if ambigous
- ;; this allows input like "h224" to be accepted
- (when (and trailing-digits completions)
- ;; use first match as input, even if ambigously
- (setq org-index--preferred-command (first completions))
- (setq what-input (number-to-string trailing-digits)))
-
- ;; convert to symbol
- (setq what (intern what-input))
- (if is-only-plus (setq what '+))
-
- ;; 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-index--preferred-command
- (first commands)))
- ;; remove any trailing dot, that user might have added to
- ;; disambiguate his input
- (if (and (> (length what-input) 0)
- (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 index table 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 link or ref columns of table
- (when within-node
- (setq search-from-table (org-index--get-field 'link))
- (if search-from-table
- (setq search-is-link t)
- (setq search-from-table (org-index--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
- (unless (eq what 'occur)
-
- (if what-input
- (setq search what-input)
- (setq search (read-from-minibuffer
- (cond ((eq what '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
- (when search
- (setq search (org-trim search))
- (if (string= search "") (setq search nil))
- (when search
- (if (string-match "^[0-9]+$" search)
- (setq search (concat head search tail)))
- (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-index--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 head)))
- (setq what 'enter)
- (setq what-adjusted t))
-
- ;; For a proper reference as input, we do multi-occur
- (if (and search
- (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)
- (let ((org-id-link-to-org-use-id t))
- (setq link-id (org-id-get-create))))
-
- ;; Move into table, if outside
-
- ;; These commands enter index table only temporarily
- (when (memq what '(occur multi-occur statistics))
-
- ;; Switch to index table
- (set-buffer org-index--buffer)
- (goto-char org-index--point)
-
- ;; sort index table
- (org-index--sort-table reorder-once))
-
- ;; These commands will leave user in index table after they are finished
- (when (memq what '(enter ref link goto missing))
-
- ;; Support orgmode-standard of going back (buffer and position)
- (org-mark-ring-push)
-
- ;; Switch to index table
- (org-pop-to-buffer-same-window org-index--buffer)
- (goto-char org-index--point)
- (show-subtree)
- (org-show-context)
- (setq org-index--point-before nil) ;; dont want to go back
-
- ;; sort index table
- (org-index--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-index--get-field 'ref))
- (string= initial-ref-or-link (org-index--get-field 'link)))))
- (forward-line))
- ;; did not find ref, go back to top
- (if (not (org-at-table-p)) (goto-char org-index--point)))
-
-
- ;;
- ;; Actually do, what is requested
- ;;
-
- (cond
-
-
- ((eq what 'help)
-
- ;; bring up help-buffer for this function
- (describe-function 'org-index))
-
-
- ((eq what 'multi-occur)
-
- ;; Conveniently position cursor on number to search for
- (goto-char org-index--below-hline)
- (let (found (initial (point)))
- (while (and (not found)
- (forward-line)
- (org-at-table-p))
- (save-excursion
- (setq found (string= search
- (org-index--get-field 'ref)))))
- (if found
- (org-index--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))
- (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-index--get-field 'link))))
-
- ;; use link if available
- (if (and link
- (not (string= link "")))
- (progn
- (org-index--update-line search)
- (org-id-goto link)
- (org-reveal)
- (if (eq (current-buffer) org-index--buffer)
- (setq org-index--point-before nil))
- (setq message-text "Followed link"))
-
- (message (format "Scanning headlines for '%s' ..." search))
- (org-index--update-line 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))
- ;; If this is not an inlinetask ...
- (when (< (org-element-property :level (org-element-at-point))
- org-inlinetask-min-level)
- ;; ... remember location and bail out
- (setq buffer (current-buffer))
- (setq point (point))
- (throw 'found t))))
- nil 'agenda)
- nil))
-
- (progn
- (if (eq buffer org-index--buffer)
- (setq org-index--point-before nil))
- (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)
-
- (setq kill-new-text org-index--text-to-yank)
- (setq org-index--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-index--last-action 'leave)
- (let ((this-command nil) (last-command nil))
- (org-mark-ring-goto 1))
- (org-mark-ring-goto)))
-
-
- ((eq what 'goto)
-
- ;; Go downward in table to requested reference
- (let (found (initial (point)))
- (goto-char org-index--below-hline)
- (while (and (not found)
- (forward-line)
- (org-at-table-p))
- (save-excursion
- (setq found
- (string= search
- (org-index--get-field
- (if search-is-link 'link 'ref))))))
- (if found
- (progn
- (setq message-text (format "Found '%s'" search))
- (org-index--update-line nil)
- (org-table-goto-column (org-index--column-num 'ref))
- (if (looking-back " ") (backward-char))
- ;; remember string to copy
- (setq org-index--text-to-yank
- (org-trim (org-table-get-field (org-index--column-num 'copy)))))
- (setq message-text (format "Did not find '%s'" search))
- (goto-char initial)
- (forward-line)
- (setq what 'missed))))
-
-
- ((eq what 'occur)
-
- (org-index--do-occur what-input))
-
-
- ((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
- (goto-char org-index--below-hline)
- ;; go through table
- (while (and (org-at-table-p)
- (not new))
- (when (string=
- (org-index--get-field 'count)
- ":reuse:")
- (setq new (org-index--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-index--text-to-yank new))
-
- ;; insert ref or link as very first row
- (goto-char org-index--below-hline)
- (org-table-insert-row)
-
- ;; fill special columns with standard values
- (when (eq what 'ref)
- (org-table-goto-column (org-index--column-num 'ref))
- (insert new))
- (when (eq what 'link)
- (org-table-goto-column (org-index--column-num 'link))
- (insert link-id))
- (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")
-
- ;; goto copy-field or first empty one
- (if (org-index--column-num 'copy)
- (org-table-goto-column (org-index--column-num 'copy))
- (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
- (goto-char org-index--below-hline)
- (show-subtree)
- (recenter)
- (if what-adjusted
- (setq message-text "Nothing to search for; at index table")
- (setq message-text "At index table")))
-
-
- ((eq what 'fill)
-
- ;; check, if within index table
- (unless (and within-node
- (org-at-table-p))
- (error "Not within index table"))
-
- ;; applies to missing refs and missing links alike
- (let ((ref (org-index--get-field 'ref))
- (link (org-index--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-index--get-field 'ref kill-new-text)
- ;; remember for org-mark-ring-goto
- (setq org-index--text-to-yank kill-new-text)
- (org-id-goto link)
- (setq message-text "Filled field of index table with new reference"))
-
- ;; fill in new link
- (if (not link)
- (progn
- (setq guarded-search (org-index--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-index--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-index--make-guarded-search ref-regex 'dont-quote)))
- (string-to-number (match-string 1))
- 0))))
- (highlight-regexp ref-regex 'isearch)
- (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 index table
- (save-excursion
- (let ((ref-or-link (if search-is-link "link" "reference")))
- (beginning-of-line)
- (if (org-index--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 index table, 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 'isearch)
- (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))
-
- (goto-char org-index--below-hline)
- (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-index--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-index--ref-format min)
- (format org-index--ref-format max)
- (length missing)))
-
- (if (y-or-n-p (format "Found %d missing references; do you wish to append them to the index table"
- (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-index--get-field 'ref x)
- (org-index--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)))
-
-
- ;; restore point in buffer or window with index table
- (if org-index--point-before
- ;; buffer displayed in window need to set point there first
- (if (eq (window-buffer active-window-index)
- org-index--buffer)
- (set-window-point active-window-index org-index--point-before)
- ;; set position in buffer in any case and second
- (with-current-buffer org-index--buffer
- (goto-char org-index--point-before)
- (setq org-index--point-before nil))))
-
-
- ;; remember what we have done for next time
- (setq org-index--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-index--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-index--go-below-hline)
- (setq org-index--below-hline (point))
- (setq top (point))
-
- ;; 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-index--create-new-index
- nil
- "Index table starts with a hline"))
-
- ;; 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-index--columns (org-index--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-index--get-field 'ref))
- (not (org-index--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-index--get-field 'ref))))
- (forward-line))
-
- ;; Some Checking
- (unless ref-field
- (org-index--create-new-index
- nil
- "Reference column is empty"))
-
- (unless (string-match "^\\([^0-9]*\\)\\([0-9]+\\)\\([^0-9]*\\)$" ref-field)
- (org-index--create-new-index
- nil
- (format "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 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-index--get-field 'ref))
- (setq link-field (org-index--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-index--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-index--sort-table (sort-column)
-
- (unless sort-column (setq sort-column (org-index--column-num 'sort)))
-
- (let (top
- bottom
- ref-field
- count-field
- count-special)
-
-
- ;; get boundaries of table
- (goto-char org-index--below-hline)
- (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-index--get-field 'ref) ""))
- (count-field (or (org-index--get-field 'count) ""))
- (count-special 0))
-
- ;; get reference with leading zeroes, so it can be
- ;; sorted as text
- (string-match org-index--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-index--get-field 'count)
- "")))
- ref))
-
- ((eq sort-column 'last-accessed)
- (concat count-special
- (org-index--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-index--go-below-hline ()
-
- ;; 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-index--create-new-index
- t
- (format "Cannot find index table within node %s" org-index-id)))
-
- ;; 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-index--create-new-index
- nil
- "Cannot find hline within index table"))
-
- (forward-line 1)
- (org-table-goto-column 1))
-
-
-
-(defun org-index--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-index--create-new-index
- nil
- (format "More than one heading is marked with flag '%c'" (car x))))))
- '((?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-index--create-new-index
- nil
- (format "'%s' appears two times as column heading" (downcase field))))
- (setcdr found (+ col 1)))))
-
- ;; check if all necessary informations have been specified
- (mapc (lambda (col)
- (unless (> (cdr (assoc col columns)) 0)
- (org-index--create-new-index
- nil
- (format "column '%s' has not been set" col))))
- '(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-index--create-new-index (create-new-index reason)
- "Create a new empty index table with detailed explanation."
- (let (prompt buffer-name title firstref id)
-
- (setq prompt
- (if create-new-index
- (concat "There is this problem with the existing index table:\n\n " reason "\n\nThis assistant will guide you to create a new one.\n\nDo you want to proceed ?")
- (concat "The existing index table contains this error:\n\n " reason "\n\nYou need to correct this error manually before proceeding. However, this assistant will help you to create an new initial index table with detailed comments, so that you may fix the errors in your existing table more easily.\n\nDo you want to proceed ?")))
-
- (unless (y-or-n-p prompt)
- (message "Cannot proceed without a valid index table: %s" reason)
- ;; show existing index
- (when (and org-index--buffer
- org-index--point)
- (org-pop-to-buffer-same-window org-index--buffer)
- (goto-char org-index--point)
- (org-show-context)
- (show-subtree)
- (recenter 1)
- (delete-other-windows))
- (throw 'created-new-index nil))
-
- (setq buffer-name (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)) nil nil))
-
- (setq title (read-from-minibuffer "Please enter the title of the index node: "))
-
- (while (progn
- (setq firstref (read-from-minibuffer "Please enter your first reference-number. This is a number preceeded by some non-digit chars and optionally followed by some more non-digit chars, e.g. 'R1', '-1-' or '#1#' (and your initial number does not need to be '1'). The format of your reference-numbers only needs to make sense for yourself, so that you can spot it easily in your texts or write it on a piece of paper; it should however not already appear to frequently within your existing notes, to avoid too many false hits when searching.\n\nPlease choose: "))
- (if (string-match "^[^0-9]+[0-9]+[^0-9]*$" firstref)
- nil
- (let (desc)
- ;; 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")))
- (read-from-minibuffer (format "Your input '%s' does not meet the requirements because it %s. Please hit RET and try again " firstref desc)))
- t)))
-
- (with-current-buffer buffer-name
- (goto-char (point-max))
- (insert (format "\n\n* %s %s\n" firstref title))
- (insert "\n\n Below you find your initial index table, which will grow over time.\n"
- " Following that your may read its detailed explanation, which will help you,\n"
- " to adopt org-index to your needs. This however is optional reading and not\n"
- " required to start using org-index.\n\n")
-
- (setq id (org-id-get-create))
- (insert (format "
-
- | | | | | | comment |
- | ref | link | created | count;s | last-accessed | ;c |
- | | <4> | | | | |
- |-----+------+---------+---------+---------------+---------|
- | %s | %s | %s | | | %s |
-
-"
- firstref
- id
- (with-temp-buffer (org-insert-time-stamp nil nil t))
- "This node"))
-
-
- (insert "
-
- Detailed explanation:
-
-
- The index table above has three lines of headings above the first
- hline:
-
- - The first one is ignored by org-index, and you can use it to
- give meaningful names to columns. In the table above only one
- column has a name (\"comment\"). This line is optional.
-
- - The second line is the most important one, because it
- contains the configuration information for org-index; please
- read further below for its format.
-
- - The third line is again optional; it may only specify the
- widths of the individual columns (e.g. <4>).
-
- The columns get their meaning by the second line of headings;
- specifically by one of the keywords (e.g. \"ref\") or a flag
- seperated by a semicolon (e.g. \";s\").
-
-
-
- The keywords and flags are:
-
-
- - ref: This contains the reference, which consists of a decorated
- number, which is incremented for each new line. References are
- meant to be used in org-mode headlines or outside of org´,
- e.g. within folder names.
-
- - link: org-mode link pointing to the matching location within org.
-
- - created: When has this line been created ?
-
- - count: How many times has this line accessed ? The trailing
- flag \"s\" makes the table beeing sorted after
- this column, so that often used entries appear at the top of
- the table.
-
- - last-accessed: When has this line ben accessed
-
- - The last column above has no keyword, only the flag \"c\",
- which makes its content beeing copied under certain
- conditions. It is typically used for comments.
-
- The sequence of columns does not matter. You may reorder them any
- way you like. Columns are found by their name, which appears in
- the second line of headings.
-
- You can add further columns or even remove the last column. All
- other columns are required.
-
-
- Finally: This node needs not be a top level node; its name is
- completely at you choice; it is found through its ID only.
-
-")
-
-
- (while (not (org-at-table-p)) (forward-line -1))
- (org-table-align)
- (while (not (org-at-heading-p)) (forward-line -1))
-
- ;; present results to user
- (if (and (not create-new-index)
- org-index--buffer
- org-index--point)
-
- ;; we had an error with the existing table, so present old and new one
- (progn
- ;; show existing index
- (org-pop-to-buffer-same-window org-index--buffer)
- (goto-char org-index--point)
- (org-show-context)
- (show-subtree)
- (recenter 1)
- (delete-other-windows)
- ;; show new index
- (select-window (split-window-vertically))
- (org-pop-to-buffer-same-window buffer-name)
- (org-id-goto id)
- (org-show-context)
- (show-subtree)
- (recenter 1)
- (message "Please compare your existing index (upper window) and a temporary new one (lower window) to correct the previous error (\"%s\"); the explanations following the new index table should help." reason))
-
- ;; Only show the new index
- (org-pop-to-buffer-same-window buffer-name)
- (delete-other-windows)
- (org-id-goto id)
- (org-show-context)
- (show-subtree)
- (recenter 1)
- (setq org-index-id id)
- (if (y-or-n-p "This is your new index table; Do you want to save its id to make it permanent ? ")
- (progn
- (customize-save-variable 'org-index-id id)
- (message "Saved org-index-id '%s' to %s" org-index-id custom-file))
- (let (sq)
- (setq sq (format "(setq org-index-id \"%s\")" org-index-id))
- (kill-new sq)
- (message "Did not make the id of the new index permamanent; you may want to put\n\n %s\n\ninto your own initialization; it is copied already, just yank it." sq)))))
- ;; cannot handle this situation in higher code, but do not want to finish with an error
- (throw 'created-new-index nil)))
-
-
-
-
-(defun org-index--update-line (ref-or-link)
-
- (let (initial
- found
- count-field)
-
- (with-current-buffer org-index--buffer
-
- ;; search reference or link, if given (or assume, that we are already positioned right)
- (when ref-or-link
- (setq initial (point))
- (goto-char org-index--below-hline)
- (while (and (org-at-table-p)
- (not (or (string= ref-or-link (org-index--get-field 'ref))
- (string= ref-or-link (org-index--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-index--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-index--get-field 'count
- (number-to-string
- (+ 1 (string-to-number (or count-field "0"))))))
-
- ;; update timestamp
- (org-table-goto-column (org-index--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-index--get-field (key &optional value)
- (let (field)
- (setq field (org-trim (org-table-get-field (cdr (assoc key org-index--columns)) value)))
- (if (string= field "") (setq field nil))
-
- field))
-
-
-(defun org-index--column-num (key)
- (cdr (assoc key org-index--columns)))
-
-
-(defun org-index--make-guarded-search (ref &optional dont-quote)
- (concat "\\b" (if dont-quote ref (regexp-quote ref)) "\\b"))
-
-
-(defun org-index-get-ref-regex-format ()
- "return cons-cell with regular expression and format for references"
- (unless org-index--ref-regex
- (org-index-1 'parse))
- (cons (org-index--make-guarded-search org-index--ref-regex 'dont-quote) org-index--ref-format))
-
-
-(defun org-index--do-occur (initial-search)
- (let (
- (occur-buffer-name "*org-index-occur*")
- (word "") ; last word to search for growing and shrinking on keystrokes
- (prompt "Search for: ")
- words ; list of other words that must match too
- occur-buffer
- lines-to-show ; number of lines to show in window
- start-of-lines ; position, where lines begin
- left-off-at ; stack of last positions in index table
- after-inserted ; in occur-buffer
- lines-visible ; in occur-buffer
- below-hline-bol ; below-hline and at bol
- exit-gracefully ; true if normal exit
- in-c-backspace ; true while processing C-backspace
- ret from to key)
-
- ;; clear buffer
- (if (get-buffer "*org-index-occur*")
- (kill-buffer occur-buffer-name))
- (setq occur-buffer (get-buffer-create "*org-index-occur*"))
-
- (with-current-buffer org-index--buffer
- (let ((initial (point)))
- (goto-char org-index--below-hline)
- (forward-line 0)
- (setq below-hline-bol (point))
- (goto-char initial)))
-
- (org-pop-to-buffer-same-window occur-buffer)
- (toggle-truncate-lines 1)
-
- (unwind-protect ; to reset cursor-shape even in case of errors
- (progn
-
- ;; fill in header
- (erase-buffer)
- (insert (concat "Incremental search, showing one window of matches.\n"
- "Use DEL and C-DEL to erase, cursor keys to move, RET to find heading.\n\n"))
- (setq start-of-lines (point))
- (setq cursor-type 'hollow)
-
- ;; get window size of occur-buffer as number of lines to be searched
- (setq lines-to-show (+ (- (window-body-height) (line-number-at-pos)) 1))
-
-
- ;; fill initially
- (setq ret (org-index--get-matching-lines nil lines-to-show below-hline-bol))
- (when (car ret)
- (insert (cdr ret))
- (setq left-off-at (cons (car ret) nil))
- (setq after-inserted (cons (point) nil)))
-
- ;; read keys
- (while
- (progn
- (goto-char start-of-lines)
- (setq lines-visible 0)
-
- ;; use initial-search (if present) to simulate keyboard input
- (if (and initial-search
- (> (length initial-search) 0))
- (progn
- (setq key (string-to-char (substring initial-search 0 1)))
- (if (length initial-search)
- (setq initial-search (substring initial-search 1))))
- (if in-c-backspace
- (setq key 'backspace)
- (setq key (read-event
- (format "%s %s"
- prompt
- (mapconcat 'identity (reverse (cons word words)) ","))))
-
- (setq exit-gracefully (memq key (list 'return 'up 'down 'left 'right)))))
-
- (not exit-gracefully))
-
- (cond
-
- ((eq key 'C-backspace)
-
- (setq in-c-backspace t))
-
- ((eq key 'backspace) ; erase last char
-
- (if (= (length word) 0)
-
- ;; nothing more to delete
- (setq in-c-backspace nil)
-
- ;; unhighlight longer match
- (let ((case-fold-search t))
- (unhighlight-regexp (regexp-quote word)))
-
- ;; chars 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))
-
- ;; remove everything, that has been added for char just deleted
- (when (cdr after-inserted)
- (setq after-inserted (cdr after-inserted))
- (goto-char (car after-inserted))
- (delete-region (point) (point-max)))
-
- ;; back up last position in index table too
- (when (cdr left-off-at)
- (setq left-off-at (cdr left-off-at)))
-
- ;; go through buffer and check, if any invisible line should now be shown
- (goto-char start-of-lines)
- (while (< (point) (point-max))
- (if (outline-invisible-p)
- (progn
- (setq from (line-beginning-position)
- to (line-beginning-position 2))
-
- ;; check for matches
- (when (org-index--test-words (cons word words) (buffer-substring from to))
- (when (<= lines-visible lines-to-show) ; show, if more lines required
- (outline-flag-region from to nil)
- (incf lines-visible))))
-
- ;; already visible, just count
- (incf lines-visible))
-
- (forward-line 1))
-
- ;; highlight shorter word
- (unless (= (length word) 0)
- (let ((case-fold-search t))
- (highlight-regexp (regexp-quote word) 'isearch)))))
-
-
- ((eq key ?,) ; comma: enter an additional search word
-
- ;; push current word and clear, no need to change display
- (setq words (cons word words))
- (setq word ""))
-
-
- ((and (characterp key)
- (aref printable-chars key)) ; any other char: add to current search word
-
-
- ;; unhighlight short word
- (unless (= (length word) 0)
- (let ((case-fold-search t))
- (unhighlight-regexp (regexp-quote word))))
-
- ;; add to word
- (setq word (concat word (downcase (string key))))
-
- ;; hide lines, that do not match longer word any more
- (while (< (point) (point-max))
- (unless (outline-invisible-p)
- (setq from (line-beginning-position)
- to (line-beginning-position 2))
-
- ;; check for matches
- (if (org-index--test-words (list word) (buffer-substring from to))
- (incf lines-visible) ; count as visible
- (outline-flag-region from to t))) ; hide
-
- (forward-line 1))
-
- ;; duplicate top of stacks; eventually overwritten below
- (setq left-off-at (cons (car left-off-at) left-off-at))
- (setq after-inserted (cons (car after-inserted) after-inserted))
-
- ;; get new lines from index table
- (when (< lines-visible lines-to-show)
- (setq ret (org-index--get-matching-lines (cons word words)
- (- lines-to-show lines-visible)
- (car left-off-at)))
-
- (when (car ret)
- (insert (cdr ret))
- (setcar left-off-at (car ret))
- (setcar after-inserted (point))))
-
- ;; highlight longer word
- (let ((case-fold-search t))
- (highlight-regexp (regexp-quote word) 'isearch)))))
-
- ;; search is done collect and brush up results
- ;; remove any lines, that are still invisible
- (goto-char start-of-lines)
- (while (< (point) (point-max))
- (if (outline-invisible-p)
- (delete-region (line-beginning-position) (line-beginning-position 2))
- (forward-line 1)))
-
- ;; get all the rest
- (message "Getting all matches ...")
- (setq ret (org-index--get-matching-lines (cons word words) 0 (car left-off-at)))
- (message "done.")
- (insert (cdr ret)))
-
- ;; postprocessing even for non graceful exit
- (setq cursor-type t)
- ;; replace previous heading
- (let ((numlines (count-lines (point) start-of-lines)))
- (goto-char start-of-lines)
- (forward-line -1)
- (delete-region (point-min) (point))
- (insert (format (concat (if exit-gracefully
- "Search is done; showing all %d matches.\n"
- "Search aborted; showing only some matches.\n")
- "Use cursor keys to move, press RET to find heading.\n")
- numlines)))
- (forward-line))
-
- ;; install keyboard-shortcuts within occur-buffer
- (let ((keymap (make-sparse-keymap))
- fun-on-ret)
- (set-keymap-parent keymap text-mode-map)
-
- (setq fun-on-ret (lambda () (interactive)
- (let ((ref (org-index--get-field 'ref))
- (link (org-index--get-field 'link)))
- (org-index-1 'head
- (or link ref) ;; prefer link
- (if link t nil)))))
-
- (define-key keymap (kbd "RET") fun-on-ret)
- (use-local-map keymap)
-
- ;; perform action according to last char
- (cond
- ((eq key 'return)
- (funcall fun-on-ret))
-
- ((eq key 'up)
- (forward-line -1))
-
- ((eq key 'down)
- (forward-line 1))
-
- ((eq key 'left)
- (forward-char -1))
-
- ((eq key 'right)
- (forward-char 1))))))
-
-
-(defun org-index--get-matching-lines (words numlines start-from)
- (let ((numfound 0)
- pos
- initial line lines)
-
- (with-current-buffer org-index--buffer
-
- ;; remember initial pos and start at requested
- (setq initial (point))
- (goto-char start-from)
-
- ;; loop over buffer until we have found enough lines
- (while (and (or (< numfound numlines)
- (= numlines 0))
- (org-at-table-p))
-
- ;; check each word
- (setq line (buffer-substring (line-beginning-position) (line-beginning-position 2)))
- (when (org-index--test-words words line)
- (setq lines (concat lines line))
- (incf numfound))
- (forward-line 1)
- (setq pos (point)))
-
- ;; return to initial position
- (goto-char initial))
-
- (unless lines (setq lines ""))
- (cons pos lines)))
-
-
-(defun org-index--test-words (words line)
- (let ((found-all t))
- (setq line (downcase line))
- (catch 'not-found
- (dolist (w words)
- (or (search w line)
- (throw 'not-found nil)))
- t)))
-
-
-(defadvice org-mark-ring-goto (after org-index--advice-text-to-yank activate)
- "Make text from org-index available for yank."
- (when org-index--text-to-yank
- (kill-new org-index--text-to-yank)
- (message (format "Ready to yank '%s'" org-index--text-to-yank))
- (setq org-index--text-to-yank nil)))
-
-
-(provide 'org-index)
-
-;; Local Variables:
-;; fill-column: 75
-;; comment-column: 50
-;; End:
-
-;;; org-index.el ends here
+;;; org-index.el --- A personal adaptive index for org -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2011-2017 Free Software Foundation, Inc.
+
+;; Author: Marc Ihm <org-index@2484.de>
+;; Version: 5.6.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 of your load-path,
+;; e.g. org-mode/contrib/lisp.
+;; - Add these lines to your .emacs:
+;;
+;; (require 'org-index)
+;;
+;; - Restart your Emacs to make this effective.
+;; - Invoke `org-index'; on first run it will assist in creating your
+;; index table.
+;;
+;; - Optionally invoke `M-x org-customize', group 'Org Index', to tune
+;; some settings, e.g. the global prefix key 'C-c i'.
+;;
+;;
+;; 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:
+
+;;
+;; - See the command 'news' for recent changes, or
+;; - https://github.com/marcIhm/org-index/ChangeLog.org for older news
+;; - https://github.com/marcIhm/org-index/commits/master for a complete list of changes
+;;
+;;
+
+;;; Code:
+
+(require 'org-table)
+(require 'org-id)
+(require 'cl-lib)
+(require 'widget)
+
+;; Version of this package
+(defvar org-index-version "5.6.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-dispatch-key "i"
+ "Key to invoke ‘org-index-dispatch’, which is the central entry function for ‘org-index’."
+ :group 'org-index
+ :initialize 'custom-initialize-set
+ :set (lambda (var val)
+ (set-default var val)
+ (global-set-key org-index-dispatch-key 'org-index-dispatch))
+ :type 'key-sequence)
+
+(defcustom org-index-idle-delay 68
+ "Delay in seconds after which buffer will sorted or fontified when Emacs is idle."
+ :group 'org-index
+ :type 'integer)
+
+(defcustom org-index-prepare-when-idle nil
+ "Fontify and sort index-table when idle to make first call faster.
+You only need this if your index has grown so large, that first
+invocation of `org-index' needs a noticable amount of time."
+ :group 'org-index
+ :initialize 'custom-initialize-set
+ :set (lambda (var val)
+ (set-default var val)
+ (when val
+ (setq org-index--align-interactive 200)
+ (run-with-idle-timer org-index-idle-delay nil 'org-index--idle-prepare)))
+ :type 'boolean)
+
+(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-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 '(keywords yank)
+ "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))))
+
+(defcustom org-index-clock-into-focus nil
+ "Clock into focused node."
+ :group 'org-index
+ :type 'boolean)
+
+;; Variables to hold the configuration of the index table
+(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.")
+(defvar org-index--ids-focused-nodes nil "Ids of focused node (if any).")
+(defvar org-index--id-last-goto-focus nil "Id of last node, that has been focused to.")
+
+;; 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-assumed nil "Last column, the index has been sorted after (best guess).")
+(defvar org-index--sort-timer nil "Timer to sort index in correct order.")
+(defvar org-index--inhibit-sort-idle nil "If set, index will not be sorted in idle background.")
+(defvar org-index--aligned 0 "For this Emacs session: remember number of table lines aligned.")
+(defvar org-index--align-interactive most-positive-fixnum "Number of rows to align in ‘org-index--parse-table’.")
+(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--news-buffer-name "*org-index news*" "Name of buffer to display news.")
+(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--prefix-arg nil "True, if prefix argument has been received during input.")
+(defvar org-index--minibuffer-saved-key nil "Temporarily save entry of minibuffer keymap.")
+(defvar org-index--after-focus-timer nil "Timer to clock in or update focused node after a delay.")
+(defvar org-index--after-focus-context nil "Context for after focus action.")
+(defvar org-index--this-command nil "Subcommand, that is currently excecuted.")
+(defvar org-index--last-command nil "Subcommand, that hast been excecuted last.")
+
+;; static information for this program package
+(defconst org-index--commands '(occur add kill head ping index ref yank column edit help short-help news focus 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.")
+(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.")
+(defvar org-index--after-focus-delay 10 "Number of seconds to wait before invoking after-focus action.")
+
+
+(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"))
+ (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.
+
+This function 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 by means of an incremental occur; results
+are sorted by usage count and date, so that frequently used
+entries appear first.
+
+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 this function 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.6.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 `\\[org-index-dispatch] 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. With a numeric
+ prefix argument, show lines, which have been accessed at
+ most this many days ago.
+
+ 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.
+
+ focus: [f] Return to first focused node; repeat to see them all.
+ The focused nodes are kept in a short list; they need not be
+ part of the index though. This command visits one focus node
+ after the other, as long as you invoke it in quick succession
+ and without moving to other nodes; otherwise it returns to
+ the focus node, where you left off. Finally, with a prefix
+ argument, this command offers more options, e.g. to set focus
+ in the first place.
+
+ help: Show complete help text of `org-index'.
+ I.e. this text.
+
+ short-help: [?] Show this one-line description of each subcommand.
+ I.e. from the complete help, show only the first line for each
+ subcommand.
+
+ news: [n] Show news for the current point release.
+
+ 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'.
+
+This includes the global key `org-index-dispatch-key' to invoke
+the most important subcommands with one additional key.
+
+A numeric prefix argument is used as a reference number for
+commands, that need one (e.g. 'head') or to modify their
+behaviour (e.g. 'occur').
+
+Also, a single prefix argument may be specified just before the
+final character (e.g. like `C-c i C-u f') or by just typing an
+upper case letter (e.g. `C-c i F').
+
+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 org-index--align-interactive t)
+
+ ;; 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-assumed (setq org-index--last-sort-assumed 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-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))
+ (if org-index--prefix-arg (setq arg (or arg '(4))))
+ (setq org-index--display-short-help nil))
+
+ (setq org-index--last-command org-index--this-command)
+ (setq org-index--this-command command)
+
+
+ ;;
+ ;; 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 (cl-first r))
+ (setq search-id (cl-second r))
+ (setq search-fingerprint (cl-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 focus))
+ (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 'short-help)
+
+ (org-index--display-short-help))
+
+
+ ((eq command 'news)
+ (with-current-buffer-window
+ org-index--news-buffer-name nil nil
+ (insert (format "News for Version %s of org-index:\n"
+ (progn
+ (string-match "\\([0-9]+\\.[0-9]+\\)\\." org-index-version)
+ (match-string 1 org-index-version))))
+ (insert "
+ - Quick repeat with delete-option for goto-focus
+ - Moved Changelog to its own file
+ - New command 'news'
+ - Bugfixes
+")
+ (insert "\nSee https://github.com/marcIhm/org-index/ChangeLog.org for older news.\n")
+ (org-mode))
+ (shrink-window-if-larger-than-buffer (get-buffer-window org-index--news-buffer-name)))
+
+
+ ((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 done)
+
+ (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 done)
+ (if id
+ (setq info (org-index--on 'id id
+ (mapcar (lambda (x) (org-index--get-or-set-field x))
+ (list 'keywords 'count 'created 'last-accessed 'category 'ref)))))
+
+ (setq reached-top (= (org-outline-level) 1))
+
+ (if (or info reached-top)
+ (setq done t)
+ (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'%s has been accessed %s times between %s and %s; category is '%s', reference is '%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 (if (numberp arg) arg nil)))
+
+
+ ((eq command 'ref)
+
+ (let (args newref)
+
+ (setq args (org-index--collect-values-from-user org-index-edit-on-ref))
+ (setq newref (org-index--get-save-maxref))
+ (setq args (plist-put args 'ref newref))
+ (apply 'org-index--do-new-line args)
+
+ (setq kill-new-text newref)
+
+ (setq message-text (format "Added new row with ref '%s'" newref))))
+
+
+ ((eq command 'yank)
+
+ (let (args)
+
+ (setq args (org-index--collect-values-from-user org-index-edit-on-yank))
+ (if (plist-get args 'yank)
+ (plist-put args 'yank (replace-regexp-in-string "|" "\\vert" (plist-get args 'yank) nil 'literal)))
+ (setq args (plist-put args 'category "yank"))
+ (apply 'org-index--do-new-line args)
+
+ (setq message-text "Added new row with text to yank")))
+
+
+ ((eq command 'column)
+
+ (if (and org-index--within-index-node
+ (org-at-table-p))
+ (let (char col num)
+ (setq char (read-char "Please specify, which column to go to (r=ref, k=keywords, c=category, y=yank): "))
+ (unless (memq char (list ?r ?k ?c ?y))
+ (error (format "Invalid char '%c', cannot goto this column" char)))
+ (setq col (cdr (assoc char '((?r . ref) (?k . keywords) (?c . category) (?y . yank)))))
+ (setq num (org-index--column-num col))
+ (if num
+ (progn
+ (org-table-goto-column num)
+ (setq message-text (format "At column %s" (symbol-name col))))
+
+ (error (format "Column '%s' is not present" col))))
+ (error "Need to be in index table to go to a specific column")))
+
+
+ ((eq command 'edit)
+
+ (setq message-text (org-index--do-edit)))
+
+
+ ((eq command 'sort)
+
+ (let ((sorts (list "count" "last-accessed" "mixed" "id" "ref"))
+ sort groups-and-counts)
+
+ (cond
+ ((eq sort-what 'index)
+ (setq sort
+ (intern
+ (completing-read
+ "Please choose column to sort index table: "
+ (cl-copy-list sorts)
+ nil t nil nil (symbol-name org-index-sort-by))))
+
+ (org-index--do-sort-index sort)
+ (org-table-goto-column (org-index--column-num (if (eq sort 'mixed) 'last-access sort)))
+ ;; When saving index, it should again be sorted correctly
+ (with-current-buffer org-index--buffer
+ (add-hook 'before-save-hook 'org-index--sort-silent t))
+
+ (setq message-text
+ (format
+ (concat "Your index has been sorted temporarily by %s and will be sorted again by %s after %d seconds of idle time"
+ (if groups-and-counts
+ "; %d groups with equal %s and a total of %d lines have been found"
+ ""))
+ (symbol-name sort)
+ org-index-sort-by
+ org-index-idle-delay
+ (cl-second groups-and-counts)
+ (symbol-name sort)
+ (cl-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 'focus)
+ (setq message-text (if arg
+ (org-index--more-focus-commands)
+ (org-index--goto-focus))))
+
+
+ ((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 (c-u-text (if arg " C-u " "")))
+ (while (not char)
+ (if (sit-for 1)
+ (message (concat "org-index (? for detailed prompt) -" c-u-text)))
+ (setq char (key-description (read-key-sequence nil)))
+ (if (string= char "C-g") (keyboard-quit))
+ (if (string= char "SPC") (setq char "?"))
+ (when (string= char (upcase char))
+ (setq char (downcase char))
+ (setq arg (or arg '(4))))
+ (when (string= char "C-u")
+ (setq arg (or arg '(4)))
+ (setq c-u-text " C-u ")
+ (setq char nil)))
+ (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--get-save-maxref))
+ (setq keys-values (plist-put keys-values 'ref ref)))
+
+ (apply 'org-index--do-new-line keys-values)
+ ref))
+
+
+(defun org-index--read-command ()
+ "Read subcommand for ‘org-index’ from minibuffer."
+ (let (minibuffer-scroll-window
+ command)
+ (setq org-index--short-help-displayed nil)
+ (setq org-index--prefix-arg 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
+ (completing-read
+ (concat
+ "Please choose"
+ (if org-index--display-short-help "" " (? for short help)")
+ ": ")
+ (append (mapcar 'symbol-name org-index--commands)
+ (mapcar 'upcase-initials (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)
+ (unless (string= command (downcase command))
+ (if command (setq command (downcase command)))
+ (setq org-index--prefix-arg '(4)))
+ (setq command (intern command))
+ (when org-index--short-help-displayed
+ (quit-windows-on org-index--short-help-buffer-name)))
+ command))
+
+
+(defun org-index--minibuffer-setup-function ()
+ "Prepare minibuffer for `org-index--read-command'."
+ (setq org-index--minibuffer-saved-key (local-key-binding (kbd "?")))
+ (local-set-key (kbd "?") 'org-index--display-short-help)
+ (local-set-key (kbd "C-u") (lambda () (interactive)
+ (setq org-index--prefix-arg t)
+ (message "C-u")))
+ (if org-index--display-short-help (org-index--display-short-help)))
+
+
+(defun org-index--minibuffer-exit-function ()
+ "Restore minibuffer after `org-index--read-command'."
+ (local-set-key (kbd "?") org-index--minibuffer-saved-key)
+ (local-set-key (kbd "C-u") 'universal-argument)
+ (setq org-index--minibuffer-saved-key nil))
+
+
+(defun org-index--display-short-help ()
+ "Helper function to show help in minibuffer."
+ (interactive)
+
+ (with-temp-buffer-window
+ org-index--short-help-buffer-name nil nil
+ (setq org-index--short-help-displayed t)
+ (princ "Short help; shortcuts in []; capital letter acts like C-u.\n")
+ (princ (org-index--get-short-help-text)))
+ (with-current-buffer org-index--short-help-buffer-name
+ (let ((inhibit-read-only t))
+ (shrink-window-if-larger-than-buffer (get-buffer-window))
+ (goto-char (point-min))
+ (end-of-line)
+ (goto-char (point-min)))))
+
+
+(defun org-index--get-short-help-text ()
+ "Extract text for short help message from long help."
+ (or org-index--short-help-text
+ (with-temp-buffer
+ (insert (documentation 'org-index))
+ (goto-char (point-min))
+ (search-forward (concat " " (symbol-name (cl-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]+\\)[ \t]+: +\\[\\([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--goto-focus ()
+ "Goto focus node, one after the other."
+ (if org-index--ids-focused-nodes
+ (let (this-id target-id following-id last-id again explain marker (repeat-clause ""))
+ (setq again (and (eq this-command last-command)
+ (eq org-index--this-command org-index--last-command)))
+ (setq last-id (or org-index--id-last-goto-focus
+ (car (last org-index--ids-focused-nodes))))
+ (setq this-id (org-id-get))
+ (setq following-id (car (or (cdr-safe (member last-id
+ (append org-index--ids-focused-nodes
+ org-index--ids-focused-nodes)))
+ org-index--ids-focused-nodes)))
+ (if again
+ (progn
+ (setq target-id following-id)
+ (setq explain "Jumped to next"))
+ (setq target-id last-id)
+ (setq explain "Jumped back to current"))
+
+ (set-transient-map (let ((map (make-sparse-keymap)))
+ (define-key map (vector ?f)
+ (lambda () (interactive)
+ (setq this-command last-command)
+ (setq org-index--this-command org-index--last-command)
+ (message (concat (org-index--goto-focus) "."))))
+ (define-key map (vector ?d)
+ (lambda () (interactive)
+ (setq this-command last-command)
+ (org-index--delete-from-focus)
+ (org-index--persist-focused-nodes)
+ (message (concat "Current node has been removed from list of focused nodes, " (org-index--goto-focus) "."))))
+ map) t)
+ (setq repeat-clause "; type 'f' to repeat or 'd' to delete this node from list")
+
+ (if (member target-id (org-index--ids-up-to-top))
+ (setq explain "Staying below current")
+ (unless (setq marker (org-id-find target-id 'marker))
+ (setq org-index--id-last-goto-focus nil)
+ (error "Could not find focus-node with id %s" target-id))
+
+ (pop-to-buffer-same-window (marker-buffer marker))
+ (goto-char (marker-position marker))
+ (org-index--unfold-buffer)
+ (move-marker marker nil))
+
+ (when org-index-clock-into-focus
+ (if org-index--after-focus-timer (cancel-timer org-index--after-focus-timer))
+ (setq org-index--after-focus-context target-id)
+ (setq org-index--after-focus-timer
+ (run-at-time org-index--after-focus-delay nil
+ (lambda ()
+ (when org-index--after-focus-context
+ (save-window-excursion
+ (save-excursion
+ (org-id-goto org-index--after-focus-context)
+ (org-clock-in)
+ (org-index--update-line org-index--after-focus-context t)
+ (setq org-index--after-focus-context nil)
+ (cancel-timer org-index--after-focus-timer))))))))
+ (setq org-index--id-last-goto-focus target-id)
+ (concat
+ (if (cdr org-index--ids-focused-nodes)
+ (format "%s focus node (out of %d)"
+ explain
+ (length org-index--ids-focused-nodes))
+ "Jumped to single focus-node")
+ repeat-clause))
+ "No nodes in focus, use set-focus"))
+
+
+(defun org-index--more-focus-commands ()
+ "More commands for handling focused nodes."
+ (let (id text more-text char prompt ids-up-to-top)
+
+ (setq prompt (format "Please specify action on the list of %s focused nodes: set, append, delete (s,a,d or ? for short help) - "
+ (length org-index--ids-focused-nodes)))
+ (while (not (memq char (list ?s ?a ?d)))
+ (setq char (read-char prompt))
+ (setq prompt "Actions on list of focused nodes: s)et single focus on this node, a)ppend this node to list, d)elete this node from list. Please choose - "))
+ (setq text
+ (cond
+
+ ((eq char ?s)
+ (setq id (org-id-get-create))
+ (setq org-index--ids-focused-nodes (list id))
+ (setq org-index--id-last-goto-focus id)
+ (if org-index-clock-into-focus (org-clock-in))
+ "Focus has been set on current node%s (1 node in focus)")
+
+ ((eq char ?a)
+ (setq id (org-id-get-create))
+ (unless (member id org-index--ids-focused-nodes)
+ ;; remove any children, that are already in list of focused nodes
+ (setq org-index--ids-focused-nodes
+ (delete nil (mapcar (lambda (x)
+ (if (member id (org-with-point-at (org-id-find x t)
+ (org-index--ids-up-to-top)))
+ (progn
+ (setq more-text ", removing its children")
+ nil)
+ x))
+ org-index--ids-focused-nodes)))
+ ;; remove parent, if already in list of focused nodes
+ (setq ids-up-to-top (org-index--ids-up-to-top))
+ (when (seq-intersection ids-up-to-top org-index--ids-focused-nodes)
+ (setq org-index--ids-focused-nodes (seq-difference org-index--ids-focused-nodes ids-up-to-top))
+ (setq more-text (concat more-text ", replacing its parent")))
+ (setq org-index--ids-focused-nodes (cons id org-index--ids-focused-nodes)))
+ (setq org-index--id-last-goto-focus id)
+ (setq org-index--id-last-goto-focus id)
+ (if org-index-clock-into-focus (org-clock-in))
+ "Current node has been appended to list of focused nodes%s (%d node%s in focus)")
+
+ ((eq char ?d)
+ (org-index--delete-from-focus))))
+
+ (org-index--persist-focused-nodes)
+
+ (format text (or more-text "") (length org-index--ids-focused-nodes) (if (cdr org-index--ids-focused-nodes) "s" ""))))
+
+
+(defun org-index--persist-focused-nodes ()
+ "Write list of focused nodes to property."
+ (with-current-buffer org-index--buffer
+ (org-entry-put org-index--point "ids-focused-nodes" (string-join org-index--ids-focused-nodes " "))))
+
+
+(defun org-index--delete-from-focus ()
+ "Delete current node from list of focused nodes"
+ (let (id)
+ (setq id (org-id-get))
+ (if (and id (member id org-index--ids-focused-nodes))
+ (progn
+ (setq org-index--id-last-goto-focus
+ (or (car-safe (cdr-safe (member id (reverse (append org-index--ids-focused-nodes
+ org-index--ids-focused-nodes)))))
+ org-index--id-last-goto-focus))
+ (setq org-index--ids-focused-nodes (delete id org-index--ids-focused-nodes))
+ (setq org-index--id-last-goto-focus nil)
+ "Current node has been removed from list of focused nodes%s (%d node%s in focus)")
+ "Current node has not been in list of focused nodes%s (%d node%s in focus)")))
+
+
+(defun org-index--ids-up-to-top ()
+ "Get list of all ids from current node up to top level."
+ (when (string= major-mode "org-mode")
+ (let (ancestors id level start-level)
+ (save-excursion
+ (ignore-errors
+ (outline-back-to-heading)
+ (setq id (org-id-get))
+ (if id (setq ancestors (cons id ancestors)))
+ (setq start-level (org-outline-level))
+ (if (<= start-level 1)
+ nil
+ (while (> start-level 1)
+ (setq level start-level)
+ (while (>= level start-level)
+ (outline-previous-heading)
+ (setq level (org-outline-level)))
+ (setq start-level level)
+ (setq id (org-id-get))
+ (if id (setq ancestors (cons id ancestors))))
+ ancestors))))))
+
+
+(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-accept)
+ (define-key buffer-keymap (kbd "C-c C-k") 'org-index--edit-abort)
+
+ (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-accept)
+ (define-key field-keymap (kbd "C-c C-k") 'org-index--edit-abort)
+
+ ;; 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)
+ (setq org-index--inhibit-sort-idle t)
+ "Editing a single line from index"))
+
+
+(defun org-index--edit-accept ()
+ "Function to accept editing 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 (car 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--inhibit-sort-idle nil)
+ (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-abort ()
+ "Function to abort editing 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 keywords 'yank))
+ (error "Argument column can only be 'ref', 'id', 'keywords' or 'yank'"))
+
+ (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 (&optional num-lines-to-format check-sort-mixed)
+ "Parse content of index table.
+Optional argument NUM-LINES-TO-FORMAT limits formatting effort and duration.
+Optional argument CHECK-SORT-MIXED triggers resorting if mixed and stale."
+
+ (let (initial-point
+ end-of-headings
+ start-of-headings
+ max-ref-field)
+
+ (unless num-lines-to-format (setq num-lines-to-format 0))
+
+ (with-current-buffer org-index--buffer
+
+ (setq initial-point (point))
+
+ (org-index--go-below-hline)
+ (org-reveal)
+
+ ;; if table is sorted mixed and it was sorted correctly yesterday, it could still be wrong today; so check
+ (when (and check-sort-mixed (eq org-index-sort-by 'mixed))
+ (goto-char org-index--below-hline)
+ (let (count-first-line count-second-line)
+ (setq count-first-line (string-to-number (concat (org-index--get-or-set-field 'count) " 0")))
+ (forward-line)
+ (setq count-second-line (string-to-number (concat (org-index--get-or-set-field 'count) " 0")))
+ (forward-line -1)
+ (if (and (string< (org-index--get-or-set-field 'last-accessed)
+ (org-index--get-mixed-time))
+ (< count-first-line count-second-line))
+ (org-index--do-sort-index org-index-sort-by)))
+ (org-index--go-below-hline))
+
+ ;; align and fontify table once for this emacs session
+ (when (> num-lines-to-format org-index--aligned)
+ (org-index--go-below-hline)
+ (message "Aligning and fontifying %s lines of index table (once per emacs session)..."
+ (if (= num-lines-to-format most-positive-fixnum) "all" (format "%d" num-lines-to-format)))
+ (save-restriction
+ (let (from to)
+ (forward-line -3)
+ (setq from (point))
+ (setq to (org-table-end))
+ (when (< num-lines-to-format most-positive-fixnum)
+ (forward-line (+ 3 num-lines-to-format))
+ (narrow-to-region from (point))
+ (setq to (min (point) to)))
+ (goto-char org-index--below-hline)
+ (org-table-align)
+ (setq to (min (point-max) to))
+ (font-lock-fontify-region from to)))
+ (setq org-index--aligned num-lines-to-format)
+ (org-index--go-below-hline)
+ (message "Done."))
+
+ (beginning-of-line)
+
+ ;; get headings to display during occur
+ (setq end-of-headings (point))
+ (goto-char (org-table-begin))
+ (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
+ (goto-char (org-table-begin))
+
+ ;; parse line of headings
+ (org-index--parse-headings)
+
+ ;; read property or go through table to find maximum number
+ (goto-char org-index--below-hline)
+ (setq max-ref-field (or (org-entry-get org-index--point "max-ref")
+ (org-index--migrate-maxref-to-property)))
+
+ (unless org-index--head (org-index--get-decoration-from-ref-field max-ref-field))
+
+ ;; Get ids of focused node (if any)
+ (setq org-index--ids-focused-nodes (split-string (or (org-entry-get nil "ids-focused-nodes") "")))
+ (org-entry-delete (point) "id-focused-node") ; migrate (kind of) from previous versions
+
+ ;; save position below hline
+ (org-index--go-below-hline)
+ ;; go back to initial position
+ (goto-char initial-point))))
+
+
+(defun org-index--get-decoration-from-ref-field (ref-field)
+ "Extract decoration from a REF-FIELD."
+ (unless (string-match "^\\([^0-9]*\\)\\([0-9]+\\)\\([^0-9]*\\)$" ref-field)
+ (org-index--report-index-error
+ "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)))
+
+
+(defun org-index--extract-refnum (ref-field)
+ "Extract the number from a complete reference REF-FIELD like 'R102'."
+ (unless (string-match org-index--ref-regex ref-field)
+ (org-index--report-index-error
+ "Reference '%s' is not formatted properly (does not match '%s')" ref-field org-index--ref-regex))
+ (string-to-number (match-string 1 ref-field)))
+
+
+(defun org-index--migrate-maxref-to-property ()
+ "One-time migration: No property; need to go through whole table once to find max."
+ (org-index--go-below-hline)
+ (let ((max-ref-num 0)
+ ref-field ref-num ref)
+ (message "One-time migration to set index-property maxref...")
+ (while (org-at-table-p)
+ (setq ref-field (org-index--get-or-set-field 'ref))
+ (when ref-field
+ (unless org-index--head (org-index--get-decoration-from-ref-field ref-field))
+ (setq ref-num (org-index--extract-refnum ref-field))
+ (if (> ref-num max-ref-num) (setq max-ref-num ref-num)))
+ (forward-line))
+ (unless (> max-ref-num 0)
+ (org-index--report-index-error "No reference found in property max-ref and none in index"))
+ (setq ref-field (format org-index--ref-format max-ref-num))
+ (org-index--go-below-hline)
+ (org-entry-put org-index--point "max-ref" ref-field)
+ (message "Done.")
+ ref-field))
+
+
+(defun org-index--get-save-maxref (&optional no-inc)
+ "Get next reference, increment number and store it in index.
+Optional argument NO-INC skips automatic increment on maxref."
+ (let (ref-field)
+ (with-current-buffer org-index--buffer
+ (setq ref-field (org-entry-get org-index--point "max-ref"))
+ (unless no-inc
+ (setq ref-field (format org-index--ref-format (1+ (org-index--extract-refnum ref-field))))
+ (org-entry-put org-index--point "max-ref" ref-field)))
+ ref-field))
+
+
+(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))
+ (goto-char (org-table-end))
+
+ ;; 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-assumed 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))
+ (org-entry-put org-index--point "max-ref" firstref)
+ (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 id-or-pos no-error)
+ "Update columns count and last-accessed in line ID-OR-POS.
+Optional argument NO-ERROR suppresses error."
+
+ (let (initial)
+
+ (with-current-buffer org-index--buffer
+ (unless buffer-read-only
+
+ (setq initial (point))
+
+ (if (if (integerp id-or-pos)
+ (goto-char id-or-pos)
+ (org-index--go 'id id-or-pos))
+ (org-index--update-current-line)
+ (unless no-error (error "Did not find reference or id '%s'" (list id-or-pos))))
+
+ (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 lines-fontified)
+ ;; 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
+ (setq
+ lines-fontified
+ (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-fontified))
+
+
+(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-assumed)) ; 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--get-save-maxref))
+ (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 args (plist-put args 'ref ref)))
+ (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 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 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 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 (or (string-match org-index--ref-regex tag)
+ (string= tag ""))
+ (setq new-tags (cons tag new-tags))))
+ (org-get-tags))
+ (org-set-tags-to new-tags)))
+
+
+(defun org-index--go (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"))
+
+ (unless value
+ (error "Cannot search for nil"))
+
+ (if (string= value "")
+ (error "Cannot search for empty string"))
+
+ (if (<= (length value) 2)
+ (warn "Searching for short string '%s' will be slow" value))
+
+ (goto-char org-index--below-hline)
+ (forward-line 0)
+ (save-restriction
+ (narrow-to-region (point) (org-table-end))
+ (while (and (not found)
+ (search-forward value nil t))
+ (setq found (string= value (org-index--get-or-set-field column)))))
+
+ ;; 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 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 (&optional days)
+ "Perform command occur; optional narrow to DAYS back."
+ (let ((word "") ; last word to search for growing and shrinking on keystrokes
+ (prompt "Search for: ")
+ (these-commands " NOTE: If you invoke the subcommands edit (`e') or kill (`C-c i k') from within this buffer, the index is updated accordingly")
+ (lines-wanted (window-body-height))
+ words ; list words that should match
+ occur-buffer
+ begin ; position of first line
+ 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
+ initial-frame ; Frame when starting occur
+ key ; input from user in various forms
+ key-sequence
+ key-sequence-raw
+ days-clause) ; clause to display for days back search
+
+
+ ;; 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)
+
+ ;; 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)
+ (narrow-to-region (point) (org-table-end))
+ (forward-line)
+
+ ;; initialize help text
+ (setq days-clause (if days (format " (%d days back)" days) ""))
+ (setq help-text (cons
+ (concat
+ (propertize (format "Incremental occur%s" days-clause) '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)
+
+ ;; do not enter loop if number of days is requested
+ (when days
+ (goto-char begin)
+ (org-index--hide-with-overlays (cons word words) lines-wanted days)
+ (move-overlay org-index--occur-tail-overlay (org-index--occur-end-of-visible) (point-max))
+
+ (goto-char begin)
+ (setq done t))
+
+ ;; main loop
+ (while (not done)
+
+ (if in-c-backspace
+ (setq key "<backspace>")
+ (setq search-text (mapconcat 'identity (reverse (cons word words)) ","))
+
+ ;; 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))
+
+ ;; 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
+ (org-index--unhide)
+ (move-overlay org-index--occur-tail-overlay
+ (org-index--occur-end-of-visible)
+ (point-max))
+
+ ;; 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
+
+ ;; add to word
+ (setq word (concat word key))
+
+ ;; make overlays to hide lines, that do not match longer word any more
+ (goto-char begin)
+ (org-index--hide-with-overlays (cons word words) lines-wanted days)
+ (move-overlay org-index--occur-tail-overlay
+ (org-index--occur-end-of-visible)
+ (point-max))
+
+ (goto-char begin)
+
+ ;; make sure, point is on a visible line
+ (line-move -1 t)
+ (line-move 1 t))
+
+ ;; anything else terminates input 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))
+
+ ;; 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)
+ (let ((inhibit-read-only t))
+ (put-text-property begin (org-table-end) 'face nil))
+
+ ;; 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)))
+ (when (fboundp 'font-lock-ensure)
+ (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 (format "Search is done%s; ? toggles help and headlines.\n" days-clause) 'face 'org-agenda-dimmed-todo-face))
+ (concat
+ (org-index--wrap
+ (propertize
+ (format
+ (concat (format "Search is done%s." days-clause)
+ (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
+ (mapc (lambda (w) (unless (or (not w) (string= w ""))
+ (highlight-regexp
+ (if (string= w (downcase w))
+ (apply 'concat (mapcar (lambda (c) (if (string-match "[[:alpha:]]" (char-to-string c))
+ (format "[%c%c]" (downcase c) (upcase c))
+ (char-to-string c)))
+ (regexp-quote w)))
+ (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 "e")
+ (lambda () (interactive)
+ (message (org-index 'edit))))
+
+ (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-end-of-visible ()
+ "End of visible stretch during occur."
+ (if org-index--occur-stack
+ (cdr (assoc :end-of-visible (car org-index--occur-stack)))
+ (point-max)))
+
+
+(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; please repeat search"))))
+
+
+(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)
+ (if (and (>= (length yank) 4) (string= (substring yank 0 4) "http"))
+ (progn
+ (browse-url yank)
+ (format "Opened '%s' in browser (and copied it too)" yank))
+ (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 days)
+ "Hide lines that are currently visible and do not match WORDS;
+leave LINES-WANTED lines visible.
+Argument DAYS hides older lines."
+ (let ((lines-found 0)
+ (end-of-visible (point))
+ overlay overlays start matched places all-places)
+
+ ;; 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 places nil)
+ (setq start (point))
+ (while (and (not (eobp))
+ (not (and
+ (invisible-p (point))
+ (< (point) (overlay-start org-index--occur-tail-overlay))))
+ ;; either regard words or days, but not both
+ (if days
+ (let ((last-accessed (org-index--get-or-set-field 'last-accessed)))
+ (if last-accessed
+ (not (and
+ (<= (- (time-to-days (current-time))
+ (time-to-days (org-read-date nil t last-accessed nil)))
+ days)
+ (setq matched t))) ; for its side effect
+ t))
+ (not (and (setq places (org-index--test-words words))
+ (setq matched t))))) ; for its side effect
+ (forward-line 1))
+
+ (setq all-places (append places all-places))
+
+ ;; 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
+ (let ((inhibit-read-only t) (lbp (line-beginning-position)))
+ (put-text-property lbp (line-end-position) 'face nil)
+ (while places
+ (put-text-property (caar places) (+ (caar places) (cdar places)) 'face 'isearch)
+ (setq places (cdr places))))
+ (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)
+ (cons :places all-places))
+ org-index--occur-stack))
+
+ lines-found))
+
+
+(defun org-index--unhide ()
+ "Unhide text that does has been hidden by `org-index--hide-with-overlays'."
+ (let (places)
+ (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 latest highlights
+ (setq places (cdr (assoc :places (car org-index--occur-stack))))
+ (while places
+ (let ((inhibit-read-only t))
+ (put-text-property (caar places) (+ (caar places) (cdar places)) 'face nil))
+ (setq places (cdr places)))
+ ;; remove top of stack
+ (setq org-index--occur-stack (cdr org-index--occur-stack))
+ ;; redo older highlights
+ (setq places (cdr (assoc :places (car org-index--occur-stack))))
+ (while places
+ (let ((inhibit-read-only t))
+ (put-text-property (caar places) (+ (caar places) (cdar places)) 'face 'isearch))
+ (setq places (cdr places))))))
+
+
+(defun org-index--test-words (words)
+ "Test current line for match against WORDS."
+ (let ((lbp (line-beginning-position))
+ line dc-line places index)
+ (setq line (buffer-substring lbp (line-beginning-position 2)))
+ (setq dc-line (downcase line))
+ (catch 'not-found
+ (dolist (word words)
+ (if (setq index (cl-search word (if (string= word (downcase word)) dc-line line)))
+ (setq places (cons (cons (+ lbp index) (length word)) places))
+ (throw 'not-found nil)))
+ places)))
+
+
+(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
+ (goto-char (org-table-end))
+ (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."
+ (unless org-index--inhibit-sort-idle
+ (save-excursion
+ (org-index--verify-id)
+ (org-index--parse-table)
+ (with-current-buffer org-index--buffer
+ (save-excursion
+ (goto-char org-index--below-hline)
+ (org-index--do-sort-index org-index-sort-by)
+ (remove-hook 'before-save-hook 'org-index--sort-silent))))))
+
+
+(defun org-index--idle-prepare ()
+ "For parsing table when idle."
+ (org-index--verify-id)
+ (org-index--parse-table most-positive-fixnum t))
+
+
+(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 57665e2..147ddae 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-2013 Free Software Foundation, Inc.
+;; Copyright 2007-2017 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-invoice.el b/contrib/lisp/org-invoice.el
index 88ff48f..6868894 100644
--- a/contrib/lisp/org-invoice.el
+++ b/contrib/lisp/org-invoice.el
@@ -1,6 +1,6 @@
;;; org-invoice.el --- Help manage client invoices in OrgMode
;;
-;; Copyright (C) 2008-2013 pmade inc. (Peter Jones pjones@pmade.com)
+;; Copyright (C) 2008-2014 pmade inc. (Peter Jones pjones@pmade.com)
;;
;; This file is not part of GNU Emacs.
;;
@@ -55,6 +55,8 @@
(require 'cl)
(require 'org))
+(declare-function org-duration-from-minutes "org-duration" (minutes &optional fmt fractional))
+
(defgroup org-invoice nil
"OrgMode Invoice Helper"
:tag "Org-Invoice" :group 'org)
@@ -159,7 +161,7 @@ looks like tree2, where the