diff options
| author | Sebastien Delafond <seb@untangle.com> | 2017-08-02 11:47:03 -0700 |
|---|---|---|
| committer | Sebastien Delafond <seb@untangle.com> | 2017-08-02 11:47:03 -0700 |
| commit | f41dc76cb81204c4ef33420f69eecfc387d7f2a5 (patch) | |
| tree | 652270789f46934981ba73535a733722d79576be /contrib/lisp | |
Import org-mode_9.0.9+dfsg.orig.tar.xz
[dgit import orig org-mode_9.0.9+dfsg.orig.tar.xz]
Diffstat (limited to 'contrib/lisp')
69 files changed, 31140 insertions, 0 deletions
diff --git a/contrib/lisp/htmlize.el b/contrib/lisp/htmlize.el new file mode 100644 index 0000000..8358830 --- /dev/null +++ b/contrib/lisp/htmlize.el @@ -0,0 +1,1924 @@ +;;; 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, +\"©\" *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, \"©\" is exactly equivalent to \"©\". + +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 ?&) "&" + (aref table ?<) "<" + (aref table ?>) ">" + ;; 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 ?\") """ + ) + 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 ?\") + """ + (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:" 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) + (setq color (funcall function face nil t)) + (when (and (eq face 'default) (null color)) + (setq color (cdr (assq (if fg 'foreground-color 'background-color) + (frame-parameters))))) + (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 (face-attribute face attr nil t))) + (when (and value (not (eq value 'unspecified))) + (htmlize-face-emacs21-attr fstruct attr value)))) + (let ((size (htmlize-face-size face))) + (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 --- /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 new file mode 100644 index 0000000..d3ad993 --- /dev/null +++ b/contrib/lisp/ob-eukleides.el @@ -0,0 +1,98 @@ +;;; ob-eukleides.el --- Org-babel functions for eukleides evaluation + +;; Copyright (C) 2010-2017 Free Software Foundation, Inc. + +;; Author: Luis Anaya +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org + +;; This file is not part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating eukleides script. +;; +;; Inspired by Ian Yang's org-export-blocks-format-eukleides +;; http://www.emacswiki.org/emacs/org-export-blocks-format-eukleides.el + +;;; Requirements: + +;; eukleides | http://eukleides.org +;; eukleides | `org-eukleides-path' should point to the eukleides executablexs + +;;; Code: +(require 'ob) +(require 'ob-eval) + +(defvar org-babel-default-header-args:eukleides + '((:results . "file") (:exports . "results")) + "Default arguments for evaluating a eukleides source block.") + +(defcustom org-eukleides-path nil + "Path to the eukleides executable file." + :group 'org-babel + :type 'string) + +(defcustom org-eukleides-eps-to-raster nil + "Command used to convert EPS to raster. Nil for no conversion." + :group 'org-babel + :type '(choice + (repeat :tag "Shell Command Sequence" (string :tag "Shell Command")) + (const :tag "sam2p" "a=%s;b=%s;sam2p ${a} ${b}" ) + (const :tag "NetPNM" "a=%s;b=%s;pstopnm -stdout ${a} | pnmtopng > ${b}" ) + (const :tag "None" nil))) + +(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 (assq :results params)) ""))) + (out-file (or (cdr (assq :file params)) + (error "Eukleides requires a \":file\" header argument"))) + (cmdline (cdr (assq :cmdline params))) + (in-file (org-babel-temp-file "eukleides-")) + (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) + " -b --output=" + (org-babel-process-file-name + (concat + (file-name-sans-extension out-file) ".eps")) + " " + (org-babel-process-file-name in-file))))) + (unless (file-exists-p org-eukleides-path) + (error "Could not find eukleides at %s" org-eukleides-path)) + + (if (string= (file-name-extension out-file) "png") + (if org-eukleides-eps-to-raster + (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"))) + + (with-temp-file in-file (insert body)) + (message "%s" cmd) (org-babel-eval cmd "") + nil)) ;; signal that output has already been written to file + +(defun org-babel-prep-session:eukleides (session params) + "Return an error because eukleides does not support sessions." + (error "Eukleides does not support sessions")) + +(provide 'ob-eukleides) + + + +;;; ob-eukleides.el ends here diff --git a/contrib/lisp/ob-fomus.el b/contrib/lisp/ob-fomus.el new file mode 100644 index 0000000..30f292f --- /dev/null +++ b/contrib/lisp/ob-fomus.el @@ -0,0 +1,92 @@ +;;; ob-fomus.el --- Org-babel functions for fomus evaluation + +;; Copyright (C) 2011-2014 Torsten Anders + +;; Author: Torsten Anders +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org + +;; This file is not part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, 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: + +;; Org-Babel support for evaluating Fomus source code. +;; For information on Fomus see http://fomus.sourceforge.net/ +;; +;; This differs from most standard languages in that +;; +;; 1) there is no such thing as a "session" in fomus +;; +;; 2) we are generally only going to return results of type "file" +;; +;; 3) we are adding the "file" and "cmdline" header arguments +;; +;; 4) there are no variables (at least for now) + +;;; Code: +(require 'ob) +(require 'ob-eval) + +(defvar org-babel-default-header-args:fomus + '((:results . "file") (:exports . "results")) + "Default arguments to use when evaluating a fomus source block.") + +(defun org-babel-expand-body:fomus (body params) + "Expand BODY according to PARAMS, return the expanded body." + (let ((vars (org-babel--get-vars params))) + (mapc + (lambda (pair) + (let ((name (symbol-name (car pair))) + (value (cdr pair))) + (setq body + (replace-regexp-in-string + (concat "\$" (regexp-quote name)) + (if (stringp value) value (format "%S" value)) + body)))) + vars) + body)) + +(defun org-babel-execute: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 (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))) + ;; TMP: testing + ;; (message (concat cmd + ;; " " (org-babel-process-file-name in-file) + ;; " " cmdline + ;; " -o " (org-babel-process-file-name out-file))) + (org-babel-eval + (concat cmd + " " (org-babel-process-file-name in-file) + " " cmdline + " -o " (org-babel-process-file-name out-file)) "") + nil)) ;; signal that output has already been written to file + +(defun org-babel-prep-session:fomus (session params) + "Return an error because Fomus does not support sessions." + (error "Fomus does not support sessions")) + +(provide 'ob-fomus) + +;;; ob-fomus.el ends here diff --git a/contrib/lisp/ob-julia.el b/contrib/lisp/ob-julia.el new file mode 100644 index 0000000..41c8b5a --- /dev/null +++ b/contrib/lisp/ob-julia.el @@ -0,0 +1,301 @@ +;;; ob-julia.el --- org-babel functions for julia code evaluation + +;; 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. + +;; 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 julia code. +;; +;; See https://github.com/gjkerns/ob-julia/blob/master/ob-julia-doc.org +;; for detailed instructions on how to get started. The git repository +;; contains more documentation: git://github.com/gjkerns/ob-julia.git + +;;; Code: +(require 'ob) +(require 'cl-lib) + +(declare-function orgtbl-to-csv "org-table" (table params)) +(declare-function julia "ext:ess-julia" (&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:julia + '((width . :any) + (horizontal . :any) + (results . ((file list vector table scalar verbatim) + (raw org html latex code pp wrap) + (replace silent append prepend) + (output value graphics)))) + "julia-specific header arguments.") + +(add-to-list 'org-babel-tangle-lang-exts '("julia" . "jl")) + +(defvar org-babel-default-header-args:julia '()) + +(defcustom org-babel-julia-command inferior-julia-program-name + "Name of command to use for executing julia code." + :group 'org-babel + :version "24.4" + :package-version '(Org . "8.0") + :type 'string) + +(defvar ess-local-process-name) ; dynamically scoped +(defun org-babel-edit-prep:julia (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))))) + +(defun org-babel-expand-body:julia (body params &optional graphics-file) + "Expand BODY according to PARAMS, return the expanded body." + (let ((graphics-file + (or graphics-file (org-babel-julia-graphical-output-file params)))) + (mapconcat + #'identity + ((lambda (inside) + (if graphics-file + inside + inside)) + (append (org-babel-variable-assignments:julia params) + (list body))) "\n"))) + +(defun org-babel-execute:julia (body params) + "Execute a block of julia 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-julia-initiate-session + (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 + (org-babel-julia-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:julia (session params) + "Prepare SESSION according to the header arguments specified in PARAMS." + (let* ((session (org-babel-julia-initiate-session session params)) + (var-lines (org-babel-variable-assignments:julia 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:julia (session body params) + "Load BODY into SESSION." + (save-window-excursion + (let ((buffer (org-babel-prep-session:julia 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:julia (params) + "Return list of julia statements assigning the block's variables." + (let ((vars (org-babel--get-vars params))) + (mapcar + (lambda (pair) + (org-babel-julia-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-julia-quote-csv-field (s) + "Quote field S for export to julia." + (if (stringp s) + (concat "\"" (mapconcat 'identity (split-string s "\"") "\"\"") "\"") + (format "%S" s))) + +(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 (cl-remove-if-not + #'sequencep value)))) + (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) + (unless (listp (car value)) (setq value (list value))) + (with-temp-file transition-file + (insert + (orgtbl-to-csv value '(:fmt org-babel-julia-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 = readcsv(\"%s\")" name file) + (format "%s = readcsv(\"%s\")" + name file)))) + (format "%s = %s" name (org-babel-julia-quote-csv-field value)))) + +(defvar ess-ask-for-ess-directory) ; dynamically scoped + +(defun org-babel-julia-initiate-session (session params) + "If there is not a current julia process then create one." + (unless (string= session "none") + (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 (assq :dir params)))))) + (if (org-babel-comint-buffer-livep session) + session + (save-window-excursion + (require 'ess) (julia) + (rename-buffer + (if (bufferp session) + (buffer-name session) + (if (stringp session) + session + (buffer-name)))) + (current-buffer)))))) + +(defun org-babel-julia-associate-session (session) + "Associate julia code buffer with a julia 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-julia-graphical-output-file (params) + "Name of file to which julia should send graphical output." + (and (member "graphics" (cdr (assq :result-params params))) + (cdr (assq :file params)))) + +(defvar org-babel-julia-eoe-indicator "print(\"org_babel_julia_eoe\")") +(defvar org-babel-julia-eoe-output "org_babel_julia_eoe") + +(defvar org-babel-julia-write-object-command "writecsv(\"%s\",%s)") + +;; The following was a very complicated write object command +;; The replacement needs to add error catching +;(defvar org-babel-julia-write-object-command "{function(object,transfer.file){object;invisible(if(inherits(try({tfile<-tempfile();write.table(object,file=tfile,sep=\"\\t\",na=\"nil\",row.names=%s,col.names=%s,quote=FALSE);file.rename(tfile,transfer.file)},silent=TRUE),\"try-error\")){if(!file.exists(transfer.file))file.create(transfer.file)})}}(object=%s,transfer.file=\"%s\")") + +(defun org-babel-julia-evaluate + (session body result-type result-params column-names-p row-names-p) + "Evaluate julia code in BODY." + (if session + (org-babel-julia-evaluate-session + session body result-type result-params column-names-p row-names-p) + (org-babel-julia-evaluate-external-process + body result-type result-params column-names-p row-names-p))) + +(defun org-babel-julia-evaluate-external-process + (body result-type result-params column-names-p row-names-p) + "Evaluate BODY in external julia 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 "julia-"))) + (org-babel-eval org-babel-julia-command + (format org-babel-julia-write-object-command + (org-babel-process-file-name tmp-file 'noquote) + (format "begin\n%s\nend" body))) + (org-babel-julia-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-julia-command body)))) + +(defun org-babel-julia-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 "julia-"))) + (org-babel-comint-eval-invisibly-and-wait-for-file + session tmp-file + (format org-babel-julia-write-object-command + (org-babel-process-file-name tmp-file 'noquote) "ans")) + (org-babel-julia-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-julia-eoe-output) + (insert (mapconcat #'org-babel-chomp + (list body org-babel-julia-eoe-indicator) + "\n")) + (inferior-ess-send-input)))))) "\n")))) + +(defun org-babel-julia-process-value-result (result column-names-p) + "julia-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-julia) + +;;; ob-julia.el ends here diff --git a/contrib/lisp/ob-mathematica.el b/contrib/lisp/ob-mathematica.el new file mode 100644 index 0000000..cb35dec --- /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 new file mode 100644 index 0000000..c62e181 --- /dev/null +++ b/contrib/lisp/ob-mathomatic.el @@ -0,0 +1,145 @@ +;;; ob-mathomatic.el --- Org-babel functions for mathomatic evaluation + +;; Copyright (C) 2009-2017 Free Software Foundation, Inc. + +;; Author: Eric S Fraga +;; Eric Schulte +;; Luis Anaya (Mathomatic) + +;; Keywords: literate programming, reproducible research, mathomatic +;; Homepage: http://orgmode.org + +;; This file is not part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating mathomatic entries. +;; +;; This differs from most standard languages in that +;; +;; 1) there is no such thing as a "session" in mathomatic +;; +;; 2) we are adding the "cmdline" header argument + +;;; Code: +(require 'ob) + +(defvar org-babel-tangle-lang-exts) +(add-to-list 'org-babel-tangle-lang-exts '("mathomatic" . "math")) + +(defvar org-babel-default-header-args:mathomatic '()) + +(defcustom org-babel-mathomatic-command + (if (boundp 'mathomatic-command) mathomatic-command "mathomatic") + "Command used to call mathomatic on the shell." + :group 'org-babel) + +(defun org-babel-mathomatic-expand (body params) + "Expand a block of Mathomatic code according to its header arguments." + (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 (assq :results params)) ""))) + (result + (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))) + (with-temp-file in-file (insert (org-babel-mathomatic-expand body params))) + (message cmd) + ((lambda (raw) ;; " | grep -v batch | grep -v 'replaced' | sed '/^$/d' " + (mapconcat + #'identity + (delq nil + (mapcar (lambda (line) + (unless (or (string-match "batch" line) + (string-match "^rat: replaced .*$" line) + (= 0 (length line))) + line)) + (split-string raw "[\r\n]"))) "\n")) + (org-babel-eval cmd ""))))) + (if (org-babel-mathomatic-graphical-output-file params) + nil + (if (or (member "scalar" result-params) + (member "verbatim" result-params) + (member "output" result-params)) + result + (let ((tmp-file (org-babel-temp-file "mathomatic-res-"))) + (with-temp-file tmp-file (insert result)) + (org-babel-import-elisp-from-file tmp-file)))))) + +(defun org-babel-prep-session:mathomatic (session params) + (error "Mathomatic does not support sessions")) + +(defun org-babel-mathomatic-var-to-mathomatic (pair) + "Convert an elisp val into a string of mathomatic code specifying a var +of the same value." + (let ((var (car pair)) + (val (cdr pair))) + (when (symbolp val) + (setq val (symbol-name val)) + (when (= (length val) 1) + (setq val (string-to-char val)))) + (format "%s=%s" var + (org-babel-mathomatic-elisp-to-mathomatic val)))) + +(defun org-babel-mathomatic-graphical-output-file (params) + "Name of file to which mathomatic should send graphical output." + (and (member "graphics" (cdr (assq :result-params params))) + (cdr (assq :file params)))) + +(defun org-babel-mathomatic-elisp-to-mathomatic (val) + "Return a string of mathomatic code which evaluates to VAL." + (if (listp val) + (mapconcat #'org-babel-mathomatic-elisp-to-mathomatic val " ") + (format "%s" val))) + +(provide 'ob-mathomatic) + +;;; ob-mathomatic.el ends here diff --git a/contrib/lisp/ob-oz.el b/contrib/lisp/ob-oz.el new file mode 100644 index 0000000..9beadeb --- /dev/null +++ b/contrib/lisp/ob-oz.el @@ -0,0 +1,294 @@ +;;; ob-oz.el --- Org-babel functions for Oz evaluation + +;; Copyright (C) 2009-2014 Torsten Anders and Eric Schulte + +;; Author: Torsten Anders and Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 0.02 + +;; 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: + +;; Org-Babel support for evaluating Oz source code. +;; +;; Oz code is always send to the Oz Programming Environment (OPI), the +;; Emacs mode and compiler interface for Oz programs. Therefore, only +;; session mode is supported. In practice, non-session code blocks are +;; handled equally well by the session mode. However, only a single +;; session is supported. Consequently, the :session header argument is +;; ignored. +;; +;; The Org-babel header argument :results is interpreted as +;; follows. :results output requires the respective code block to be +;; an Oz statement and :results value requires an Oz +;; expression. Currently, results are only supported for expressions +;; (i.e. the result of :results output is always nil). +;; +;; Expression evaluation happens synchronously. Therefore there is an +;; additional header argument :wait-time <number>, which specifies the +;; maximum time to wait for the result of a given expression. nil +;; means to wait as long as it takes to get a result (potentially wait +;; forever). +;; +;; NOTE: Currently the copyright of this file may not be in a state to +;; permit inclusion as core software into Emacs or Org-mode. + +;;; Requirements: + +;; - Mozart Programming System, the implementation of the Oz +;; programming language (http://www.mozart-oz.org/), which includes +;; the major mode mozart for editing Oz programs. +;; +;; - StartOzServer.oz which is located in the contrib/scripts +;; directory of the Org-mode repository + +;;; TODO: + +;; - Decide: set communication to \\switch -threadedqueries? +;; +;; - Only start Oz compiler when required, e.g., load Org-babel only when needed? +;; +;; - Avoid synchronous evaluation to avoid blocking Emacs (complex +;; Strasheela programs can take long to find a result..). In order +;; to cleanly map code blocks to their associated results (which can +;; arrive then in any order) I could use IDs +;; (e.g. integers). However, how do I do concurrency in Emacs Lisp, +;; and how can I define org-babel-execute:oz concurrently. +;; +;; - Expressions are rarely used in Oz at the top-level, and using +;; them in documentation and Literate Programs will cause +;; confusion. Idea: hide expression from reader and instead show +;; them statement (e.g., MIDI output statement) and then include +;; result in Org file. Implementation: for expressions (:results +;; value) support an additional header argument that takes arbitrary +;; Oz code. This code is not seen by the reader, but will be used +;; for the actual expression at the end. Alternative: feed all +;; relevant code as statement (:results output), then add expression +;; as extra code block which outputs, e.g., file name (so the file +;; name must be accessible by global var), but the code of this +;; extra codeblock is not seen. Hm, in that case it might be even +;; more easy to manually add this link to the Org file. +;; + + +(require 'ob) +;;; major mode for editing Oz programs +(require 'mozart nil t) + +;; +;; Interface to communicate with Oz. +;; (1) For statements without any results: oz-send-string +;; (2) For expressions with a single result: oz-send-string-expression +;; (defined in org-babel-oz-ResultsValue.el) +;; + +;; oz-send-string-expression implements an additional very direct +;; communication between Org-babel and the Oz compiler. Communication +;; with the Oz server works already without this code via the function +;; oz-send-string from mozart.el.in, but this function does not get +;; back any results from Oz to Emacs. The following code creates a +;; socket for sending code to the OPI compiler and results are +;; returned by the same socket. On the Oz side, a socket is opened and +;; conected to the compiler of the OPI (via oz-send-string). On the +;; Emacs side, a connection to this socket is created for feeding code +;; and receiving results. This additional communication channel to the +;; OPI compiler ensures that results are returned cleanly (e.g., only +;; the result of the sent code is returned, no parsing or any +;; processing of *Oz Emulator* is required). +;; +;; There is no buffer, nor sentinel involved. Oz code is send +;; directly, and results from Oz are send back, but Emacs Lisp +;; requires a filter function for processing results. + +(defvar org-babel-oz-server-dir + (file-name-as-directory + (expand-file-name + "contrib/scripts" + (file-name-as-directory + (expand-file-name + "../../.." + (file-name-directory (or load-file-name buffer-file-name)))))) + "Path to the contrib/scripts directory in which +StartOzServer.oz is located.") + +(defvar org-babel-oz-port 6001 + "Port for communicating with Oz compiler.") +(defvar org-babel-oz-OPI-socket nil + "Socket for communicating with OPI.") + +(defvar org-babel-oz-collected-result nil + "Aux var to hand result from org-babel-oz-filter to oz-send-string-expression.") +(defun org-babel-oz-filter (proc string) + "Processes output from socket org-babel-oz-OPI-socket." +;; (setq org-babel-oz-collected-results (cons string org-babel-oz-collected-results)) + (setq org-babel-oz-collected-result string) + ) + + +(defun org-babel-oz-create-socket () + (message "Create OPI socket for evaluating expressions") + ;; Start Oz directly + (run-oz) + ;; Create socket on Oz side (after Oz was started). + (oz-send-string (concat "\\insert '" org-babel-oz-server-dir "StartOzServer.oz'")) + ;; Wait until socket is created before connecting to it. + ;; Quick hack: wait 3 sec + ;; + ;; extending time to 30 secs does not help when starting Emacs for + ;; the first time (and computer does nothing else) + (sit-for 3) + ;; connect to OPI socket + (setq org-babel-oz-OPI-socket + ;; Creates a socket. I/O interface of Emacs sockets as for processes. + (open-network-stream "*Org-babel-OPI-socket*" nil "localhost" org-babel-oz-port)) + ;; install filter + (set-process-filter org-babel-oz-OPI-socket #'org-babel-oz-filter) +) + +;; communication with org-babel-oz-OPI-socket is asynchronous, but +;; oz-send-string-expression turns is into synchronous... +(defun oz-send-string-expression (string &optional wait-time) + "Similar to oz-send-string, oz-send-string-expression sends a string to the OPI compiler. However, string must be expression and this function returns the result of the expression (as string). oz-send-string-expression is synchronous, wait-time allows to specify a maximum wait time. After wait-time is over with no result, the function returns nil." + (if (not org-babel-oz-OPI-socket) + (org-babel-oz-create-socket)) + (let ((polling-delay 0.1) + result) + (process-send-string org-babel-oz-OPI-socket string) + ;; wait for result + (if wait-time + (let ((waited 0)) + (unwind-protect + (progn + (while + ;; stop loop if org-babel-oz-collected-result \= nil or waiting time is over + (not (or (not (equal org-babel-oz-collected-result nil)) + (> waited wait-time))) + (progn + (sit-for polling-delay) +;; (message "org-babel-oz: next polling iteration") + (setq waited (+ waited polling-delay)))) +;; (message "org-babel-oz: waiting over, got result or waiting timed out") +;; (message (format "wait-time: %s, waited: %s" wait-time waited)) + (setq result org-babel-oz-collected-result) + (setq org-babel-oz-collected-result nil)))) + (unwind-protect + (progn + (while (equal org-babel-oz-collected-result nil) + (sit-for polling-delay)) + (setq result org-babel-oz-collected-result) + (setq org-babel-oz-collected-result nil)))) + result)) + +(defun org-babel-expand-body:oz (body params) + (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) + (format "%s=%s" + (car pair) + (org-babel-oz-var-to-oz (cdr pair)))) + vars))) + ;; only add var declarations if any variables are there + (mapconcat #'identity + (append (list "local") var-string (list "in" body "end")) + "\n")) + body))) + +(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 (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 + (org-babel-reassemble-table + (cond + ((member "output" result-params) + (message "Org-babel: executing Oz statement") + (oz-send-string full-body)) + ((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 (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. +(defun org-babel-prep-session:oz (session params) + "Prepare SESSION according to the header arguments specified in PARAMS." + (error "org-babel-prep-session:oz unimplemented")) +;; TODO: testing... (copied from org-babel-haskell.el) +;; (defun org-babel-prep-session:oz (session params) +;; "Prepare SESSION according to the header arguments specified in PARAMS." +;; (save-window-excursion +;; (org-babel-oz-initiate-session session) +;; (let* ((vars (org-babel-ref-variables params)) +;; (var-lines (mapconcat ;; define any variables +;; (lambda (pair) +;; (format "%s=%s" +;; (car pair) +;; (org-babel-ruby-var-to-ruby (cdr pair)))) +;; vars "\n")) +;; (vars-file (concat (make-temp-file "org-babel-oz-vars") ".oz"))) +;; (when vars +;; (with-temp-buffer +;; (insert var-lines) (write-file vars-file) +;; (oz-mode) +;; ;; (inferior-oz-load-file) ; ?? +;; )) +;; (current-buffer)))) +;; + + +;; TODO: testing... (simplified version of def in org-babel-prep-session:ocaml) +;; +;; BUG: does not work yet. Error: ad-Orig-error: buffer none doesn't exist or has no process +;; UNUSED DEF +(defun org-babel-oz-initiate-session (&optional session params) + "If there is not a current inferior-process-buffer in SESSION +then create. Return the initialized session." + (unless (string= session "none") + ;; TODO: make it possible to have multiple sessions + (save-window-excursion + ;; (run-oz) + (get-buffer oz-compiler-buffer)))) + +(defun org-babel-oz-var-to-oz (var) + "Convert an elisp var into a string of Oz source code +specifying a var of the same value." + (if (listp var) +;; (concat "[" (mapconcat #'org-babel-oz-var-to-oz var ", ") "]") + (eval var) + (format "%s" var) ; don't preserve string quotes. +;; (format "%s" var) + )) + +;; TODO: +(defun org-babel-oz-table-or-string (results) + "If the results look like a table, then convert them into an +Emacs-lisp table, otherwise return the results as a string." + (error "org-babel-oz-table-or-string unimplemented")) + + +(provide 'ob-oz) +;;; org-babel-oz.el ends here diff --git a/contrib/lisp/ob-stata.el b/contrib/lisp/ob-stata.el new file mode 100644 index 0000000..d8cf52a --- /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 new file mode 100644 index 0000000..c76b138 --- /dev/null +++ b/contrib/lisp/ob-tcl.el @@ -0,0 +1,128 @@ +;;; ob-tcl.el --- Org-babel functions for tcl evaluation + +;; Copyright (C) 2009-2017 Free Software Foundation, Inc. + +;; Authors: Dan Davison +;; Eric Schulte +;; Luis Anaya (tcl) +;; +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org + +;; This file is not part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating tcl source code. + +;;; Code: +(require 'ob) +(require 'ob-eval) +(eval-when-compile (require 'cl)) + +(defvar org-babel-tangle-lang-exts) +(add-to-list 'org-babel-tangle-lang-exts '("tcl" . "tcl")) + +(defvar org-babel-default-header-args:tcl nil) + +(defcustom org-babel-tcl-command "tclsh" +"Name of command to use for executing Tcl code." + :group 'org-babel + :type 'string) + + +(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 (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 (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:tcl (session params) + "Prepare SESSION according to the header arguments in PARAMS." + (error "Sessions are not supported for Tcl")) + +(defun org-babel-variable-assignments:tcl (params) + "Return list of tcl statements assigning the block's variables." + (mapcar + (lambda (pair) + (format "set %s %s" + (car pair) + (org-babel-tcl-var-to-tcl (cdr pair)))) + (org-babel--get-vars params))) + +;; helper functions + +(defun org-babel-tcl-var-to-tcl (var) + "Convert an elisp value to a tcl variable. +The elisp value, VAR, is converted to a string of tcl source code +specifying a var of the same value." + (if (listp var) + (concat "{" (mapconcat #'org-babel-tcl-var-to-tcl var " ") "}") + (format "%s" var))) + +(defvar org-babel-tcl-buffers '(:default . nil)) + +(defun org-babel-tcl-initiate-session (&optional session params) + "Return nil because sessions are not supported by tcl." +nil) + +(defvar org-babel-tcl-wrapper-method + " +proc main {} { + %s +} + +set r [eval main] +set o [open \"%s\" \"w\"]; +puts $o $r +flush $o +close $o + +") + +(defvar org-babel-tcl-pp-wrapper-method + nil) + +(defun org-babel-tcl-evaluate (session body &optional result-type) + "Pass BODY to the Tcl process in SESSION. +If RESULT-TYPE equals 'output then return a list of the outputs +of the statements in BODY, if RESULT-TYPE equals 'value then +return the value of the last statement in BODY, as elisp." + (when session (error "Sessions are not supported for Tcl")) + (case result-type + (output (org-babel-eval org-babel-tcl-command body)) + (value (let ((tmp-file (org-babel-temp-file "tcl-"))) + (org-babel-eval + org-babel-tcl-command + (format org-babel-tcl-wrapper-method body + (org-babel-process-file-name tmp-file 'noquote))) + (org-babel-eval-read-file tmp-file))))) + +(provide 'ob-tcl) + + + +;;; ob-tcl.el ends here diff --git a/contrib/lisp/ob-vbnet.el b/contrib/lisp/ob-vbnet.el new file mode 100644 index 0000000..b0f2688 --- /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 new file mode 100644 index 0000000..b8e8bd9 --- /dev/null +++ b/contrib/lisp/org-annotate-file.el @@ -0,0 +1,157 @@ +;;; org-annotate-file.el --- Annotate a file with org syntax + +;; Copyright (C) 2008-2014 Philip Jackson + +;; Author: Philip Jackson <phil@shellarchive.co.uk> +;; Version: 0.2 + +;; This file is not currently 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 is yet another implementation to allow the annotation of a +;; 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: +;; +;; (require 'org-annotate-file) +;; (global-set-key (kbd "C-c C-l") 'org-annotate-file) ; for example +;; +;; To change the location of the annotation file: +;; +;; (setq org-annotate-file-storage-file "~/annotated.org") +;; +;; Then when you visit any file and hit C-c C-l you will find yourself +;; in an org buffer on a headline which links to the file you were +;; visiting, e.g: + +;; * ~/org-annotate-file.el + +;; Under here you can put anything you like, save the file +;; 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 +;; 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... + +;; Note that both of the above will be links. + +;;; Code: + +(require 'org) + +(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]*$" "") + (cons (concat "^\\(.\\{" after + "\\}\\).*") "\\1...")))) + (mapc (lambda (x) + (when (string-match (car x) string) + (setq string (replace-match (cdr x) nil nil string)))) + replace-map) + string)) + +;;;###autoload +(defun org-annotate-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!")) + (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-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 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)) + +(provide 'org-annotate-file) + +;;; org-annotate-file.el ends here diff --git a/contrib/lisp/org-bibtex-extras.el b/contrib/lisp/org-bibtex-extras.el new file mode 100644 index 0000000..c5b521a --- /dev/null +++ b/contrib/lisp/org-bibtex-extras.el @@ -0,0 +1,137 @@ +;;; org-bibtex-extras --- extras for working with org-bibtex entries + +;; Copyright (C) 2008-2017 Free Software Foundation, Inc. + +;; Author: Eric Schulte <eric dot schulte at gmx dot com> +;; Keywords: outlines, hypermedia, bibtex, d3 +;; Homepage: http://orgmode.org +;; Version: 0.01 + +;; This file is not yet part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Warning: This should certainly be considered EXPERIMENTAL and still +;; in development, feedback is welcome, but don't expect it +;; to work. + +;; This file add some extra functionality to your bibtex entries which +;; are stored as Org-mode headlines using org-bibtex.el. Most +;; features expect that you keep all of your reading notes in a single +;; file, set the `obe-bibtex-file' variable to the path to this file. +;; +;; - d3 view :: d3 is a Javascript library which supports interactive +;; display of graphs. To view your citations as a d3 +;; graph, execute the following which will create a .json +;; export of your references file, then grab a copy of +;; d3, edit examples/force/force.js to replace +;; +;; var source`"miserables.json"; +;; +;; with +;; +;; var source`"your-references.json"; +;; +;; then view examples/force/force.html in your browser. +;; +;; - HTML export :: Customize the `obe-html-link-base' variable so +;; that it points to an html export of your +;; references, then add the following to your html +;; export hook, and citations will be resolved during +;; html export. +;; +;; (add-hook 'org-export-first-hook +;; (lambda () +;; (when (equal org-export-current-backend 'html) +;; (obe-html-export-citations)))) + +;;; 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 + "Base of citation links. +For example, to point to your `obe-bibtex-file' use the following. + + (setq obe-html-link-base (format \"file:%s\" obe-bibtex-file)) +") + +(defvar obe-citations nil) +(defun obe-citations () + "Return all citations from `obe-bibtex-file'." + (or obe-citations + (save-window-excursion + (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-html-export-citations () + "Convert all \\cite{...} citations in the current file into HTML links." + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "\\\\cite{\\([^\000}]+\\)}" nil t) + (replace-match + (save-match-data + (mapconcat (lambda (c) (format "[[%s#%s][%s]]" obe-html-link-base c c)) + (mapcar #'org-trim + (split-string (match-string 1) ",")) ", ")))))) + +(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) + (flet ((id (it) (position it nodes :test #'string= :key #'car)) + (col (k) (mapcar (lambda (r) (cdr (assoc k r))) meta)) + (add (lst) + (dolist (el lst) (push (cons el counter) nodes)) + (incf counter))) + ;; build the nodes of the graph + (add (col :title)) + (add (remove-if (lambda (author) (string-match "others" author)) + (remove-duplicates (apply #'append (col :authors)) + :test #'string=))) + (dolist (field fields) + (add (remove-duplicates (col field) :test #'string=))) + ;; build the links in the graph + (dolist (citation meta) + (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 (assq :journal citation))))) + (when jid (push (cons jid dest) links))) + (let ((cid (id (cdr (assq :category citation))))) + (when cid (push (cons cid dest) links))))) + ;; build the json string + (format "{\"nodes\":[%s],\"links\":[%s]}" + (mapconcat + (lambda (pair) + (format "{\"name\":%S,\"group\":%d}" + (car pair) (cdr pair))) + nodes ",") + (mapconcat + (lambda (link) + (format "{\"source\":%d,\"target\":%d,\"value\":1}" + (car link) (cdr link))) + (meta-to-links meta nodes) ","))))) + +(provide 'org-bibtex-extras) +;;; org-bibtex-extras ends here diff --git a/contrib/lisp/org-bookmark.el b/contrib/lisp/org-bookmark.el new file mode 100644 index 0000000..04a473b --- /dev/null +++ b/contrib/lisp/org-bookmark.el @@ -0,0 +1,89 @@ +;;; org-bookmark.el - Support for links to bookmark +;; Copyright (C) 2008-2017 Free Software Foundation, Inc. +;; +;; Author: Tokuya Kameshima <kames AT fa2.so-net.ne.jp> +;; Version: 1.0 +;; Keywords: outlines, hypermedia, calendar, wp +;; +;; This file is not part of GNU Emacs. +;; +;; Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; 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. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(require 'org) +(require 'bookmark) + +(defgroup org-bookmark nil + "Options concerning the bookmark link." + :tag "Org Startup" + :group 'org-link) + +(defcustom org-bookmark-in-dired nil + "Use org-bookmark in dired." + :group 'org-bookmark + :type 'boolean) + +(defcustom org-bookmark-when-visiting-a-file nil + "Use org-bookmark in any buffer visiting a file." + :group 'org-bookmark + :type 'boolean) + +(defcustom org-bookmark-use-first-bookmark nil + "If several bookmarks links to the buffer, take the first one. +Otherwise prompt the user for the right bookmark to use." + :group 'org-bookmark + :type 'boolean) + +(org-link-set-parameters "bookmark" + :follow #'org-bookmark-open + :store #'org-bookmark-store-link) + +(defun org-bookmark-open (bookmark) + "Visit the bookmark BOOKMARK." + (bookmark-jump bookmark)) + +(defun org-bookmark-store-link () + "Store a link to the current line's bookmark in bookmark list." + (let (file bookmark bmks) + (cond ((and org-bookmark-in-dired + (eq major-mode 'dired-mode)) + (setq file (abbreviate-file-name (dired-get-filename)))) + ((and org-bookmark-when-visiting-a-file + (buffer-file-name (buffer-base-buffer))) + (setq file (abbreviate-file-name + (buffer-file-name (buffer-base-buffer)))))) + (if (not file) + (when (eq major-mode 'bookmark-bmenu-mode) + (setq bookmark (bookmark-bmenu-bookmark))) + (when (and (setq bmks + (mapcar (lambda (name) + (if (equal file + (abbreviate-file-name + (bookmark-location name))) + name)) + (bookmark-all-names))) + (setq bmks (delete nil bmks))) + (setq bookmark + (if (or (eq 1 (length bmks)) org-bookmark-use-first-bookmark) + (car bmks) + (completing-read "Bookmark: " bmks nil t nil nil (car bmks)))))) + (if bookmark + (org-store-link-props :link (concat "bookmark:" bookmark) + :description bookmark)))) + +(provide 'org-bookmark) + +;;; org-bookmark.el ends here diff --git a/contrib/lisp/org-bullets.el b/contrib/lisp/org-bullets.el new file mode 100644 index 0000000..2951bf8 --- /dev/null +++ b/contrib/lisp/org-bullets.el @@ -0,0 +1,122 @@ +;;; 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 new file mode 100644 index 0000000..2bc00c0 --- /dev/null +++ b/contrib/lisp/org-checklist.el @@ -0,0 +1,141 @@ +;;; org-checklist.el --- org functions for checklist handling + +;; Copyright (C) 2008-2014 James TD Smith + +;; Author: James TD Smith (@ ahktenzero (. mohorovi cc)) +;; Version: 1.0 +;; Keywords: org, checklists +;; +;; 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: + +;; This file provides some functions for handing repeated tasks which involve +;; checking off a list of items. By setting the RESET_CHECK_BOXES property in an +;; item, when the TODO state is set to done all checkboxes under that item are +;; cleared. If the LIST_EXPORT_BASENAME property is set, a file will be created +;; using the value of that property plus a timestamp, containing all the items +;; in the list which are not checked. Additionally the user will be prompted to +;; print the list. +;; +;; I use this for to keep track of stores of various things (food stores, +;; components etc) which I check periodically and use the exported list of items +;; which are not present as a shopping list. +;; +;;; Usage: +;; (require 'org-checklist) +;; +;; Set the RESET_CHECK_BOXES and LIST_EXPORT_BASENAME properties in items as +;; needed. +;; +;;; Code: +(require 'org) +(load "a2ps-print" 'no-error) + +(setq org-default-properties (cons "RESET_CHECK_BOXES" (cons "LIST_EXPORT_BASENAME" org-default-properties))) + +(defgroup org-checklist nil + "Extended checklist handling for org" + :tag "Org-checklist" + :group 'org) + +(defcustom org-checklist-export-time-format "%Y%m%d%H%M" + "The format of timestamp appended to LIST_EXPORT_BASENAME to + make the name of the export file." + :link '(function-link format-time-string) + :group 'org-checklist + :type 'string) + +(defcustom org-checklist-export-function 'org-export-as-ascii + "function used to prepare the export file for printing" + :group 'org-checklist + :type '(radio (function-item :tag "ascii text" org-export-as-ascii) + (function-item :tag "HTML" org-export-as-html) + (function-item :tag "LaTeX" :value org-export-as-latex) + (function-item :tag "XOXO" :value org-export-as-xoxo))) + +(defcustom org-checklist-export-params nil + "options for the export function file for printing" + :group 'org-checklist + :type '(repeat string)) + +(defcustom org-checklist-a2ps-params nil + "options for a2ps for printing" + :group 'org-checklist + :type '(repeat string)) + +(defun org-reset-checkbox-state-maybe () + "Reset all checkboxes in an entry if the `RESET_CHECK_BOXES' property is set" + (interactive "*") + (if (org-entry-get (point) "RESET_CHECK_BOXES") + (org-reset-checkbox-state-subtree))) + + +(defun org-make-checklist-export () + "Produce a checklist containing all unchecked items from a list +of checkbox items" + (interactive "*") + (if (org-entry-get (point) "LIST_EXPORT_BASENAME") + (let* ((export-file (concat (org-entry-get (point) "LIST_EXPORT_BASENAME" nil) + "-" (format-time-string + org-checklist-export-time-format) + ".org")) + (print (case (org-entry-get (point) "PRINT_EXPORT" nil) + (("" "nil" nil) nil) + (t t) + (nil (y-or-n-p "Print list? ")))) + exported-lines + (title "Checklist export")) + (save-restriction + (save-excursion + (org-narrow-to-subtree) + (org-update-checkbox-count-maybe) + (org-show-subtree) + (goto-char (point-min)) + (when (looking-at org-complex-heading-regexp) + (setq title (match-string 4))) + (goto-char (point-min)) + (let ((end (point-max))) + (while (< (point) end) + (when (and (org-at-item-checkbox-p) + (or (string= (match-string 0) "[ ]") + (string= (match-string 0) "[-]"))) + (add-to-list 'exported-lines (thing-at-point 'line) t)) + (beginning-of-line 2))) + (set-buffer (get-buffer-create export-file)) + (org-insert-heading) + (insert (or title export-file) "\n") + (dolist (entry exported-lines) (insert entry)) + (org-update-checkbox-count-maybe) + (write-file export-file) + (if (print) + (progn (funcall org-checklist-export-function + org-checklist-export-params) + (let* ((current-a2ps-switches a2ps-switches) + (a2ps-switches (append current-a2ps-switches + org-checklist-a2ps-params))) + (a2ps-buffer))))))))) + +(defun org-checklist () + (when (member org-state org-done-keywords) ;; org-state dynamically bound in org.el/org-todo + (org-make-checklist-export) + (org-reset-checkbox-state-maybe))) + +(add-hook 'org-after-todo-state-change-hook 'org-checklist) + +(provide 'org-checklist) + +;;; org-checklist.el ends here diff --git a/contrib/lisp/org-choose.el b/contrib/lisp/org-choose.el new file mode 100644 index 0000000..c1006d0 --- /dev/null +++ b/contrib/lisp/org-choose.el @@ -0,0 +1,496 @@ +;;; org-choose.el --- decision management for org-mode + +;; Copyright (C) 2009-2014 Tom Breton (Tehom) + +;; This file is not part of GNU Emacs. + +;; Author: Tom Breton (Tehom) +;; Keywords: outlines, convenience + +;; This file 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 file 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., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This is code to support decision management. It lets you treat a +;; group of sibling items in org-mode as alternatives in a decision. + +;; There are no user commands in this file. You use it by: +;; * Loading it (manually or by M-x customize-apropos org-modules) + +;; * Setting up at least one set of TODO keywords with the +;; interpretation "choose" by either: + +;; * Using the file directive #+CHOOSE_TODO: + +;; * For instance, "#+CHOOSE_TODO: NO(,-) MAYBE(,0) YES" + +;; * Or by M-x customize-apropos org-todo-keywords + +;; * Operating on single items with the TODO commands. + +;; * Use C-S-right to change the keyword set. Use this to change to +;; the "choose" keyword set that you just defined. + +;; * Use S-right to advance the TODO mark to the next setting. + +;; For "choose", that means you like this alternative more than +;; before. Other alternatives will be automatically demoted to +;; keep your settings consistent. + +;; * Use S-left to demote TODO to the previous setting. + +;; For "choose", that means you don't like this alternative as much +;; as before. Other alternatives will be automatically promoted, +;; if this item was all that was keeping them down. + +;; * All the other TODO commands are available and behave essentially +;; the normal way. + +;;; Requires + +(require 'org) + ;(eval-when-compile + ; (require 'cl)) +(require 'cl) + +;;; Body +;;; The variables + +(defstruct (org-choose-mark-data. (:type list)) + "The format of an entry in org-choose-mark-data. +Indexes are 0-based or `nil'. +" + keyword + bot-lower-range + top-upper-range + range-length + static-default + all-keywords) + +(defvar org-choose-mark-data + () + "Alist of information for choose marks. + +Each entry is an `org-choose-mark-data.'" ) +(make-variable-buffer-local 'org-choose-mark-data) +;;;_ , For setup +;;;_ . org-choose-filter-one + +(defun org-choose-filter-one (i) + "Return a list of + * a canonized version of the string + * optionally one symbol" + + (if + (not + (string-match "(.*)" i)) + (list i i) + (let* + ( + (end-text (match-beginning 0)) + (vanilla-text (substring i 0 end-text)) + ;;Get the parenthesized part. + (match (match-string 0 i)) + ;;Remove the parentheses. + (args (substring match 1 -1)) + ;;Split it + (arglist + (let + ((arglist-x (org-split-string args ","))) + ;;When string starts with "," `split-string' doesn't + ;;make a first arg, so in that case make one + ;;manually. + (if + (string-match "^," args) + (cons nil arglist-x) + arglist-x))) + (decision-arg (second arglist)) + (type + (cond + ((string= decision-arg "0") + 'default-mark) + ((string= decision-arg "+") + 'top-upper-range) + ((string= decision-arg "-") + 'bot-lower-range) + (t nil))) + (vanilla-arg (first arglist)) + (vanilla-mark + (if vanilla-arg + (concat vanilla-text "("vanilla-arg")") + vanilla-text))) + (if type + (list vanilla-text vanilla-mark type) + (list vanilla-text vanilla-mark))))) + +;;;_ . org-choose-setup-vars +(defun org-choose-setup-vars (bot-lower-range top-upper-range + static-default num-items all-mark-texts) + "Add to org-choose-mark-data according to arguments" + (let* + ((tail + ;;If there's no bot-lower-range or no default, we don't + ;;have ranges. + (cdr + (if (and static-default bot-lower-range) + (let* + ;;If there's no top-upper-range, use the last + ;;item. + ((top-upper-range + (or top-upper-range (1- num-items))) + (lower-range-length + (1+ (- static-default bot-lower-range))) + (upper-range-length + (- top-upper-range static-default)) + (range-length + (min upper-range-length lower-range-length))) + (make-org-choose-mark-data. + :keyword nil + :bot-lower-range bot-lower-range + :top-upper-range top-upper-range + :range-length range-length + :static-default static-default + :all-keywords all-mark-texts)) + (make-org-choose-mark-data. + :keyword nil + :bot-lower-range nil + :top-upper-range nil + :range-length nil + :static-default (or static-default 0) + :all-keywords all-mark-texts))))) + (dolist (text all-mark-texts) + (pushnew (cons text tail) + org-choose-mark-data + :test + #'(lambda (a b) + (equal (car a) (car b))))))) + +;;; org-choose-filter-tail +(defun org-choose-filter-tail (raw) + "Return a translation of RAW to vanilla and set appropriate +buffer-local variables. + +RAW is a list of strings representing the input text of a choose +interpretation." + (let + ((vanilla-list nil) + (all-mark-texts nil) + (index 0) + bot-lower-range top-upper-range range-length static-default) + (dolist (i raw) + (destructuring-bind + (vanilla-text vanilla-mark &optional type) + (org-choose-filter-one i) + (cond + ((eq type 'bot-lower-range) + (setq bot-lower-range index)) + ((eq type 'top-upper-range) + (setq top-upper-range index)) + ((eq type 'default-mark) + (setq static-default index))) + (incf index) + (push vanilla-text all-mark-texts) + (push vanilla-mark vanilla-list))) + + (org-choose-setup-vars bot-lower-range top-upper-range + static-default index (reverse all-mark-texts)) + (nreverse vanilla-list))) + +;;; org-choose-setup-filter + +(defun org-choose-setup-filter (raw) + "A setup filter for choose interpretations." + (when (eq (car raw) 'choose) + (cons + 'choose + (org-choose-filter-tail (cdr raw))))) + +;;; org-choose-conform-after-promotion +(defun org-choose-conform-after-promotion (entry-pos keywords highest-ok-ix) + "Conform the current item after another item was promoted" + (unless + ;;Skip the entry that triggered this by skipping any entry with + ;;the same starting position. plist uses the start of the + ;;header line as the position, but map no longer does, so we + ;;have to go back to the heading. + (= + (save-excursion + (org-back-to-heading) + (point)) + entry-pos) + (let + ((ix + (org-choose-get-entry-index keywords))) + ;;If the index of the entry exceeds the highest allowable + ;;index, change it to that. + (when (and ix + (> ix highest-ok-ix)) + (org-todo + (nth highest-ok-ix keywords)))))) +;;;_ . org-choose-conform-after-demotion +(defun org-choose-conform-after-demotion (entry-pos keywords + raise-to-ix + old-highest-ok-ix) + "Conform the current item after another item was demoted." + (unless + ;;Skip the entry that triggered this. + (= + (save-excursion + (org-back-to-heading) + (point)) + entry-pos) + (let + ((ix + (org-choose-get-entry-index keywords))) + ;;If the index of the entry was at or above the old allowable + ;;position, change it to the new mirror position if there is + ;;one. + (when (and + ix + raise-to-ix + (>= ix old-highest-ok-ix)) + (org-todo + (nth raise-to-ix keywords)))))) + +;;; org-choose-keep-sensible (the org-trigger-hook function) +(defun org-choose-keep-sensible (change-plist) + "Bring the other items back into a sensible state after an item's +setting was changed." + (let* + ( (from (plist-get change-plist :from)) + (to (plist-get change-plist :to)) + (entry-pos + (set-marker + (make-marker) + (plist-get change-plist :position))) + (kwd-data + (assoc to org-todo-kwd-alist))) + (when + (eq (nth 1 kwd-data) 'choose) + (let* + ( + (data + (assoc to org-choose-mark-data)) + (keywords + (org-choose-mark-data.-all-keywords data)) + (old-index + (org-choose-get-index-in-keywords + from + keywords)) + (new-index + (org-choose-get-index-in-keywords + to + keywords)) + (highest-ok-ix + (org-choose-highest-other-ok + new-index + data)) + (funcdata + (cond + ;;The entry doesn't participate in conformance, + ;;so give `nil' which does nothing. + ((not highest-ok-ix) nil) + ;;The entry was created or promoted + ((or + (not old-index) + (> new-index old-index)) + (list + #'org-choose-conform-after-promotion + entry-pos keywords + highest-ok-ix)) + (t ;;Otherwise the entry was demoted. + (let + ( + (raise-to-ix + (min + highest-ok-ix + (org-choose-mark-data.-static-default + data))) + (old-highest-ok-ix + (org-choose-highest-other-ok + old-index + data))) + (list + #'org-choose-conform-after-demotion + entry-pos + keywords + raise-to-ix + old-highest-ok-ix)))))) + (if funcdata + ;;The funny-looking names are to make variable capture + ;;unlikely. (Poor-man's lexical bindings). + (destructuring-bind (func-d473 . args-46k) funcdata + (let + ((map-over-entries + (org-choose-get-fn-map-group)) + ;;We may call `org-todo', so let various hooks + ;;`nil' so we don't cause loops. + org-after-todo-state-change-hook + org-trigger-hook + org-blocker-hook + org-todo-get-default-hook + ;;Also let this alist `nil' so we don't log + ;;secondary transitions. + org-todo-log-states) + ;;Map over group + (funcall map-over-entries + #'(lambda () + (apply func-d473 args-46k)))))))) + ;;Remove the marker + (set-marker entry-pos nil))) + +;;; Getting the default mark +;;; org-choose-get-index-in-keywords +(defun org-choose-get-index-in-keywords (ix all-keywords) + "Return the index of the current entry." + (if ix + (position ix all-keywords + :test #'equal))) + +;;; org-choose-get-entry-index +(defun org-choose-get-entry-index (all-keywords) + "Return index of current entry." + (let* + ((state (org-entry-get (point) "TODO"))) + (org-choose-get-index-in-keywords state all-keywords))) + +;;; org-choose-get-fn-map-group + +(defun org-choose-get-fn-map-group () + "Return a function to map over the group" + #'(lambda (fn) + (require 'org-agenda) ;; `org-map-entries' seems to need it. + (save-excursion + (unless (org-up-heading-safe) + (error "Choosing is only supported between siblings in a tree, not on top level")) + (let + ((level (org-reduced-level (org-outline-level)))) + (save-restriction + (org-map-entries + fn + (format "LEVEL=%d" level) + 'tree)))))) + +;;; org-choose-get-highest-mark-index + +(defun org-choose-get-highest-mark-index (keywords) + "Get the index of the highest current mark in the group. +If there is none, return 0" + (let* + ;;Func maps over applicable entries. + ((map-over-entries + (org-choose-get-fn-map-group)) + (indexes-list + (remove nil + (funcall map-over-entries + #'(lambda () + (org-choose-get-entry-index keywords)))))) + (if + indexes-list + (apply #'max indexes-list) + 0))) + +;;; org-choose-highest-ok + +(defun org-choose-highest-other-ok (ix data) + "Return the highest index that any choose mark can sensibly have, +given that another mark has index IX. +DATA must be a `org-choose-mark-data.'." + (let + ((bot-lower-range + (org-choose-mark-data.-bot-lower-range data)) + (top-upper-range + (org-choose-mark-data.-top-upper-range data)) + (range-length + (org-choose-mark-data.-range-length data))) + (when (and ix bot-lower-range) + (let* + ((delta + (- top-upper-range ix))) + (unless + (< range-length delta) + (+ bot-lower-range delta)))))) + +;;; org-choose-get-default-mark-index + +(defun org-choose-get-default-mark-index (data) + "Return the index of the default mark in a choose interpretation. + +DATA must be a `org-choose-mark-data.'." + (or + (let + ((highest-mark-index + (org-choose-get-highest-mark-index + (org-choose-mark-data.-all-keywords data)))) + (org-choose-highest-other-ok + highest-mark-index data)) + (org-choose-mark-data.-static-default data))) + +;;; org-choose-get-mark-N +(defun org-choose-get-mark-N (n data) + "Get the text of the nth mark in a choose interpretation." + + (let* + ((l (org-choose-mark-data.-all-keywords data))) + (nth n l))) + +;;; org-choose-get-default-mark + +(defun org-choose-get-default-mark (new-mark old-mark) + "Get the default mark IFF in a choose interpretation. +NEW-MARK and OLD-MARK are the text of the new and old marks." + (let* + ((old-kwd-data + (assoc old-mark org-todo-kwd-alist)) + (new-kwd-data + (assoc new-mark org-todo-kwd-alist)) + (becomes-choose + (and + (or + (not old-kwd-data) + (not + (eq (nth 1 old-kwd-data) 'choose))) + (eq (nth 1 new-kwd-data) 'choose)))) + (when + becomes-choose + (let + ((new-mark-data + (assoc new-mark org-choose-mark-data))) + (if + new-mark + (org-choose-get-mark-N + (org-choose-get-default-mark-index + new-mark-data) + new-mark-data) + (error "Somehow got an unrecognizable mark")))))) + +;;; Setting it all up + +(eval-after-load "org" + '(progn + (add-to-list 'org-todo-setup-filter-hook + #'org-choose-setup-filter) + (add-to-list 'org-todo-get-default-hook + #'org-choose-get-default-mark) + (add-to-list 'org-trigger-hook + #'org-choose-keep-sensible) + (add-to-list 'org-todo-interpretation-widgets + '(:tag "Choose (to record decisions)" choose) + 'append))) + +(provide 'org-choose) + +;;; org-choose.el ends here diff --git a/contrib/lisp/org-collector.el b/contrib/lisp/org-collector.el new file mode 100644 index 0000000..10ec0cb --- /dev/null +++ b/contrib/lisp/org-collector.el @@ -0,0 +1,231 @@ +;;; org-collector --- collect properties into tables + +;; Copyright (C) 2008-2017 Free Software Foundation, Inc. + +;; Author: Eric Schulte <schulte dot eric at gmail dot com> +;; Keywords: outlines, hypermedia, calendar, wp, experimentation, +;; organization, properties +;; Homepage: http://orgmode.org +;; Version: 0.01 + +;; This file is not yet part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Pass in an alist of columns, each column can be either a single +;; property or a function which takes column names as arguments. +;; +;; For example the following propview block would collect the value of +;; the 'amount' property from each header in the current buffer +;; +;; #+BEGIN: propview :cols (ITEM amount) +;; | "ITEM" | "amount" | +;; |---------------------+----------| +;; | "December Spending" | 0 | +;; | "Grocery Store" | 56.77 | +;; | "Athletic club" | 75.0 | +;; | "Restaurant" | 30.67 | +;; | "January Spending" | 0 | +;; | "Athletic club" | 75.0 | +;; | "Restaurant" | 50.00 | +;; |---------------------+----------| +;; | | | +;; #+END: +;; +;; This slightly more selective propview block will limit those +;; headers included to those in the subtree with the id 'december' +;; in which the spendtype property is equal to "food" +;; +;; #+BEGIN: propview :id "december" :conds ((string= spendtype "food")) :cols (ITEM amount) +;; | "ITEM" | "amount" | +;; |-----------------+----------| +;; | "Grocery Store" | 56.77 | +;; | "Restaurant" | 30.67 | +;; |-----------------+----------| +;; | | | +;; #+END: +;; +;; Org Collector allows arbitrary processing of the property values +;; through elisp in the cols: property. This allows for both simple +;; computations as in the following example +;; +;; #+BEGIN: propview :id "results" :cols (ITEM f d list (apply '+ list) (+ f d)) +;; | "ITEM" | "f" | "d" | "list" | "(apply (quote +) list)" | "(+ f d)" | +;; |--------+-----+-----+-------------------------+--------------------------+-----------| +;; | "run1" | 2 | 33 | (quote (9 2 3 4 5 6 7)) | 36 | 35 | +;; | "run2" | 2 | 34 | :na | :na | 36 | +;; | "run3" | 2 | 35 | :na | :na | 37 | +;; | "run4" | 2 | 36 | :na | :na | 38 | +;; | | | | | | | +;; #+END: +;; +;; or more complex computations as in the following example taken from +;; an org file where each header in "results" subtree contained a +;; property "sorted_hits" which was passed through the +;; "average-precision" elisp function +;; +;; #+BEGIN: propview :id "results" :cols (ITEM (average-precision sorted_hits)) +;; | "ITEM" | "(average-precision sorted_hits)" | +;; |-----------+-----------------------------------| +;; | run (80) | 0.105092 | +;; | run (70) | 0.108142 | +;; | run (10) | 0.111348 | +;; | run (60) | 0.113593 | +;; | run (50) | 0.116446 | +;; | run (100) | 0.118863 | +;; #+END: +;; + +;;; Code: +(require 'org) +(require 'org-table) + +(defvar org-propview-default-value 0 + "Default value to insert into the propview table when the no +value is calculated either through lack of required variables for +a column, or through the generation of an error.") + +(defun and-rest (list) + (if (listp list) + (if (> (length list) 1) + (and (car list) (and-rest (cdr list))) + (car list)) + list)) + +(put 'org-collector-error + 'error-conditions + '(error column-prop-error org-collector-error)) + +(defun org-dblock-write:propview (params) + "collect the column specification from the #+cols line +preceeding the dblock, then update the contents of the dblock." + (interactive) + (condition-case er + (let ((cols (plist-get params :cols)) + (inherit (plist-get params :inherit)) + (conds (plist-get params :conds)) + (match (plist-get params :match)) + (scope (plist-get params :scope)) + (noquote (plist-get params :noquote)) + (colnames (plist-get params :colnames)) + (defaultval (plist-get params :defaultval)) + (content-lines (org-split-string (plist-get params :content) "\n")) + id table line pos) + (save-excursion + (when (setq id (plist-get params :id)) + (cond ((not id) nil) + ((eq id 'global) (goto-char (point-min))) + ((eq id 'local) nil) + ((setq idpos (org-find-entry-with-id id)) + (goto-char idpos)) + (t (error "Cannot find entry with :ID: %s" id)))) + (unless (eq id 'global) (org-narrow-to-subtree)) + (setq stringformat (if noquote "%s" "%S")) + (let ((org-propview-default-value (if defaultval defaultval org-propview-default-value))) + (setq table (org-propview-to-table + (org-propview-collect cols stringformat conds match scope inherit + (if colnames colnames cols)) stringformat))) + (widen)) + (setq pos (point)) + (when content-lines + (while (string-match "^#" (car content-lines)) + (insert (pop content-lines) "\n"))) + (insert table) (insert "\n|--") (org-cycle) (move-end-of-line 1) + (message (format "point-%d" pos)) + (while (setq line (pop content-lines)) + (when (string-match "^#" line) + (insert "\n" line))) + (goto-char pos) + (org-table-recalculate 'all)) + (org-collector-error (widen) (error "%s" er)) + (error (widen) (error "%s" er)))) + +(defun org-propview-eval-w-props (props body) + "evaluate the BODY-FORMS binding the variables using the +variables and values specified in props" + (condition-case nil ;; catch any errors + (eval `(let ,(mapcar + (lambda (pair) (list (intern (car pair)) (cdr pair))) + props) + ,body)) + (error nil))) + +(defun org-propview-get-with-inherited (&optional inherit) + (append + (org-entry-properties) + (delq nil + (mapcar (lambda (i) + (let* ((n (symbol-name i)) + (p (org-entry-get (point) n 'do-inherit))) + (when p (cons n p)))) + inherit)))) + +(defun org-propview-collect (cols stringformat &optional conds match scope inherit colnames) + (interactive) + ;; collect the properties from every header + (let* ((header-props + (let ((org-trust-scanner-tags t) alst) + (org-map-entries + (quote (cons (cons "ITEM" (org-get-heading t)) + (org-propview-get-with-inherited inherit))) + match scope))) + ;; read property values + (header-props + (mapcar (lambda (props) + (mapcar (lambda (pair) + (cons (car pair) (org-babel-read (cdr pair)))) + props)) + header-props)) + ;; collect all property names + (prop-names + (mapcar 'intern (delete-dups + (apply 'append (mapcar (lambda (header) + (mapcar 'car header)) + header-props)))))) + (append + (list + (if colnames colnames (mapcar (lambda (el) (format stringformat el)) cols)) + 'hline) ;; ------------------------------------------------ + (mapcar ;; calculate the value of the column for each header + (lambda (props) (mapcar (lambda (col) + (let ((result (org-propview-eval-w-props props col))) + (if result result org-propview-default-value))) + cols)) + (if conds + ;; eliminate the headers which don't satisfy the property + (delq nil + (mapcar + (lambda (props) + (if (and-rest (mapcar + (lambda (col) + (org-propview-eval-w-props props col)) + conds)) + props)) + header-props)) + header-props))))) + +(defun org-propview-to-table (results stringformat) + ;; (message (format "cols:%S" cols)) + (orgtbl-to-orgtbl + (mapcar + (lambda (row) + (if (equal row 'hline) + 'hline + (mapcar (lambda (el) (format stringformat el)) row))) + (delq nil results)) '())) + +(provide 'org-collector) +;;; org-collector ends here diff --git a/contrib/lisp/org-contacts.el b/contrib/lisp/org-contacts.el new file mode 100644 index 0000000..2cadd1d --- /dev/null +++ b/contrib/lisp/org-contacts.el @@ -0,0 +1,1150 @@ +;;; org-contacts.el --- Contacts management + +;; Copyright (C) 2010-2014 Julien Danjou <julien@danjou.info> + +;; Author: Julien Danjou <julien@danjou.info> +;; Keywords: outlines, hypermedia, calendar +;; +;; This file is NOT part of GNU Emacs. +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file contains the code for managing your contacts into Org-mode. + +;; To enter new contacts, you can use `org-capture' and a minimal template just like +;; this: + +;; ("c" "Contacts" entry (file "~/Org/contacts.org") +;; "* %(org-contacts-template-name) +;; :PROPERTIES: +;; :EMAIL: %(org-contacts-template-email) +;; :END:"))) +;; +;; You can also use a complex template, for example: +;; +;; ("c" "Contacts" entry (file "~/Org/contacts.org") +;; "* %(org-contacts-template-name) +;; :PROPERTIES: +;; :EMAIL: %(org-contacts-template-email) +;; :PHONE: +;; :ALIAS: +;; :NICKNAME: +;; :IGNORE: +;; :ICON: +;; :NOTE: +;; :ADDRESS: +;; :BIRTHDAY: +;; :END:"))) +;; +;;; Code: + +(require 'cl-lib) +(require 'org) +(require 'gnus-util) +(require 'gnus-art) +(require 'mail-utils) +(require 'org-agenda) +(require 'org-capture) + +(defgroup org-contacts nil + "Options about contacts management." + :group 'org) + +(defcustom org-contacts-files nil + "List of Org files to use as contacts source. +When set to nil, all your Org files will be used." + :type '(repeat file) + :group 'org-contacts) + +(defcustom org-contacts-email-property "EMAIL" + "Name of the property for contact email address." + :type 'string + :group 'org-contacts) + +(defcustom org-contacts-tel-property "PHONE" + "Name of the property for contact phone number." + :type 'string + :group 'org-contacts) + +(defcustom org-contacts-address-property "ADDRESS" + "Name of the property for contact address." + :type 'string + :group 'org-contacts) + +(defcustom org-contacts-birthday-property "BIRTHDAY" + "Name of the property for contact birthday date." + :type 'string + :group 'org-contacts) + +(defcustom org-contacts-note-property "NOTE" + "Name of the property for contact note." + :type 'string + :group 'org-contacts) + +(defcustom org-contacts-alias-property "ALIAS" + "Name of the property for contact name alias." + :type 'string + :group 'org-contacts) + +(defcustom org-contacts-ignore-property "IGNORE" + "Name of the property, which values will be ignored when +completing or exporting to vcard." + :type 'string + :group 'org-contacts) + + +(defcustom org-contacts-birthday-format "Birthday: %l (%Y)" + "Format of the anniversary agenda entry. +The following replacements are available: + + %h - Heading name + %l - Link to the heading + %y - Number of year + %Y - Number of year (ordinal)" + :type 'string + :group 'org-contacts) + +(defcustom org-contacts-last-read-mail-property "LAST_READ_MAIL" + "Name of the property for contact last read email link storage." + :type 'string + :group 'org-contacts) + +(defcustom org-contacts-icon-property "ICON" + "Name of the property for contact icon." + :type 'string + :group 'org-contacts) + +(defcustom org-contacts-nickname-property "NICKNAME" + "Name of the property for IRC nickname match." + :type 'string + :group 'org-contacts) + +(defcustom org-contacts-icon-size 32 + "Size of the contacts icons." + :type 'string + :group 'org-contacts) + +(defcustom org-contacts-icon-use-gravatar (fboundp 'gravatar-retrieve) + "Whether use Gravatar to fetch contact icons." + :type 'boolean + :group 'org-contacts) + +(defcustom org-contacts-completion-ignore-case t + "Ignore case when completing contacts." + :type 'boolean + :group 'org-contacts) + +(defcustom org-contacts-group-prefix "+" + "Group prefix." + :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 + (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 + :group 'org-contacts) + +(defcustom org-contacts-email-link-description-format "%s (%d)" + "Format used to store links to email. +This overrides `org-email-link-description-format' if set." + :group 'org-contacts + :type 'string) + +(defcustom org-contacts-vcard-file "contacts.vcf" + "Default file for vcard export." + :group 'org-contacts + :type 'file) + +(defcustom org-contacts-enable-completion t + "Enable or not the completion in `message-mode' with `org-contacts'." + :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") +(declare-function wl-summary-message-number "ext:wl-summary") +(declare-function wl-address-header-extract-address "ext:wl-address") +(declare-function wl-address-header-extract-realname "ext:wl-address") +(declare-function erc-buffer-list "ext:erc") +(declare-function erc-get-channel-user-list "ext:erc") +(declare-function google-maps-static-show "ext:google-maps-static") +(declare-function elmo-message-field "ext:elmo-pipe") +(declare-function std11-narrow-to-header "ext:std11") +(declare-function std11-fetch-field "ext:std11") + +(defconst org-contacts-property-values-separators "[,; \f\t\n\r\v]+" + "The default value of separators for `org-contacts-split-property'. + +A regexp matching strings of whitespace, `,' and `;'.") + +(defvar org-contacts-keymap + (let ((map (make-sparse-keymap))) + (define-key map "M" 'org-contacts-view-send-email) + (define-key map "i" 'org-contacts-view-switch-to-irc-buffer) + map) + "The keymap used in `org-contacts' result list.") + +(defvar org-contacts-db nil + "Org Contacts database.") + +(defvar org-contacts-last-update nil + "Last time the Org Contacts database has been updated.") + +(defun org-contacts-files () + "Return list of Org files to use for contact management." + (or org-contacts-files (org-agenda-files t 'ifmode))) + +(defun org-contacts-db-need-update-p () + "Determine whether `org-contacts-db' needs to be refreshed." + (or (null org-contacts-last-update) + (cl-find-if (lambda (file) + (or (time-less-p org-contacts-last-update + (elt (file-attributes file) 5)))) + (org-contacts-files)) + (org-contacts-db-has-dead-markers-p org-contacts-db))) + +(defun org-contacts-db-has-dead-markers-p (org-contacts-db) + "Returns t if at least one dead marker is found in +ORG-CONTACTS-DB. A dead marker in this case is a marker pointing +to dead or no buffer." + ;; Scan contacts list looking for dead markers, and return t at first found. + (catch 'dead-marker-found + (while org-contacts-db + (unless (marker-buffer (nth 1 (car org-contacts-db))) + (throw 'dead-marker-found t)) + (setq org-contacts-db (cdr org-contacts-db))) + nil)) + +(defun org-contacts-db () + "Return the latest Org Contacts Database." + (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)) + (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)))) + (setf org-contacts-db result + org-contacts-last-update (current-time)) + (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. + +The optional PROP-MATCH argument is a single (PROP . VALUE) cons +cell corresponding to the contact properties. +" + (if (and (null name-match) + (null prop-match) + (null tags-match)) + (org-contacts-db) + (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... + (defun completion-table-case-fold (table &optional dont-fold) + (lambda (string pred action) + (let ((completion-ignore-case (not dont-fold))) + (complete-with-action action table string pred))))) + +(defun org-contacts-try-completion-prefix (to-match collection &optional predicate) + "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." + (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'. + +This function works like `compare-strings' excepted that it +returns a cons. +- The CAR is the number of characters that match at the beginning. +- The CDR is T is the two strings are the same and NIL otherwise." + (let ((ret (compare-strings s1 start1 end1 s2 start2 end2 ignore-case))) + (if (eq ret t) + (cons (or end1 (length s1)) t) + (cons (1- (abs ret)) nil)))) + +(defun org-contacts-common-substring (s1 start1 end1 s2 start2 end2) + "Extract the common substring between S1 and S2. + +This function extracts the common substring between S1 and S2 and +adjust the part that remains common. + +START1 and END1 delimit the part in S1 that we know is common +between the two strings. This applies to START2 and END2 for S2. + +This function returns a list whose contains: +- The common substring found. +- The new value of the start of the known inner substring. +- The new value of the end of the known inner substring." + ;; Given two strings: + ;; s1: "foo bar baz" + ;; s2: "fooo bar baz" + ;; and the inner substring is "bar" + ;; then: start1 = 4, end1 = 6, start2 = 5, end2 = 7 + ;; + ;; To find the common substring we will compare two substrings: + ;; " oof" and " ooof" to find the beginning of the common substring. + ;; " baz" and " baz" to find the end of the common substring. + (let* ((len1 (length s1)) + (start1 (or start1 0)) + (end1 (or end1 len1)) + + (len2 (length s2)) + (start2 (or start2 0)) + (end2 (or end2 len2)) + + (new-start (car (org-contacts-compare-strings + (substring (org-reverse-string s1) (- len1 start1)) nil nil + (substring (org-reverse-string s2) (- len2 start2)) nil nil))) + + (new-end (+ end1 (car (org-contacts-compare-strings + (substring s1 end1) nil nil + (substring s2 end2) nil nil))))) + (list (substring s1 (- start1 new-start) new-end) + new-start + (+ new-start (- end1 start1))))) + +(defun org-contacts-all-completions-prefix (to-match collection &optional predicate) + "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." + (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." + (lexical-let ((collection collection)) + (lambda (string predicate flag) + (cond ((eq flag nil) + (org-contacts-try-completion-prefix string collection predicate)) + ((eq flag t) + ;; `org-contacts-all-completions-prefix' has already been + ;; used to compute `all-completions'. + collection) + ((eq flag 'lambda) + (org-contacts-test-completion-prefix string collection predicate)) + ((and (listp flag) (eq (car flag) 'boundaries)) + (cl-destructuring-bind (to-ignore &rest suffix) + flag + (org-contacts-boundaries-prefix string collection predicate suffix))) + ((eq flag 'metadata) + (org-contacts-metadata-prefix string collection predicate)) + (t nil ; operation unsupported + ))))) + +(defun org-contacts-display-sort-function (completions) + "Sort function for contacts display." + (mapcar (lambda (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) + (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))) + +(defun org-contacts-metadata-prefix (string collection predicate) + '(metadata . + ((cycle-sort-function . org-contacts-display-sort-function) + (display-sort-function . org-contacts-display-sort-function)))) + +(defun org-contacts-complete-group (start end string) + "Complete text at START from a group. + +A group FOO is composed of contacts with the tag FOO." + (let* ((completion-ignore-case org-contacts-completion-ignore-case) + (group-completion-p (string-match-p + (concat "^" org-contacts-group-prefix) string))) + (when group-completion-p + (let ((completion-list + (all-completions + string + (mapcar (lambda (group) + (propertize (concat org-contacts-group-prefix group) + 'org-contacts-group group)) + (org-uniquify + (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 + (lexical-let ((tag (get-text-property 0 'org-contacts-group + (car completion-list)))) + (lambda (string pred &optional to-ignore) + (mapconcat 'identity + (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." + (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 + (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)))) + (when completion-list + (list start end + (org-contacts-make-collection-prefix completion-list))))) + +(defun org-contacts-message-complete-function (&optional start) + "Function used in `completion-at-point-functions' in `message-mode'." + ;; Avoid to complete in `post-command-hook'. + (when completion-in-region-mode + (remove-hook 'post-command-hook #'completion-in-region--postch)) + (let ((mail-abbrev-mode-regexp + "^\\(Resent-To\\|To\\|B?Cc\\|Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\|Disposition-Notification-To\\|Return-Receipt-To\\):")) + (when (mail-abbrev-in-expansion-header-p) + (lexical-let* + ((end (point)) + (start (or start + (save-excursion + (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*") + (goto-char (match-end 0)) + (point)))) + (string (buffer-substring start end))) + (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." + (if (gnus-alive-p) + (gnus-with-article-headers + (mail-extract-address-components + (or (mail-fetch-field "From") ""))))) + +(defun org-contacts-gnus-article-from-get-marker () + "Return a marker for a contact based on From." + (let* ((address (org-contacts-gnus-get-name-email)) + (name (car address)) + (email (cadr address))) + (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." + (interactive) + (let ((marker (org-contacts-gnus-article-from-get-marker))) + (when marker + (switch-to-buffer-other-window (marker-buffer marker)) + (goto-char marker) + (when (eq major-mode 'org-mode) (org-show-context 'agenda))))) + +(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\". + +Format is a string matching the following format specification: + + %h - Heading name + %l - Link to the heading + %y - Number of year + %Y - Number of year (ordinal)" + (let ((calendar-date-style 'american) + (entry "")) + (unless format (setq format org-contacts-birthday-format)) + (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 + hist def inherit-input-method) + "Like `completing-read' but reads a date. +Only PROMPT and DEF are really used." + (org-read-date nil nil nil prompt nil def)) + +(add-to-list 'org-property-set-functions-alist + `(,org-contacts-birthday-property . org-completing-read-date)) + +(defun org-contacts-template-name (&optional return-value) + "Try to return the contact name for a template. +If not found return RETURN-VALUE or something that would ask the user." + (or (car (org-contacts-gnus-get-name-email)) + return-value + "%^{Name}")) + +(defun org-contacts-template-email (&optional return-value) + "Try to return the contact email for a template. +If not found return RETURN-VALUE or something that would ask the user." + (or (cadr (org-contacts-gnus-get-name-email)) + return-value + (concat "%^{" org-contacts-email-property "}p"))) + +(defun org-contacts-gnus-store-last-mail () + "Store a link between mails and contacts. + +This function should be called from `gnus-article-prepare-hook'." + (let ((marker (org-contacts-gnus-article-from-get-marker))) + (when marker + (with-current-buffer (marker-buffer marker) + (save-excursion + (goto-char marker) + (let* ((org-email-link-description-format (or org-contacts-email-link-description-format + org-email-link-description-format)) + (link (gnus-with-article-buffer (org-store-link nil)))) + (org-set-property org-contacts-last-read-mail-property link))))))) + +(defun org-contacts-icon-as-string () + "Return the contact icon as a string." + (let ((image (org-contacts-get-icon))) + (concat + (propertize "-" 'display + (append + (if image + image + `'(space :width (,org-contacts-icon-size))) + '(:ascent center))) + " "))) + +;;;###autoload +(defun org-contacts (name) + "Create agenda view for contacts matching NAME." + (interactive (list (read-string "Name: "))) + (let ((org-agenda-files (org-contacts-files)) + (org-agenda-skip-function + (lambda () (org-agenda-skip-if nil `(notregexp ,name)))) + (org-agenda-prefix-format (propertize + "%(org-contacts-icon-as-string)% s%(org-contacts-irc-number-of-unread-messages) " + 'keymap org-contacts-keymap)) + (org-agenda-overriding-header + (or org-agenda-overriding-header + (concat "List of contacts matching `" name "':")))) + (setq org-agenda-skip-regexp name) + (org-tags-view nil org-contacts-matcher) + (with-current-buffer org-agenda-buffer-name + (setq org-agenda-redo-command + (list 'org-contacts name))))) + +(defun org-contacts-completing-read (prompt + &optional predicate + initial-input hist def inherit-input-method) + "Call `completing-read' with contacts name as collection." + (org-completing-read + prompt (org-contacts-filter) predicate t initial-input hist def inherit-input-method)) + +(defun org-contacts-format-name (name) + "Trim any local formatting to get a bare NAME." + ;; Remove radio targets characters + (replace-regexp-in-string org-radio-target-regexp "\\1" name)) + +(defun org-contacts-format-email (name email) + "Format an EMAIL address corresponding to NAME." + (unless email + (error "`email' cannot be nul")) + (if name + (concat (org-contacts-format-name name) " <" email ">") + email)) + +(defun org-contacts-check-mail-address (mail) + "Add MAIL address to contact at point if it does not have it." + (let ((mails (org-entry-get (point) org-contacts-email-property))) + (unless (member mail (split-string mails)) + (when (yes-or-no-p + (format "Do you want to add this address to %s?" (org-get-heading t))) + (org-set-property org-contacts-email-property (concat mails " " mail)))))) + +(defun org-contacts-gnus-check-mail-address () + "Check that contact has the current address recorded. +This function should be called from `gnus-article-prepare-hook'." + (let ((marker (org-contacts-gnus-article-from-get-marker))) + (when marker + (org-with-point-at marker + (org-contacts-check-mail-address (cadr (org-contacts-gnus-get-name-email))))))) + +(defun org-contacts-gnus-insinuate () + "Add some hooks for Gnus user. +This adds `org-contacts-gnus-check-mail-address' and +`org-contacts-gnus-store-last-mail' to +`gnus-article-prepare-hook'. It also adds a binding on `;' in +`gnus-summary-mode-map' to `org-contacts-gnus-article-from-goto'" + (require 'gnus) + (require 'gnus-art) + (define-key gnus-summary-mode-map ";" 'org-contacts-gnus-article-from-goto) + (add-hook 'gnus-article-prepare-hook 'org-contacts-gnus-check-mail-address) + (add-hook 'gnus-article-prepare-hook 'org-contacts-gnus-store-last-mail)) + +(defun org-contacts-setup-completion-at-point () + "Add `org-contacts-message-complete-function' as a new function +to complete the thing at point." + (add-to-list 'completion-at-point-functions + 'org-contacts-message-complete-function)) + +(defun org-contacts-unload-hook () + (remove-hook 'message-mode-hook 'org-contacts-setup-completion-at-point)) + +(when (and org-contacts-enable-completion + (boundp 'completion-at-point-functions)) + (add-hook 'message-mode-hook 'org-contacts-setup-completion-at-point)) + +(defun org-contacts-wl-get-from-header-content () + "Retrieve the content of the `From' header of an email. +Works from wl-summary-mode and mime-view-mode - that is while viewing email. +Depends on Wanderlust been loaded." + (with-current-buffer (org-capture-get :original-buffer) + (cond + ((eq major-mode 'wl-summary-mode) (when (and (boundp 'wl-summary-buffer-elmo-folder) + wl-summary-buffer-elmo-folder) + (elmo-message-field + wl-summary-buffer-elmo-folder + (wl-summary-message-number) + 'from))) + ((eq major-mode 'mime-view-mode) (std11-narrow-to-header) + (prog1 + (std11-fetch-field "From") + (widen)))))) + +(defun org-contacts-wl-get-name-email () + "Get name and email address from Wanderlust email. +See `org-contacts-wl-get-from-header-content' for limitations." + (let ((from (org-contacts-wl-get-from-header-content))) + (when from + (list (wl-address-header-extract-realname from) + (wl-address-header-extract-address from))))) + +(defun org-contacts-template-wl-name (&optional return-value) + "Try to return the contact name for a template from wl. +If not found, return RETURN-VALUE or something that would ask the +user." + (or (car (org-contacts-wl-get-name-email)) + return-value + "%^{Name}")) + +(defun org-contacts-template-wl-email (&optional return-value) + "Try to return the contact email for a template from Wanderlust. +If not found return RETURN-VALUE or something that would ask the user." + (or (cadr (org-contacts-wl-get-name-email)) + return-value + (concat "%^{" org-contacts-email-property "}p"))) + +(defun org-contacts-view-send-email (&optional ask) + "Send email to the contact at point. +If ASK is set, ask for the email address even if there's only one +address." + (interactive "P") + (let ((marker (org-get-at-bol 'org-hd-marker))) + (org-with-point-at marker + (let ((emails (org-entry-get (point) org-contacts-email-property))) + (if emails + (let ((email-list (org-contacts-split-property emails))) + (if (and (= (length email-list) 1) (not ask)) + (compose-mail (org-contacts-format-email + (org-get-heading t) emails)) + (let ((email (completing-read "Send mail to which address: " email-list))) + (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)" + org-contacts-email-property))))))) + +(defun org-contacts-get-icon (&optional pom) + "Get icon for contact at POM." + (setq pom (or pom (point))) + (catch 'icon + ;; Use `org-contacts-icon-property' + (let ((image-data (org-entry-get pom org-contacts-icon-property))) + (when image-data + (throw 'icon + (if (fboundp 'gnus-rescale-image) + (gnus-rescale-image (create-image image-data) + (cons org-contacts-icon-size org-contacts-icon-size)) + (create-image image-data))))) + ;; Next, try Gravatar + (when org-contacts-icon-use-gravatar + (let* ((gravatar-size org-contacts-icon-size) + (email-list (org-entry-get pom org-contacts-email-property)) + (gravatar + (when email-list + (loop for email in (org-contacts-split-property email-list) + for gravatar = (gravatar-retrieve-synchronously (org-contacts-strip-link email)) + if (and gravatar + (not (eq gravatar 'error))) + return gravatar)))) + (when gravatar (throw 'icon gravatar)))))) + +(defun org-contacts-irc-buffer (&optional pom) + "Get the IRC buffer associated with the entry at POM." + (setq pom (or pom (point))) + (let ((nick (org-entry-get pom org-contacts-nickname-property))) + (when nick + (let ((buffer (get-buffer nick))) + (when buffer + (with-current-buffer buffer + (when (eq major-mode 'erc-mode) + buffer))))))) + +(defun org-contacts-irc-number-of-unread-messages (&optional pom) + "Return the number of unread messages for contact at POM." + (when (boundp 'erc-modified-channels-alist) + (let ((number (cadr (assoc (org-contacts-irc-buffer pom) erc-modified-channels-alist)))) + (if number + (format (concat "%3d unread message" (if (> number 1) "s" " ") " ") number) + (make-string 21 ? ))))) + +(defun org-contacts-view-switch-to-irc-buffer () + "Switch to the IRC buffer of the current contact if it has one." + (interactive) + (let ((marker (org-get-at-bol 'org-hd-marker))) + (org-with-point-at marker + (switch-to-buffer-other-window (org-contacts-irc-buffer))))) + +(defun org-contacts-completing-read-nickname (prompt collection + &optional predicate require-match initial-input + hist def inherit-input-method) + "Like `completing-read' but reads a nickname." + (org-completing-read prompt (append collection (erc-nicknames-list)) predicate require-match + initial-input hist def inherit-input-method)) + +(defun erc-nicknames-list () + "Return all nicknames of all ERC buffers." + (loop for buffer in (erc-buffer-list) + nconc (with-current-buffer buffer + (loop for user-entry in (mapcar 'car (erc-get-channel-user-list)) + collect (elt user-entry 1))))) + +(add-to-list 'org-property-set-functions-alist + `(,org-contacts-nickname-property . org-contacts-completing-read-nickname)) + +(defun org-contacts-vcard-escape (str) + "Escape ; , and \n in STR for the VCard format." + ;; Thanks to this library for the regexp: + ;; http://www.emacswiki.org/cgi-bin/wiki/bbdb-vcard-export.el + (when str + (replace-regexp-in-string + "\n" "\\\\n" + (replace-regexp-in-string "\\(;\\|,\\|\\\\\\)" "\\\\\\1" str)))) + +(defun org-contacts-vcard-encode-name (name) + "Try to encode NAME as VCard's N property. +The N property expects + + FamilyName;GivenName;AdditionalNames;Prefix;Postfix. + +Org-contacts does not specify how to encode the name. So we try +to do our best." + (concat (replace-regexp-in-string "\\(\\w+\\) \\(.*\\)" "\\2;\\1" name) ";;;")) + +(defun org-contacts-vcard-format (contact) + "Formats CONTACT in VCard 3.0 format." + (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))) + (tel (cdr (assoc-string org-contacts-tel-property properties))) + (ignore-list (cdr (assoc-string org-contacts-ignore-property properties))) + (ignore-list (when ignore-list + (org-contacts-split-property ignore-list))) + (note (cdr (assoc-string org-contacts-note-property properties))) + (bday (org-contacts-vcard-escape (cdr (assoc-string org-contacts-birthday-property properties)))) + (addr (cdr (assoc-string org-contacts-address-property properties))) + (nick (org-contacts-vcard-escape (cdr (assoc-string org-contacts-nickname-property properties)))) + (head (format "BEGIN:VCARD\nVERSION:3.0\nN:%s\nFN:%s\n" n name)) + emails-list result phones-list) + (concat head + (when email (progn + (setq emails-list (org-contacts-remove-ignored-property-values ignore-list (org-contacts-split-property email))) + (setq result "") + (while emails-list + (setq result (concat result "EMAIL:" (org-contacts-strip-link (car emails-list)) "\n")) + (setq emails-list (cdr emails-list))) + result)) + (when addr + (format "ADR:;;%s\n" (replace-regexp-in-string "\\, ?" ";" addr))) + (when tel (progn + (setq phones-list (org-contacts-remove-ignored-property-values ignore-list (org-contacts-split-property tel))) + (setq result "") + (while phones-list + (setq result (concat result "TEL:" (org-link-unescape (org-contacts-strip-link (car phones-list))) "\n")) + (setq phones-list (cdr phones-list))) + result)) + (when bday + (let ((cal-bday (calendar-gregorian-from-absolute (org-time-string-to-absolute bday)))) + (format "BDAY:%04d-%02d-%02d\n" + (calendar-extract-year cal-bday) + (calendar-extract-month cal-bday) + (calendar-extract-day cal-bday)))) + (when nick (format "NICKNAME:%s\n" nick)) + (when note (format "NOTE:%s\n" note)) + "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." + (let* ((filename (or file org-contacts-vcard-file)) + (buffer (if to-buffer + (get-buffer-create to-buffer) + (find-file-noselect filename)))) + (message "Exporting...") + (set-buffer buffer) + (let ((inhibit-read-only t)) (erase-buffer)) + (fundamental-mode) + (when (fboundp 'set-buffer-file-coding-system) + (set-buffer-file-coding-system coding-system-for-write)) + (loop for contact in (org-contacts-filter name) + do (insert (org-contacts-vcard-format contact))) + (if to-buffer + (current-buffer) + (progn (save-buffer) (kill-buffer))))) + +(defun org-contacts-show-map (&optional name) + "Show contacts on a map. +Requires google-maps-el." + (interactive) + (unless (fboundp 'google-maps-static-show) + (error "`org-contacts-show-map' requires `google-maps-el'")) + (google-maps-static-show + :markers + (cl-loop + for contact in (org-contacts-filter name) + 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))))))) + +(defun org-contacts-strip-link (link) + "Remove brackets, description, link type and colon from an org +link string and return the pure link target." + (let (startpos colonpos endpos) + (setq startpos (string-match (regexp-opt '("[[tel:" "[[mailto:")) link)) + (if startpos + (progn + (setq colonpos (string-match ":" link)) + (setq endpos (string-match "\\]" link)) + (if endpos (substring link (1+ colonpos) endpos) link)) + (progn + (setq startpos (string-match "mailto:" link)) + (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 +for SEPARATORS but keep Org links intact. + +The beginning and end of STRING, and each match for SEPARATORS, are +splitting points. The substrings matching SEPARATORS are removed, and +the substrings between the splitting points are collected as a list, +which is returned. + +If SEPARATORS is non-nil, it should be a regular expression +matching text which separates, but is not part of, the +substrings. If nil it defaults to `org-contacts-property-values-separators', +normally \"[,; \f\t\n\r\v]+\", and OMIT-NULLS is forced to t. + +If OMIT-NULLS is t, zero-length substrings are omitted from the list \(so +that for the default value of SEPARATORS leading and trailing whitespace +are effectively trimmed). If nil, all zero-length substrings are retained." + (let* ((omit-nulls (if separators omit-nulls t)) + (rexp (or separators org-contacts-property-values-separators)) + (inputlist (split-string string rexp omit-nulls)) + (linkstring "") + (bufferstring "") + (proplist (list ""))) + (while inputlist + (setq bufferstring (pop inputlist)) + (if (string-match "\\[\\[" bufferstring) + (progn + (setq linkstring (concat bufferstring " ")) + (while (not (string-match "\\]\\]" bufferstring)) + (setq bufferstring (pop inputlist)) + (setq linkstring (concat linkstring bufferstring " "))) + (setq proplist (cons (org-trim linkstring) proplist))) + (setq proplist (cons bufferstring proplist)))) + (cdr (reverse proplist)))) + +(provide 'org-contacts) + +;;; org-contacts.el ends here diff --git a/contrib/lisp/org-contribdir.el b/contrib/lisp/org-contribdir.el new file mode 100644 index 0000000..4ad3116 --- /dev/null +++ b/contrib/lisp/org-contribdir.el @@ -0,0 +1,38 @@ +;;; org-contribdir.el --- Mark the location of the contrib directory +;; Copyright (C) 2009-2017 Free Software Foundation, Inc. +;; +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 0.01 +;; +;; This file is not yet part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; 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 sole purpose of this file is to be located in the same place +;; as where the contributed Org files are located, typically in the +;; contrib/lisp directory of the Org-mode distribution. This is to +;; make sure that the command `org-reload' can reliably locate +;; contributed org files. + +(provide 'org-contribdir) + +;;; org-contribdir.el ends here diff --git a/contrib/lisp/org-depend.el b/contrib/lisp/org-depend.el new file mode 100644 index 0000000..b6f3d27 --- /dev/null +++ b/contrib/lisp/org-depend.el @@ -0,0 +1,420 @@ +;;; org-depend.el --- TODO dependencies for Org-mode +;; Copyright (C) 2008-2017 Free Software Foundation, Inc. +;; +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 0.08 +;; +;; This file is not part of GNU Emacs. +;; +;; This file 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: +;; +;; WARNING: This file is just a PROOF OF CONCEPT, not a supported part +;; of Org-mode. +;; +;; This is an example implementation of TODO dependencies in Org-mode. +;; It uses the new hooks in version 5.13 of Org-mode, +;; `org-trigger-hook' and `org-blocker-hook'. +;; +;; It implements the following: +;; +;; Triggering +;; ---------- +;; +;; 1) If an entry contains a TRIGGER property that contains the string +;; "chain-siblings(KEYWORD)", then switching that entry to DONE does +;; do the following: +;; - The sibling following this entry switched to todo-state KEYWORD. +;; - The sibling also gets a TRIGGER property "chain-sibling(KEYWORD)", +;; property, to make sure that, when *it* is DONE, the chain will +;; continue. +;; +;; 2) If an entry contains a TRIGGER property that contains the string +;; "chain-siblings-scheduled", then switching that entry to DONE does +;; the following actions, similarly to "chain-siblings(KEYWORD)": +;; - The sibling receives the same scheduled time as the entry +;; marked as DONE (or, in the case, in which there is no scheduled +;; time, the sibling does not get any either). +;; - The sibling also gets the same TRIGGER property +;; "chain-siblings-scheduled", so the chain can continue. +;; +;; 3) If the TRIGGER property contains the string +;; "chain-find-next(KEYWORD[,OPTIONS])", then switching that entry +;; to DONE do the following: +;; - All siblings are of the entry are collected into a temporary +;; list and then filtered and sorted according to OPTIONS +;; - The first sibling on the list is changed into KEYWORD state +;; - The sibling also gets the same TRIGGER property +;; "chain-find-next", so the chain can continue. +;; +;; OPTIONS should be a comma separated string without spaces, and +;; can contain following options: +;; +;; - from-top the candidate list is all of the siblings in +;; the current subtree +;; +;; - from-bottom candidate list are all siblings from bottom up +;; +;; - from-current candidate list are all siblings from current item +;; until end of subtree, then wrapped around from +;; first sibling +;; +;; - no-wrap candidate list are siblings from current one down +;; +;; - todo-only Only consider siblings that have a todo keyword +;; - +;; - todo-and-done-only +;; Same as above but also include done items. +;; +;; - priority-up sort by highest priority +;; - priority-down sort by lowest priority +;; - effort-up sort by highest effort +;; - effort-down sort by lowest effort +;; +;; Default OPTIONS are from-top +;; +;; +;; 4) If the TRIGGER property contains any other words like +;; XYZ(KEYWORD), these are treated as entry id's with keywords. That +;; means Org-mode will search for an entry with the ID property XYZ +;; and switch that entry to KEYWORD as well. +;; +;; Blocking +;; -------- +;; +;; 1) If an entry contains a BLOCKER property that contains the word +;; "previous-sibling", the sibling above the current entry is +;; checked when you try to mark it DONE. If it is still in a TODO +;; state, the current state change is blocked. +;; +;; 2) If the BLOCKER property contains any other words, these are +;; treated as entry id's. That means Org-mode will search for an +;; entry with the ID property exactly equal to this word. If any +;; of these entries is not yet marked DONE, the current state change +;; will be blocked. +;; +;; 3) Whenever a state change is blocked, an org-mark is pushed, so that +;; you can find the offending entry with `C-c &'. +;; +;;; Example: +;; +;; When trying this example, make sure that the settings for TODO keywords +;; have been activated, i.e. include the following line and press C-c C-c +;; on the line before working with the example: +;; +;; #+TYP_TODO: TODO NEXT | DONE +;; +;; * TODO Win a million in Las Vegas +;; The "third" TODO (see above) cannot become a TODO without this money. +;; +;; :PROPERTIES: +;; :ID: I-cannot-do-it-without-money +;; :END: +;; +;; * Do this by doing a chain of TODO's +;; ** NEXT This is the first in this chain +;; :PROPERTIES: +;; :TRIGGER: chain-siblings(NEXT) +;; :END: +;; +;; ** This is the second in this chain +;; +;; ** This is the third in this chain +;; :PROPERTIES: +;; :BLOCKER: I-cannot-do-it-without-money +;; :END: +;; +;; ** This is the forth in this chain +;; When this is DONE, we will also trigger entry XYZ-is-my-id +;; :PROPERTIES: +;; :TRIGGER: XYZ-is-my-id(TODO) +;; :END: +;; +;; ** This is the fifth in this chain +;; +;; * Start writing report +;; :PROPERTIES: +;; :ID: XYZ-is-my-id +;; :END: +;; +;; + +(require 'org) +(eval-when-compile + (require 'cl)) + +(defcustom org-depend-tag-blocked t + "Whether to indicate blocked TODO items by a special tag." + :group 'org + :type 'boolean) + +(defcustom org-depend-find-next-options + "from-current,todo-only,priority-up" + "Default options for chain-find-next trigger" + :group 'org + :type 'string) + +(defmacro org-depend-act-on-sibling (trigger-val &rest rest) + "Perform a set of actions on the next sibling, if it exists, +copying the sibling spec TRIGGER-VAL to the next sibling." + `(catch 'exit + (save-excursion + (goto-char pos) + ;; find the sibling, exit if no more siblings + (condition-case nil + (outline-forward-same-level 1) + (error (throw 'exit t))) + ;; mark the sibling TODO + ,@rest + ;; make sure the sibling will continue the chain + (org-entry-add-to-multivalued-property + nil "TRIGGER" ,trigger-val)))) + +(defvar org-depend-doing-chain-find-next nil) + +(defun org-depend-trigger-todo (change-plist) + "Trigger new TODO entries after the current is switched to DONE. +This does two different kinds of triggers: + +- If the current entry contains a TRIGGER property that contains + \"chain-siblings(KEYWORD)\", it goes to the next sibling, marks it + KEYWORD and also installs the \"chain-sibling\" trigger to continue + the chain. +- If the current entry contains a TRIGGER property that contains + \"chain-siblings-scheduled\", we go to the next sibling and copy + the scheduled time from the current task, also installing the property + in the sibling. +- Any other word (space-separated) like XYZ(KEYWORD) in the TRIGGER + property is seen as an entry id. Org-mode finds the entry with the + corresponding ID property and switches it to the state TODO as well." + + ;; Refresh the effort text properties + (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)) + (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) + (catch 'return + (unless (eq type 'todo-state-change) + ;; We are only handling todo-state-change.... + (throw 'return t)) + (unless (and (member from org-not-done-keywords) + (member to org-done-keywords)) + ;; This is not a change from TODO to DONE, ignore it + (throw 'return t)) + + ;; OK, we just switched from a TODO state to a DONE state + ;; 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]+"))) + + ;; Go through all the triggers + (while (setq tr (pop triggers)) + (cond + ((and (not org-depend-doing-chain-find-next) + (string-match "\\`chain-find-next(\\b\\(.+?\\)\\b\\(.*\\))\\'" tr)) + ;; smarter sibling selection + (let* ((org-depend-doing-chain-find-next t) + (kwd (match-string 1 tr)) + (options (match-string 2 tr)) + (options (if (or (null options) + (equal options "")) + org-depend-find-next-options + options)) + (todo-only (string-match "todo-only" options)) + (todo-and-done-only (string-match "todo-and-done-only" + options)) + (from-top (string-match "from-top" options)) + (from-bottom (string-match "from-bottom" options)) + (from-current (string-match "from-current" options)) + (no-wrap (string-match "no-wrap" options)) + (priority-up (string-match "priority-up" options)) + (priority-down (string-match "priority-down" options)) + (effort-up (string-match "effort-up" options)) + (effort-down (string-match "effort-down" options))) + (save-excursion + (org-back-to-heading t) + (let ((this-item (point))) + ;; go up to the parent headline, then advance to next child + (org-up-heading-safe) + (let ((end (save-excursion (org-end-of-subtree t) + (point))) + (done nil) + (items '())) + (outline-next-heading) + (while (not done) + (if (not (looking-at org-complex-heading-regexp)) + (setq done t) + (let ((todo-kwd (match-string 2)) + (tags (match-string 5)) + (priority (org-get-priority (or (match-string 3) ""))) + (effort (when (or effort-up effort-down) + (let ((effort (get-text-property (point) 'org-effort))) + (when effort + (org-duration-string-to-minutes effort)))))) + (push (list (point) todo-kwd priority tags effort) + items)) + (unless (org-goto-sibling) + (setq done t)))) + ;; massage the list according to options + (setq items + (cond (from-top (nreverse items)) + (from-bottom items) + ((or from-current no-wrap) + (let* ((items (nreverse items)) + (pos (position this-item items :key #'first)) + (items-before (subseq items 0 pos)) + (items-after (subseq items pos))) + (if no-wrap items-after + (append items-after items-before)))) + (t (nreverse items)))) + (setq items (remove-if + (lambda (item) + (or (equal (first item) this-item) + (and (not todo-and-done-only) + (member (second item) org-done-keywords)) + (and (or todo-only + todo-and-done-only) + (null (second item))))) + items)) + (setq items + (sort + items + (lambda (item1 item2) + (let* ((p1 (third item1)) + (p2 (third item2)) + (e1 (fifth item1)) + (e2 (fifth item2)) + (p1-lt (< p1 p2)) + (p1-gt (> p1 p2)) + (e1-lt (and e1 (or (not e2) (< e1 e2)))) + (e2-gt (and e2 (or (not e1) (> e1 e2))))) + (cond (priority-up + (or p1-gt + (and (equal p1 p2) + (or (and effort-up e1-lt) + (and effort-down e2-gt))))) + (priority-down + (or p1-lt + (and (equal p1 p2) + (or (and effort-up e1-lt) + (and effort-down e2-gt))))) + (effort-up + (or e2-gt (and (equal e1 e2) p1-gt))) + (effort-down + (or e1-lt (and (equal e1 e2) p1-gt)))))))) + (when items + (goto-char (first (first items))) + (org-entry-add-to-multivalued-property nil "TRIGGER" tr) + (org-todo kwd))))))) + ((string-match "\\`chain-siblings(\\(.*?\\))\\'" tr) + ;; This is a TODO chain of siblings + (setq kwd (match-string 1 tr)) + (org-depend-act-on-sibling (format "chain-siblings(%s)" kwd) + (org-todo kwd))) + ((string-match "\\`\\(\\S-+\\)(\\(.*?\\))\\'" tr) + ;; This seems to be ENTRY_ID(KEYWORD) + (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)))) + ((string-match "\\`chain-siblings-scheduled\\'" tr) + (let ((time (org-get-scheduled-time pos))) + (when time + (org-depend-act-on-sibling + "chain-siblings-scheduled" + (org-schedule nil time)))))))))) + +(defun org-depend-block-todo (change-plist) + "Block turning an entry into a TODO. +This checks for a BLOCKER property in an entry and checks +all the entries listed there. If any of them is not done, +block changing the current entry into a TODO entry. If the property contains +the word \"previous-sibling\", the sibling above the current entry is checked. +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)) + (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 + (proceed-p + (catch 'return + ;; If this is not a todo state change, or if this entry is + ;; DONE, do not block + (when (or (not (eq type 'todo-state-change)) + (member from (cons 'done org-done-keywords)) + (member to (cons 'todo org-not-done-keywords)) + (not to)) + (throw 'return t)) + + ;; OK, the plan is to switch from nothing to TODO + ;; 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]+"))) + + ;; go through all the blockers + (while (setq bl (pop blockers)) + (cond + ((equal bl "previous-sibling") + ;; the sibling is required to be DONE. + (catch 'ignore + (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))) + ;; 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 + (goto-char p1) + (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 + ))) + (when org-depend-tag-blocked + (org-toggle-tag "blocked" (if proceed-p 'off 'on))) + + proceed-p)) + +(add-hook 'org-trigger-hook 'org-depend-trigger-todo) +(add-hook 'org-blocker-hook 'org-depend-block-todo) + +(provide 'org-depend) + +;;; org-depend.el ends here diff --git a/contrib/lisp/org-drill.el b/contrib/lisp/org-drill.el new file mode 100644 index 0000000..fb578ab --- /dev/null +++ b/contrib/lisp/org-drill.el @@ -0,0 +1,3367 @@ +;; -*- coding: utf-8-unix -*- +;;; org-drill.el - Self-testing using spaced repetition +;;; +;;; Copyright (C) 2010-2015 Paul Sexton +;;; +;;; 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" + "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 + "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 + "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 + "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 +than this number, it is regarded as successfully recalled, but the +time interval to the next repetition will be lowered if the quality +was near to a fail. + +By default this is 2, for SuperMemo-like behaviour. For +Mnemosyne-like behaviour, set it to 1. Other values are not +really sensible." + :group 'org-drill + :type '(choice (const 2) (const 1))) + + +(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 +climbs above this number." + :group 'org-drill + :type 'integer) + + +(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 + "How should 'leech items' be handled during drill sessions? +Possible values: +- nil :: Leech items are treated the same as normal items. +- skip :: Leech items are not included in drill sessions. +- warn :: Leech items are still included in drill sessions, + but a warning message is printed when each leech item is + presented." + :group 'org-drill + :type '(choice (const warn) (const skip) (const nil))) + + +(defface org-drill-visible-cloze-face + '((t (:foreground "darkseagreen"))) + "The face used to hide the contents of cloze phrases." + :group 'org-drill) + + +(defface org-drill-visible-cloze-hint-face + '((t (:foreground "dark slate blue"))) + "The face used to hide the contents of cloze phrases." + :group 'org-drill) + + +(defface org-drill-hidden-cloze-face + '((t (:foreground "deep sky blue" :background "blue"))) + "The face used to hide the contents of cloze phrases." + :group 'org-drill) + + +(defcustom org-drill-use-visible-cloze-face-p + nil + "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 + "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" + "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" + "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" + "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" + "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 ,(format "%s...%s" + org-drill-left-cloze-delimiter + org-drill-right-cloze-delimiter) + face org-drill-hidden-cloze-face + window t)) + +(setplist 'org-drill-hidden-text-overlay + '(invisible t)) + +(setplist 'org-drill-replaced-text-overlay + '(display "Replaced text" + 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.") + +(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.") + + +(defcustom org-drill-card-type-alist + '((nil org-drill-present-simple-card) + ("simple" org-drill-present-simple-card) + ("twosided" org-drill-present-two-sided-card nil t) + ("multisided" org-drill-present-multi-sided-card nil t) + ("hide1cloze" org-drill-present-multicloze-hide1) + ("hide2cloze" org-drill-present-multicloze-hide2) + ("show1cloze" org-drill-present-multicloze-show1) + ("show2cloze" org-drill-present-multicloze-show2) + ("multicloze" org-drill-present-multicloze-hide1) + ("hidefirst" org-drill-present-multicloze-hide-first) + ("hidelast" org-drill-present-multicloze-hide-last) + ("hide1_firstmore" org-drill-present-multicloze-hide1-firstmore) + ("show1_lastmore" org-drill-present-multicloze-show1-lastmore) + ("show1_firstless" org-drill-present-multicloze-show1-firstless) + ("conjugate" + org-drill-present-verb-conjugation + org-drill-show-answer-verb-conjugation) + ("decline_noun" + org-drill-present-noun-declension + org-drill-show-answer-noun-declension) + ("spanish_verb" org-drill-present-spanish-verb) + ("translate_number" org-drill-present-translate-number)) + "Alist associating card types with presentation functions. Each +entry in the alist takes the form: + +;;; (CARDTYPE QUESTION-FN [ANSWER-FN DRILL-EMPTY-P]) + +Where CARDTYPE is a string or nil (for default), and QUESTION-FN +is a function which takes no arguments and returns a boolean +value. + +When supplied, ANSWER-FN is a function that takes one argument -- +that argument is a function of no arguments, which when called, +prompts the user to rate their recall and performs rescheduling +of the drill item. ANSWER-FN is called with the point on the +active item's heading, just prior to displaying the item's +'answer'. It can therefore be used to modify the appearance of +the answer. ANSWER-FN must call its argument before returning. + +When supplied, DRILL-EMPTY-P is a boolean value, default nil. +When non-nil, cards of this type will be presented during tests +even if their bodies are empty." + :group 'org-drill + :type '(alist :key-type (choice string (const nil)) + :value-type function)) + + +(defcustom org-drill-scope + 'file + "The scope in which to search for drill items when conducting a +drill session. This can be any of: + +file The current buffer, respecting the restriction if any. + This is the default. +tree The subtree started with the entry at point +file-no-restriction The current buffer, without restriction +file-with-archives The current buffer, and any archives associated with it. +agenda All agenda files +agenda-with-archives All agenda files with any archive files associated + with them. +directory All files with the extension '.org' in the same + directory as the current file (includes the current + file if it is an .org file.) + (FILE1 FILE2 ...) If this is a list, all files in the list will be scanned. +" + ;; Note -- meanings differ slightly from the argument to org-map-entries: + ;; 'file' means current file/buffer, respecting any restriction + ;; 'file-no-restriction' means current file/buffer, ignoring restrictions + ;; 'directory' means all *.org files in current directory + :group 'org-drill + :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 + "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 + "Which SuperMemo spaced repetition algorithm to use for scheduling items. +Available choices are: +- SM2 :: the SM2 algorithm, used in SuperMemo 2.0 +- SM5 :: the SM5 algorithm, used in SuperMemo 5.0 +- Simple8 :: a modified version of the SM8 algorithm. SM8 is used in + SuperMemo 98. The version implemented here is simplified in that while it + 'learns' the difficulty of each item using quality grades and number of + failures, it does not modify the matrix of values that + governs how fast the inter-repetition intervals increase. A method for + 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))) + + +(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 at the end of each drill session. + +Over time, values in the matrix will adapt to the individual user's +pace of learning.") + + +(add-to-list 'savehist-additional-variables + 'org-drill-sm5-optimal-factor-matrix) +(unless savehist-mode + (savehist-mode 1)) + + +(defun org-drill--transfer-optimal-factor-matrix () + (if (and org-drill-optimal-factor-matrix + (null org-drill-sm5-optimal-factor-matrix)) + (setq org-drill-sm5-optimal-factor-matrix + org-drill-optimal-factor-matrix))) + +(add-hook 'after-init-hook 'org-drill--transfer-optimal-factor-matrix) + + +(defcustom org-drill-sm5-initial-interval + 4.0 + "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 + "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 +small, but scales up with the interval." + :group 'org-drill + :type 'boolean) + + +(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 + [[http://www.supermemo.com/english/algsm11.htm#Advanced%20repetitions]]. + +Items that were reviewed early will have their next review date brought +forward. Those that were reviewed late will have their next review +date postponed further. + +Note that this option currently has no effect if the SM2 algorithm +is used." + :group 'org-drill + :type 'boolean) + + +(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 +value of the variable. + +For example, with the hide1_firstmore card type, the first piece +of clozed text should be hidden more often than the other +pieces. If this variable is set to 4 (default), the first item +will only be shown 25% of the time (1 in 4 trials). Similarly for +show1_lastmore, the last item will be shown 75% of the time, and +for show1_firstless, the first item would only be shown 25% of the +time. + +If the value of this variable is NIL, then weighting is disabled, and +all weighted card types are treated as their unweighted equivalents." + :group 'org-drill + :type '(choice integer (const nil))) + + +(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 +;;; ORG-DRILL-DAYS-BEFORE-OLD days after their last +;;; repetition. These items will have been learned 'recently' and will have a +;;; low repetition count. +;;; - OLD mature items have intervals greater than +;;; ORG-DRILL-DAYS-BEFORE-OLD. +;;; - OVERDUE items are past their scheduled review date by more than +;;; LAST-INTERVAL * (ORG-DRILL-OVERDUE-INTERVAL-FACTOR - 1) days, +;;; regardless of young/old status. + + +(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 + "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 +20% of the last scheduled interval is allowed to elapse before +the item is overdue. A value of 1.0 means no extra time is +allowed at all - items are immediately considered overdue if +there is even one day's delay in reviewing them. This variable +should never be less than 1.0." + :group 'org-drill + :type 'float) + + +(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 +quickly with each successful repetition. You should only change +this in small increments (for example 0.05-0.1) as it has an +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 +presentation function will show its value instead of the default +behaviour of revealing the contents of the drilled item. + +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) +(defvar *org-drill-dormant-entry-count* 0) +(defvar *org-drill-due-entry-count* 0) +(defvar *org-drill-overdue-entry-count* 0) +(defvar *org-drill-due-tomorrow-count* 0) +(defvar *org-drill-overdue-entries* nil + "List of markers for items that are considered 'overdue', based on +the value of ORG-DRILL-OVERDUE-INTERVAL-FACTOR.") +(defvar *org-drill-young-mature-entries* nil + "List of markers for mature entries whose last inter-repetition +interval was <= ORG-DRILL-DAYS-BEFORE-OLD days.") +(defvar *org-drill-old-mature-entries* nil + "List of markers for mature entries whose last inter-repetition +interval was greater than ORG-DRILL-DAYS-BEFORE-OLD days.") +(defvar *org-drill-failed-entries* nil) +(defvar *org-drill-again-entries* nil) +(defvar *org-drill-done-entries* nil) +(defvar *org-drill-current-item* nil + "Set to the marker for the item currently being tested.") +(defvar *org-drill-cram-mode* nil + "Are we in 'cram mode', where all items are considered due +for review unless they were already reviewed in the recent past?") +(defvar org-drill-scheduling-properties + '("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)))) +(put 'org-drill-maximum-duration 'safe-local-variable + '(lambda (val) (or (integerp val) (null val)))) +(put 'org-drill-failure-quality 'safe-local-variable 'integerp) +(put 'org-drill-forgetting-index 'safe-local-variable 'integerp) +(put 'org-drill-leech-failure-threshold 'safe-local-variable 'integerp) +(put 'org-drill-leech-method 'safe-local-variable + '(lambda (val) (memq val '(nil skip warn)))) +(put 'org-drill-use-visible-cloze-face-p 'safe-local-variable 'booleanp) +(put 'org-drill-hide-item-headings-p 'safe-local-variable 'booleanp) +(put 'org-drill-spaced-repetition-algorithm 'safe-local-variable + '(lambda (val) (memq val '(simple8 sm5 sm2)))) +(put 'org-drill-sm5-initial-interval 'safe-local-variable 'floatp) +(put 'org-drill-add-random-noise-to-intervals-p 'safe-local-variable 'booleanp) +(put 'org-drill-adjust-intervals-for-early-and-late-repetitions-p + 'safe-local-variable 'booleanp) +(put 'org-drill-cram-hours 'safe-local-variable 'integerp) +(put 'org-drill-learn-fraction 'safe-local-variable 'floatp) +(put 'org-drill-days-before-old 'safe-local-variable 'integerp) +(put 'org-drill-overdue-interval-factor 'safe-local-variable 'floatp) +(put 'org-drill-scope 'safe-local-variable + '(lambda (val) (or (symbolp val) (listp val)))) +(put 'org-drill-match 'safe-local-variable + '(lambda (val) (or (stringp val) (null val)))) +(put 'org-drill-save-buffers-after-drill-sessions-p 'safe-local-variable 'booleanp) +(put 'org-drill-cloze-text-weight 'safe-local-variable + '(lambda (val) (or (null val) (integerp val)))) +(put 'org-drill-left-cloze-delimiter 'safe-local-variable 'stringp) +(put 'org-drill-right-cloze-delimiter 'safe-local-variable 'stringp) + + +;;;; Utilities ================================================================ + + +(defun free-marker (m) + (set-marker m nil)) + + +(defmacro pop-random (place) + (let ((idx (gensym))) + `(if (null ,place) + nil + (let ((,idx (random* (length ,place)))) + (prog1 (nth ,idx ,place) + (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))) + (while (< i len) + (setq j (+ i (random* (- len i)))) + (setq temp (nth i list)) + (setf (nth i list) (nth j list)) + (setf (nth j list) temp) + (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 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)) + (org-drill-match (or drill-match org-drill-match))) + (apply 'org-map-entries func + (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) + (directory + (directory-files (file-name-directory (buffer-file-name)) + t "\\.org$")) + (t org-drill-scope)) + skip))) + + +(defmacro with-hidden-cloze-text (&rest body) + `(progn + (org-drill-hide-clozed-text) + (unwind-protect + (progn + ,@body) + (org-drill-unhide-clozed-text)))) + + +(defmacro with-hidden-cloze-hints (&rest body) + `(progn + (org-drill-hide-cloze-hints) + (unwind-protect + (progn + ,@body) + (org-drill-unhide-text)))) + + +(defmacro with-hidden-comments (&rest body) + `(progn + (if org-drill-hide-item-headings-p + (org-drill-hide-heading-at-point)) + (org-drill-hide-comments) + (unwind-protect + (progn + ,@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. +Zero means it was reviewed today. +A positive number means it was reviewed that many days ago. +A negative number means the date of last review is in the future -- +this should never happen." + (let ((datestr (org-entry-get (point) "DRILL_LAST_REVIEWED"))) + (when datestr + (- (time-to-days (current-time)) + (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." + (let ((datestr (org-entry-get (point) "DRILL_LAST_REVIEWED"))) + (when datestr + (floor + (/ (- (time-to-seconds (current-time)) + (time-to-seconds (apply 'encode-time + (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 +situation use `org-part-of-drill-entry-p'." + (save-excursion + (when marker + (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?" + (or (org-drill-entry-p) + ;; 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." + (unless (org-at-heading-p) + (org-back-to-heading)) + (unless (org-part-of-drill-entry-p) + (error "Point is not inside a drill entry")) + (while (not (org-drill-entry-p)) + (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* +;; (let ((hours (org-drill-hours-since-last-review))) +;; (and (org-drill-entry-p) +;; (or (null hours) +;; (>= hours org-drill-cram-hours))))) +;; (t +;; (let ((item-time (org-get-scheduled-time (point)))) +;; (and (org-drill-entry-p) +;; (or (not (eql 'skip org-drill-leech-method)) +;; (not (org-drill-entry-leech-p))) +;; (or (null item-time) ; not scheduled +;; (not (minusp ; scheduled for today/in past +;; (- (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. + This is the case if it is not a drill item, or if it is a leech item + that we wish to skip, or if we are in cram mode and have already reviewed + the item within the last few hours. +- 0 if the item is new, or if it scheduled for review today. +- A negative integer - item is scheduled that many days in the future. +- A positive integer - item is scheduled that many days in the past." + (cond + (*org-drill-cram-mode* + (let ((hours (org-drill-hours-since-last-review))) + (and (org-drill-entry-p) + (or (null hours) + (>= hours org-drill-cram-hours)) + 0))) + (t + (let ((item-time (org-get-scheduled-time (point)))) + (cond + ((or (not (org-drill-entry-p)) + (and (eql 'skip org-drill-leech-method) + (org-drill-entry-leech-p))) + nil) + ((null item-time) ; not scheduled -> due now + 0) + (t + (- (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 +considered 'overdue'. If the arguments are not given they are extracted +from the entry at point." + (unless days-overdue + (setq days-overdue (org-drill-entry-days-overdue))) + (unless last-interval + (setq last-interval (org-drill-entry-last-interval 1))) + (and (numberp days-overdue) + (> days-overdue 1) ; enforce a sane minimum 'overdue' gap + ;;(> due org-drill-days-before-overdue) + (> (/ (+ 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 + (string-to-number val) + (or default nil)))) + +(defun org-drill-entry-last-interval (&optional default) + (let ((val (org-entry-get (point) "DRILL_LAST_INTERVAL"))) + (if val + (string-to-number val) + (or default 0)))) + +(defun org-drill-entry-repeats-since-fail (&optional default) + (let ((val (org-entry-get (point) "DRILL_REPEATS_SINCE_FAIL"))) + (if val + (string-to-number val) + (or default 0)))) + +(defun org-drill-entry-total-repeats (&optional default) + (let ((val (org-entry-get (point) "DRILL_TOTAL_REPEATS"))) + (if val + (string-to-number val) + (or default 0)))) + +(defun org-drill-entry-ease (&optional default) + (let ((val (org-entry-get (point) "DRILL_EASE"))) + (if val + (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))) + (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)))) + +(defun pseudonormal (mean variation) + "Random numbers in a pseudo-normal distribution with mean MEAN, range + MEAN-VARIATION to MEAN+VARIATION" + (+ (random* variation) + (random* variation) + (- variation) + mean)) + + +(defun org-drill-early-interval-factor (optimal-factor + optimal-interval + days-ahead) + "Arguments: +- OPTIMAL-FACTOR: interval-factor if the item had been tested +exactly when it was supposed to be. +- OPTIMAL-INTERVAL: interval for next repetition (days) if the item had been +tested exactly when it was supposed to be. +- DAYS-AHEAD: how many days ahead of time the item was reviewed. + +Returns an adjusted optimal factor which should be used to +calculate the next interval, instead of the optimal factor found +in the matrix." + (let ((delta-ofmax (* (1- optimal-factor) + (/ (+ optimal-interval + (* 0.6 optimal-interval) -1) (1- optimal-interval))))) + (- 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: +- LAST-INTERVAL is the interval in days that was used to schedule the item's + current review date. +- REPEATS is the number of items the item has been successfully recalled without + without any failures. It is reset to 0 upon failure to recall the item. +- FAILURES is the total number of times the user has failed to recall the item. +- TOTAL-REPEATS includes both successful and unsuccessful repetitions. +- AVERAGE-QUALITY is the mean quality of recall of the item over + all its repetitions, successful and unsuccessful. +- EASE is a number reflecting how easy the item is to learn. Higher is easier. +" + (let ((learn-str (org-entry-get (point) "LEARN_DATA")) + (repeats (org-drill-entry-total-repeats :missing))) + (cond + (learn-str + (let ((learn-data (or (and learn-str + (read learn-str)) + (copy-list initial-repetition-state)))) + (list (nth 0 learn-data) ; last interval + (nth 1 learn-data) ; repetitions + (org-drill-entry-failure-count) + (nth 1 learn-data) + (org-drill-entry-last-quality) + (nth 2 learn-data) ; EF + ))) + ((not (eql :missing repeats)) + (list (org-drill-entry-last-interval) + (org-drill-entry-repeats-since-fail) + (org-drill-entry-failure-count) + (org-drill-entry-total-repeats) + (org-drill-entry-average-quality) + (org-drill-entry-ease))) + (t ; virgin item + (list 0 0 0 0 nil nil))))) + + +(defun org-drill-store-item-data (last-interval repeats failures + total-repeats meanq + ease) + "Stores the given data in the item at point." + (org-entry-delete (point) "LEARN_DATA") + (org-set-property "DRILL_LAST_INTERVAL" + (number-to-string (round-float last-interval 4))) + (org-set-property "DRILL_REPEATS_SINCE_FAIL" (number-to-string repeats)) + (org-set-property "DRILL_TOTAL_REPEATS" (number-to-string total-repeats)) + (org-set-property "DRILL_FAILURE_COUNT" (number-to-string failures)) + (org-set-property "DRILL_AVERAGE_QUALITY" + (number-to-string (round-float meanq 3))) + (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: +- LAST-INTERVAL -- the number of days since the item was last reviewed. +- REPEATS -- the number of times the item has been successfully reviewed +- EF -- the 'easiness factor' +- QUALITY -- 0 to 5 + +Returns a list: (INTERVAL REPEATS EF FAILURES MEAN TOTAL-REPEATS OFMATRIX), where: +- INTERVAL is the number of days until the item should next be reviewed +- REPEATS is incremented by 1. +- EF is modified based on the recall quality for the item. +- OF-MATRIX is not modified." + (assert (> n 0)) + (assert (and (>= quality 0) (<= quality 5))) + (if (<= quality org-drill-failure-quality) + ;; 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-sm5-optimal-factor-matrix) + ;; else: + (let* ((next-ef (modify-e-factor ef quality)) + (interval + (cond + ((<= n 1) 1) + ((= n 2) + (cond + (org-drill-add-random-noise-to-intervals-p + (case quality + (5 6) + (4 4) + (3 3) + (2 1) + (t -1))) + (t 6))) + (t (* last-interval next-ef))))) + (list (if org-drill-add-random-noise-to-intervals-p + (+ last-interval (* (- interval last-interval) + (org-drill-random-dispersal-factor))) + interval) + (1+ n) + next-ef + failures meanq (1+ total-repeats) + org-drill-sm5-optimal-factor-matrix)))) + + +;;; SM5 Algorithm ============================================================= + + + +(defun initial-optimal-factor-sm5 (n ef) + (if (= 1 n) + org-drill-sm5-initial-interval + ef)) + +(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)))) + + +(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-sm5-optimal-factor-matrix)))) + (if (= 1 n) + of + (* of last-interval)))) + + +(defun determine-next-interval-sm5 (last-interval n ef quality + failures meanq total-repeats + of-matrix &optional delta-days) + (if (zerop n) (setq n 1)) + (if (null ef) (setq ef 2.5)) + (assert (> n 0)) + (assert (and (>= quality 0) (<= quality 5))) + (unless of-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) + quality org-drill-learn-fraction)) + (interval nil)) + (when (and org-drill-adjust-intervals-for-early-and-late-repetitions-p + delta-days (minusp delta-days)) + (setq new-of (org-drill-early-interval-factor + (get-optimal-factor-sm5 n ef of-matrix) + (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) + (list -1 1 old-ef (1+ failures) meanq (1+ total-repeats) + of-matrix)) ; Not clear if OF matrix is supposed to be + ; preserved + ;; For a zero-based quality of 4 or 5, don't repeat + ;; ((and (>= quality 4) + ;; (not org-learn-always-reschedule)) + ;; (list 0 (1+ n) ef failures meanq + ;; (1+ total-repeats) of-matrix)) ; 0 interval = unschedule + (t + (setq interval (inter-repetition-interval-sm5 + last-interval n ef of-matrix)) + (if org-drill-add-random-noise-to-intervals-p + (setq interval (* interval (org-drill-random-dispersal-factor)))) + (list interval + (1+ n) + ef + failures + meanq + (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 + been forgotten, ever. + +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. +- REPETITION: the number of times the item has been tested. +1 is the first repetition (ie the second trial). +Returns: +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." + (+ (* 0.0542 (expt quality 4)) + (* -0.4848 (expt quality 3)) + (* 1.4916 (expt quality 2)) + (* -1.2403 quality) + 1.4515)) + + +(defun determine-next-interval-simple8 (last-interval repeats quality + failures meanq totaln + &optional delta-days) + "Arguments: +- LAST-INTERVAL -- the number of days since the item was last reviewed. +- REPEATS -- the number of times the item has been successfully reviewed +- EASE -- the 'easiness factor' +- QUALITY -- 0 to 5 +- DELTA-DAYS -- how many days overdue was the item when it was reviewed. + 0 = reviewed on the scheduled day. +N = N days overdue. + -N = reviewed N days early. + +Returns the new item data, as a list of 6 values: +- NEXT-INTERVAL +- REPEATS +- EASE +- FAILURES +- AVERAGE-QUALITY +- TOTAL-REPEATS. +See the documentation for `org-drill-get-item-data' for a description of these." + (assert (>= repeats 0)) + (assert (and (>= quality 0) (<= quality 5))) + (assert (or (null meanq) (and (>= meanq 0) (<= meanq 5)))) + (let ((next-interval nil)) + (setf meanq (if meanq + (/ (+ quality (* meanq totaln 1.0)) (1+ totaln)) + quality)) + (cond + ((<= quality org-drill-failure-quality) + (incf failures) + (setf repeats 0 + next-interval -1)) + ((or (zerop repeats) + (zerop last-interval)) + (setf next-interval (org-drill-simple8-first-interval failures)) + (incf repeats) + (incf totaln)) + (t + (let* ((use-n + (if (and + org-drill-adjust-intervals-for-early-and-late-repetitions-p + (numberp delta-days) (plusp delta-days) + (plusp last-interval)) + (+ repeats (min 1 (/ delta-days last-interval 1.0))) + repeats)) + (factor (org-drill-simple8-interval-factor + (org-drill-simple8-quality->ease meanq) use-n)) + (next-int (* last-interval factor))) + (when (and org-drill-adjust-intervals-for-early-and-late-repetitions-p + (numberp delta-days) (minusp delta-days)) + ;; The item was reviewed earlier than scheduled. + (setf factor (org-drill-early-interval-factor + factor next-int (abs delta-days)) + next-int (* last-interval factor))) + (setf next-interval next-int) + (incf repeats) + (incf totaln)))) + (list + (if (and org-drill-add-random-noise-to-intervals-p + (plusp next-interval)) + (* next-interval (org-drill-random-dispersal-factor)) + next-interval) + repeats + (org-drill-simple8-quality->ease meanq) + failures + meanq + totaln + ))) + + + + +;;; Essentially copied from `org-learn.el', but modified to +;;; optionally call the SM2 or simple8 functions. +(defun org-drill-smart-reschedule (quality &optional days-ahead) + "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-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. + ;; Useful for entries which randomly present any of several facts. + (weight (org-entry-get (point) "DRILL_CARD_WEIGHT"))) + (if (stringp weight) + (setq weight (read weight))) + (destructuring-bind (last-interval repetitions failures + total-repeats meanq ease) + (org-drill-get-item-data) + (destructuring-bind (next-interval repetitions ease + failures meanq total-repeats + &optional new-ofmatrix) + (case org-drill-spaced-repetition-algorithm + (sm5 (determine-next-interval-sm5 last-interval repetitions + ease quality failures + meanq total-repeats ofmatrix)) + (sm2 (determine-next-interval-sm2 last-interval repetitions + ease quality failures + meanq total-repeats)) + (simple8 (determine-next-interval-simple8 last-interval repetitions + quality failures meanq + total-repeats + delta-days))) + (if (numberp days-ahead) + (setq next-interval days-ahead)) + + (if (and (null days-ahead) + (numberp weight) (plusp weight) + (not (minusp next-interval))) + (setq next-interval + (max 1.0 (+ last-interval + (/ (- next-interval last-interval) weight))))) + + (org-drill-store-item-data next-interval repetitions failures + total-repeats meanq ease) + + (if (eql 'sm5 org-drill-spaced-repetition-algorithm) + (setq org-drill-sm5-optimal-factor-matrix new-ofmatrix)) + + (cond + ((= 0 days-ahead) + (org-schedule '(4))) + ((minusp days-ahead) + (org-schedule nil (current-time))) + (t + (org-schedule nil (time-add (current-time) + (days-to-time + (round next-interval)))))))))) + + +(defun org-drill-hypothetical-next-review-date (quality) + "Returns an integer representing the number of days into the future +that the current item would be scheduled, based on a recall quality +of QUALITY." + (let ((weight (org-entry-get (point) "DRILL_CARD_WEIGHT"))) + (destructuring-bind (last-interval repetitions failures + total-repeats meanq ease) + (org-drill-get-item-data) + (if (stringp weight) + (setq weight (read weight))) + (destructuring-bind (next-interval repetitions ease + failures meanq total-repeats + &optional ofmatrix) + (case org-drill-spaced-repetition-algorithm + (sm5 (determine-next-interval-sm5 last-interval repetitions + ease quality failures + meanq total-repeats + org-drill-sm5-optimal-factor-matrix)) + (sm2 (determine-next-interval-sm2 last-interval repetitions + ease quality failures + meanq total-repeats)) + (simple8 (determine-next-interval-simple8 last-interval repetitions + quality failures meanq + total-repeats))) + (cond + ((not (plusp next-interval)) + 0) + ((and (numberp weight) (plusp weight)) + (+ last-interval + (max 1.0 (/ (- next-interval last-interval) weight)))) + (t + next-interval)))))) + + +(defun org-drill-hypothetical-next-review-dates () + (let ((intervals nil)) + (dotimes (q 6) + (push (max (or (car intervals) 0) + (org-drill-hypothetical-next-review-date q)) + intervals)) + (reverse intervals))) + + +(defun org-drill-reschedule () + "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)) + (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 (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 org-drill--help-key) + (format "0-2 Means you have forgotten the item. +3-5 Means you have remembered the item. + +0 - Completely forgot. +1 - Even after seeing the answer, it still took a bit to sink in. +2 - After seeing the answer, you remembered it. +3 - It took you awhile, but you finally remembered. (+%s days) +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? %s" + (round (nth 3 next-review-dates)) + (round (nth 4 next-review-dates)) + (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))) + ((and (vectorp input) (symbolp (elt input 0))) + (case (elt input 0) + (up (ignore-errors (forward-line -1))) + (down (ignore-errors (forward-line 1))) + (left (ignore-errors (backward-char))) + (right (ignore-errors (forward-char))) + (prior (ignore-errors (scroll-down))) ; pgup + (next (ignore-errors (scroll-up))))) ; pgdn + ((and (vectorp input) (listp (elt input 0)) + (eventp (elt input 0))) + (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 org-drill--tags-key) + (org-set-tags-command)))) + (cond + ((and (>= ch ?0) (<= ch ?5)) + (let ((quality (- ch ?0)) + (failures (org-drill-entry-failure-count))) + (unless *org-drill-cram-mode* + (save-excursion + (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) + (when org-drill-leech-failure-threshold + ;;(setq failures (if failures (string-to-number failures) 0)) + ;; (org-set-property "DRILL_FAILURE_COUNT" + ;; (format "%d" (1+ failures))) + (if (> (1+ failures) org-drill-leech-failure-threshold) + (org-toggle-tag "leech" 'on)))) + (t + (let ((scheduled-time (org-get-scheduled-time (point)))) + (when scheduled-time + (message "Next review in %d days" + (- (time-to-days scheduled-time) + (time-to-days (current-time)))) + (sit-for 0.5))))) + (org-set-property "DRILL_LAST_QUALITY" (format "%d" quality)) + (org-set-property "DRILL_LAST_REVIEWED" + (time-to-inactive-org-timestamp (current-time)))) + quality)) + ((= 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." +;; (let ((drill-entry-level (org-current-level)) +;; (drill-sections nil) +;; (drill-heading nil)) +;; (org-show-subtree) +;; (save-excursion +;; (org-map-entries +;; (lambda () +;; (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)) +;; (member drill-heading heading-list)) +;; (hide-subtree)) +;; (push (point) drill-sections))) +;; "" '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 +on the relevant subheading. TEST should return nil if the subheading is +to be revealed, non-nil if it is to be hidden. +Returns a list containing the position of each immediate subheading of +the current topic." + (let ((drill-entry-level (org-current-level)) + (drill-sections nil)) + (org-show-subtree) + (save-excursion + (org-map-entries + (lambda () + (when (and (not (org-invisible-p)) + (> (org-current-level) drill-entry-level)) + (when (or (/= (org-current-level) (1+ drill-entry-level)) + (funcall test)) + (hide-subtree)) + (push (point) drill-sections))) + "" '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) + (ch nil) + (last-second 0) + (mature-entry-count (+ (length *org-drill-young-mature-entries*) + (length *org-drill-old-mature-entries*) + (length *org-drill-overdue-entries*))) + (status (first (org-drill-entry-status))) + (prompt + (if fmt-and-args + (apply 'format + (first fmt-and-args) + (rest fmt-and-args)) + (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 + (char-to-string + (cond + ((eql status :failed) ?F) + (*org-drill-cram-mode* ?C) + (t + (case status + (:new ?N) (:young ?Y) (:old ?o) (:overdue ?!) + (t ??))))) + 'face `(:foreground + ,(case status + (:new org-drill-new-count-color) + ((:young :old) org-drill-mature-count-color) + ((:overdue :failed) org-drill-failed-count-color) + (t org-drill-done-count-color)))) + (propertize + (number-to-string (length *org-drill-done-entries*)) + 'face `(:foreground ,org-drill-done-count-color) + 'help-echo "The number of items you have reviewed this session.") + (propertize + (number-to-string (+ (length *org-drill-again-entries*) + (length *org-drill-failed-entries*))) + 'face `(:foreground ,org-drill-failed-count-color) + 'help-echo (concat "The number of items that you failed, " + "and need to review again.")) + (propertize + (number-to-string mature-entry-count) + 'face `(:foreground ,org-drill-mature-count-color) + 'help-echo "The number of old items due for review.") + (propertize + (number-to-string (length *org-drill-new-entries*)) + 'face `(:foreground ,org-drill-new-count-color) + 'help-echo (concat "The number of new items that you " + "have never reviewed.")) + prompt)) + (if (and (eql 'warn org-drill-leech-method) + (org-drill-entry-leech-p)) + (setq prompt (concat + (propertize "!!! LEECH ITEM !!! +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 org-drill--tags-key)) + (setq ch nil) + (while (not (input-pending-p)) + (let ((elapsed (time-subtract (current-time) item-start-time))) + (message (concat (if (>= (time-to-seconds elapsed) (* 60 60)) + "++:++ " + (format-time-string "%M:%S " elapsed)) + prompt)) + (sit-for 1))) + (setq input (read-key-sequence nil)) + (if (stringp input) (setq ch (elt input 0))) + (if (eql ch org-drill--tags-key) + (org-set-tags-command))) + (case ch + (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.")) + (save-excursion + (let ((beg (point))) + (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 + (dolist (ovl (overlays-in (point-min) (point-max))) + (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. + ;; - LaTeX math fragments + ;; - the contents of SRC blocks + (unless (save-match-data + (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))) + (hint-sep-pos (string-match-p (regexp-quote org-drill-hint-separator) + (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 + (match-string 0) + (+ hint-sep-pos (length org-drill-hint-separator)) + (1- (length (match-string 0)))))) + (overlay-put + ovl 'display + ;; If hint is like `X...' then display [X...] + ;; otherwise display [...X] + (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) + (unless (or (save-match-data + (org-pos-in-regexp (match-beginning 0) + org-bracket-link-regexp 1)) + (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." + `(progn + (org-drill-replace-entry-text ,text) + (unwind-protect + (progn + ,@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." + `(progn + (org-drill-replace-entry-text ,replacements t) + (unwind-protect + (progn + ,@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 +the string TEXT. +If MULTI-P is non-nil, TEXT must be a list of values which are legal +for the `display' text property. The text of the item will be temporarily +replaced by all of these items, in the order in which they appear in +the list. +Note: does not actually alter the item." + (cond + ((and multi-p + (listp text)) + (org-drill-replace-entry-text-multi text)) + (t + (let ((ovl (make-overlay (point-min) + (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 +the string TEXT. +Note: does not actually alter the item." + (let ((ovl nil) + (p-min (point-min)) + (p-max (save-excursion + (outline-next-heading) + (point)))) + (assert (>= (- p-max p-min) (length replacements))) + (dotimes (i (length replacements)) + (setq ovl (make-overlay (+ p-min (* 2 i)) + (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) + (unwind-protect + (progn + ,@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 + text + (substring-no-properties text)))) + + +;; (defun org-entry-empty-p () +;; (zerop (length (org-drill-get-entry-text)))) + +;; This version is about 5x faster than the old version, above. +(defun org-entry-empty-p () + (save-excursion + (org-back-to-heading t) + (let ((lim (save-excursion + (outline-next-heading) (point)))) + (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 +;; topic in the form of a 'question' or with some information 'hidden', as +;; appropriate for the card type. The user should then be prompted to press a +;; key. The function should then reveal either the 'answer' or the entire +;; 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 + (with-replaced-entry-text + (format "\nAnswer:\n\n %s\n" drill-answer) + (prog1 + (funcall reschedule-fn) + (setq drill-answer nil)))) + (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 + (with-hidden-cloze-text + (let ((drill-sections (org-drill-hide-all-subheadings-except nil))) + (when drill-sections + (save-excursion + (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 + (with-hidden-cloze-text + (let ((drill-sections (org-drill-hide-all-subheadings-except nil))) + (when drill-sections + (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 + force-show-last + force-hide-first) + "Hides NUMBER-TO-HIDE pieces of text that are marked for cloze deletion, +chosen at random. +If NUMBER-TO-HIDE is negative, show only (ABS NUMBER-TO-HIDE) pieces, +hiding all the rest. +If FORCE-HIDE-FIRST is non-nil, force the first piece of text to be one of +the hidden items. +If FORCE-SHOW-FIRST is non-nil, never hide the first piece of text. +If FORCE-SHOW-LAST is non-nil, never hide the last piece of text. +If the number of text pieces in the item is less than +NUMBER-TO-HIDE, then all text pieces will be hidden (except the first or last +items if FORCE-SHOW-FIRST or FORCE-SHOW-LAST is non-nil)." + (with-hidden-comments + (with-hidden-cloze-hints + (let ((item-end nil) + (match-count 0) + (body-start (or (cdr (org-get-property-block)) + (point)))) + (if (and force-hide-first force-show-first) + (error "FORCE-HIDE-FIRST and FORCE-SHOW-FIRST are mutually exclusive")) + (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) + (let ((in-regexp? (save-match-data + (org-pos-in-regexp (match-beginning 0) + org-bracket-link-regexp 1)))) + (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))) + (when (plusp match-count) + (let* ((positions (shuffle-list (loop for i from 1 + to match-count + collect i))) + (match-nums nil) + (cnt nil)) + (if force-hide-first + ;; Force '1' to be in the list, and to be the first item + ;; in the list. + (setq positions (cons 1 (remove 1 positions)))) + (if force-show-first + (setq positions (remove 1 positions))) + (if force-show-last + (setq positions (remove match-count positions))) + (setq match-nums + (subseq positions + 0 (min number-to-hide (length positions)))) + ;; (dolist (pos-to-hide match-nums) + (save-excursion + (goto-char body-start) + (setq cnt 0) + (while (re-search-forward org-drill-cloze-regexp item-end t) + (unless (save-match-data + (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))))))) + ;; (loop + ;; do (re-search-forward org-drill-cloze-regexp + ;; item-end t pos-to-hide) + ;; 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) + (prog1 (org-drill-presentation-prompt) + (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 +the second to last, etc." + (with-hidden-comments + (with-hidden-cloze-hints + (let ((item-end nil) + (match-count 0) + (body-start (or (cdr (org-get-property-block)) + (point))) + (cnt 0)) + (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) + (let ((in-regexp? (save-match-data + (org-pos-in-regexp (match-beginning 0) + org-bracket-link-regexp 1)))) + (unless (or in-regexp? + (org-inside-LaTeX-fragment-p)) + (incf match-count))))) + (if (minusp to-hide) + (setq to-hide (+ 1 to-hide match-count))) + (cond + ((or (not (plusp match-count)) + (> to-hide match-count)) + nil) + (t + (save-excursion + (goto-char body-start) + (setq cnt 0) + (while (re-search-forward org-drill-cloze-regexp item-end t) + (unless (save-match-data + ;; 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) + (prog1 (org-drill-presentation-prompt) + (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, +chosen at random. + +The definitions of 'commonly' and 'uncommonly' are determined by +the value of `org-drill-cloze-text-weight'." + ;; The 'firstmore' and 'lastmore' functions used to randomly choose whether + ;; to hide the 'favoured' piece of text. However even when the chance of + ;; hiding it was set quite high (80%), the outcome was too unpredictable over + ;; the small number of repetitions where most learning takes place for each + ;; item. In other words, the actual frequency during the first 10 repetitions + ;; was often very different from 80%. Hence we use modulo instead. + (cond + ((null org-drill-cloze-text-weight) + ;; Behave as hide1cloze + (org-drill-present-multicloze-hide1)) + ((not (and (integerp org-drill-cloze-text-weight) + (plusp org-drill-cloze-text-weight))) + (error "Illegal value for org-drill-cloze-text-weight: %S" + org-drill-cloze-text-weight)) + ((zerop (mod (1+ (org-drill-entry-total-repeats 0)) + org-drill-cloze-text-weight)) + ;; Uncommonly, hide any item except the first + (org-drill-present-multicloze-hide-n 1 t)) + (t + ;; 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 +that the last item is much less likely to be the item that is +visible. + +The definitions of 'commonly' and 'uncommonly' are determined by +the value of `org-drill-cloze-text-weight'." + (cond + ((null org-drill-cloze-text-weight) + ;; Behave as show1cloze + (org-drill-present-multicloze-show1)) + ((not (and (integerp org-drill-cloze-text-weight) + (plusp org-drill-cloze-text-weight))) + (error "Illegal value for org-drill-cloze-text-weight: %S" + org-drill-cloze-text-weight)) + ((zerop (mod (1+ (org-drill-entry-total-repeats 0)) + org-drill-cloze-text-weight)) + ;; Uncommonly, show any item except the last + (org-drill-present-multicloze-hide-n -1 nil nil t)) + (t + ;; 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 +random piece. The effect is similar to 'show1cloze' except that +the first item is much less likely to be the item that is +visible. + +The definitions of 'commonly' and 'uncommonly' are determined by +the value of `org-drill-cloze-text-weight'." + (cond + ((null org-drill-cloze-text-weight) + ;; Behave as show1cloze + (org-drill-present-multicloze-show1)) + ((not (and (integerp org-drill-cloze-text-weight) + (plusp org-drill-cloze-text-weight))) + (error "Illegal value for org-drill-cloze-text-weight: %S" + org-drill-cloze-text-weight)) + ((zerop (mod (1+ (org-drill-entry-total-repeats 0)) + org-drill-cloze-text-weight)) + ;; Uncommonly, show the first item + (org-drill-present-multicloze-hide-n -1 t)) + (t + ;; 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-card-using-text (question &optional answer) + "Present the string QUESTION as the only visible content of the card. +If ANSWER is supplied, set the global variable `drill-answer' to its value." + (if answer (setq drill-answer answer)) + (with-hidden-comments + (with-replaced-entry-text + (concat "\n" question) + (org-drill-hide-all-subheadings-except nil) + (org-cycle-hide-drawers 'all) + (ignore-errors + (org-display-inline-images t)) + (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 +visible content of the card. +If ANSWER is supplied, set the global variable `drill-answer' to its value." + (if answer (setq drill-answer answer)) + (with-hidden-comments + (with-replaced-entry-text-multi + replacements + (org-drill-hide-all-subheadings-except nil) + (org-cycle-hide-drawers 'all) + (ignore-errors + (org-display-inline-images t)) + (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 +it meets the definition of a 'review topic' used by `org-drill'. + +Returns a quality rating from 0 to 5, or nil if the user quit, or the symbol +EDIT if the user chose to exit the drill and edit the current item. Choosing +the latter option leaves the drill session suspended; it can be resumed +later using `org-drill-resume'. + +See `org-drill' for more details." + (interactive) + (org-drill-goto-drill-entry-heading) + ;;(unless (org-part-of-drill-entry-p) + ;; (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" t)) + (answer-fn 'org-drill-present-default-answer) + (present-empty-cards nil) + (cont nil) + ;; fontification functions in `outline-view-change-hook' can cause big + ;; slowdowns, so we temporarily bind this variable to nil here. + (outline-view-change-hook nil)) + (setq drill-answer nil) + (org-save-outline-visibility t + (save-restriction + (org-narrow-to-subtree) + (org-show-subtree) + (org-cycle-hide-drawers 'all) + + (let ((presentation-fn + (cdr (assoc card-type org-drill-card-type-alist)))) + (if (listp presentation-fn) + (psetq answer-fn (or (second presentation-fn) + 'org-drill-present-default-answer) + present-empty-cards (third presentation-fn) + presentation-fn (first presentation-fn))) + (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* + *org-drill-current-item* + (and (not (org-drill-maximum-item-count-reached-p)) + (not (org-drill-maximum-duration-reached-p)) + (or *org-drill-new-entries* + *org-drill-failed-entries* + *org-drill-young-mature-entries* + *org-drill-old-mature-entries* + *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*) + (length *org-drill-failed-entries*) + (length *org-drill-young-mature-entries*) + (length *org-drill-old-mature-entries*) + (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." + (and org-drill-maximum-duration + (not *org-drill-cram-mode*) + *org-drill-start-time* + (> (- (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." + (and org-drill-maximum-items-per-session + (not *org-drill-cram-mode*) + (>= (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)) + (while (or (null m) + (not (org-drill-entry-p m))) + (setq + m + (cond + ;; First priority is items we failed in a prior session. + ((and *org-drill-failed-entries* + (not (org-drill-maximum-item-count-reached-p)) + (not (org-drill-maximum-duration-reached-p))) + (pop-random *org-drill-failed-entries*)) + ;; Next priority is overdue items. + ((and *org-drill-overdue-entries* + (not (org-drill-maximum-item-count-reached-p)) + (not (org-drill-maximum-duration-reached-p))) + ;; We use `pop', not `pop-random', because we have already + ;; sorted overdue items into a random order which takes + ;; number of days overdue into account. + (pop *org-drill-overdue-entries*)) + ;; Next priority is 'young' items. + ((and *org-drill-young-mature-entries* + (not (org-drill-maximum-item-count-reached-p)) + (not (org-drill-maximum-duration-reached-p))) + (pop-random *org-drill-young-mature-entries*)) + ;; Next priority is newly added items, and older entries. + ;; We pool these into a single group. + ((and (or *org-drill-new-entries* + *org-drill-old-mature-entries*) + (not (org-drill-maximum-item-count-reached-p)) + (not (org-drill-maximum-duration-reached-p))) + (cond + ((< (random* (+ (length *org-drill-new-entries*) + (length *org-drill-old-mature-entries*))) + (length *org-drill-new-entries*)) + (pop-random *org-drill-new-entries*)) + (t + (pop-random *org-drill-old-mature-entries*)))) + ;; After all the above are done, last priority is items + ;; that were failed earlier THIS SESSION. + (*org-drill-again-entries* + (pop *org-drill-again-entries*)) + (t ; nothing left -- return nil + (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. + +RESUMING-P is true if we are resuming a suspended drill session." + (block org-drill-entries + (while (org-drill-entries-pending-p) + (let ((m (cond + ((or (not resuming-p) + (null *org-drill-current-item*) + (not (org-drill-entry-p *org-drill-current-item*))) + (org-drill-pop-next-pending-entry)) + (t ; resuming a suspended session. + (setq resuming-p nil) + *org-drill-current-item*)))) + (setq *org-drill-current-item* m) + (unless m + (error "Unexpectedly ran out of pending drill items")) + (save-excursion + (org-drill-goto-entry m) + (cond + ((not (org-drill-entry-due-p)) + ;; The entry is not due anymore. This could arise if the user + ;; suspends a drill session, then drills an individual entry, + ;; then resumes the session. + (message "Entry no longer due, skipping...") + (sit-for 0.3) + nil) + (t + (setq result (org-drill-entry)) + (cond + ((null result) + (message "Quit") + (setq end-pos :quit) + (return-from org-drill-entries nil)) + ((eql result 'edit) + (setq end-pos (point-marker)) + (return-from org-drill-entries nil)) + ((eql result 'skip) + (setq *org-drill-current-item* nil) + nil) ; skip this item + (t + (cond + ((<= result org-drill-failure-quality) + (if *org-drill-again-entries* + (setq *org-drill-again-entries* + (shuffle-list *org-drill-again-entries*))) + (push-end m *org-drill-again-entries*)) + (t + (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) + (> qual org-drill-failure-quality)) + *org-drill-session-qualities*)) + (max 1 (length *org-drill-session-qualities*)))) + (prompt nil) + (max-mini-window-height 0.6)) + (setq prompt + (format + "%d items reviewed. Session duration %s. +Recall of reviewed items: + Excellent (5): %3d%% | Near miss (2): %3d%% + Good (4): %3d%% | Failure (1): %3d%% + Hard (3): %3d%% | Abject failure (0): %3d%% + +You successfully recalled %d%% of reviewed items (quality > %s) +%d/%d items still await review (%s, %s, %s, %s, %s). +Tomorrow, %d more items will become due for review. +Session finished. Press a key to continue..." + (length *org-drill-done-entries*) + (format-seconds "%h:%.2m:%.2s" + (- (float-time (current-time)) *org-drill-start-time*)) + (round (* 100 (count 5 *org-drill-session-qualities*)) + (max 1 (length *org-drill-session-qualities*))) + (round (* 100 (count 2 *org-drill-session-qualities*)) + (max 1 (length *org-drill-session-qualities*))) + (round (* 100 (count 4 *org-drill-session-qualities*)) + (max 1 (length *org-drill-session-qualities*))) + (round (* 100 (count 1 *org-drill-session-qualities*)) + (max 1 (length *org-drill-session-qualities*))) + (round (* 100 (count 3 *org-drill-session-qualities*)) + (max 1 (length *org-drill-session-qualities*))) + (round (* 100 (count 0 *org-drill-session-qualities*)) + (max 1 (length *org-drill-session-qualities*))) + pass-percent + org-drill-failure-quality + (org-drill-pending-entry-count) + (+ (org-drill-pending-entry-count) + *org-drill-dormant-entry-count*) + (propertize + (format "%d failed" + (+ (length *org-drill-failed-entries*) + (length *org-drill-again-entries*))) + 'face `(:foreground ,org-drill-failed-count-color)) + (propertize + (format "%d overdue" + (length *org-drill-overdue-entries*)) + 'face `(:foreground ,org-drill-failed-count-color)) + (propertize + (format "%d new" + (length *org-drill-new-entries*)) + 'face `(:foreground ,org-drill-new-count-color)) + (propertize + (format "%d young" + (length *org-drill-young-mature-entries*)) + 'face `(:foreground ,org-drill-mature-count-color)) + (propertize + (format "%d old" + (length *org-drill-old-mature-entries*)) + 'face `(:foreground ,org-drill-mature-count-color)) + *org-drill-due-tomorrow-count* + )) + + (while (not (input-pending-p)) + (message "%s" prompt) + (sit-for 0.5)) + (read-char-exclusive) + + (if (and *org-drill-session-qualities* + (< pass-percent (- 100 org-drill-forgetting-index))) + (read-char-exclusive + (format + "%s +You failed %d%% of the items you reviewed during this session. +%d (%d%%) of all items scanned were overdue. + +Are you keeping up with your items, and reviewing them +when they are scheduled? If so, you may want to consider +lowering the value of `org-drill-learn-fraction' slightly in +order to make items appear more frequently over time." + (propertize "WARNING!" 'face 'org-warning) + (- 100 pass-percent) + *org-drill-overdue-entry-count* + (round (* 100 *org-drill-overdue-entry-count*) + (+ *org-drill-dormant-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 +point nowhere). Alternatively, MARKERS can be 't', in which case +all the markers used by Org-Drill will be freed." + (dolist (m (if (eql t markers) + (append *org-drill-done-entries* + *org-drill-new-entries* + *org-drill-failed-entries* + *org-drill-again-entries* + *org-drill-overdue-entries* + *org-drill-young-mature-entries* + *org-drill-old-mature-entries*) + markers)) + (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) + (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 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 +- :new +- :failed +- :overdue +- :young +- :old +" + (save-excursion + (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 + ((not (org-drill-entry-p)) + nil) + ((and (org-entry-empty-p) + (let* ((card-type (org-entry-get (point) "DRILL_CARD_TYPE" nil)) + (dat (cdr (assoc card-type org-drill-card-type-alist)))) + (or (null card-type) + (not (third dat))))) + ;; body is empty, and this is not a card type where empty bodies are + ;; meaningful, so skip it. + nil) + ((null due) ; unscheduled - usually a skipped leech + :unscheduled) + ;; ((eql -1 due) + ;; :tomorrow) + ((minusp due) ; scheduled in the future + :future) + ;; The rest of the stati all denote 'due' items ========================== + ((<= (org-drill-entry-last-quality 9999) + org-drill-failure-quality) + ;; Mature entries that were failed last time are + ;; FAILED, regardless of how young, old or overdue + ;; they are. + :failed) + ((org-drill-entry-new-p) + :new) + ((org-drill-entry-overdue-p due last-int) + ;; Overdue status overrides young versus old + ;; distinction. + ;; Store marker + due, for sorting of overdue entries + :overdue) + ((<= (org-drill-entry-last-interval 9999) + org-drill-days-before-old) + :young) + (t + :old)) + due age)))) + + +(defun org-drill-progress-message (collected scanned) + (when (zerop (% scanned 50)) + (let* ((meter-width 40) + (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-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 +hidden. The user attempts to recall the hidden information or +answer the question, then presses a key to reveal the answer. The +user then rates his or her recall or performance on that +topic. This rating information is used to reschedule the topic +for future review. + +Org-drill proceeds by: + +- Finding all topics (headings) in SCOPE which have either been + used and rescheduled before, or which have a tag that matches + `org-drill-question-tag'. + +- All matching topics which are either unscheduled, or are + scheduled for the current date or a date in the past, are + considered to be candidates for the drill session. + +- If `org-drill-maximum-items-per-session' is set, a random + subset of these topics is presented. Otherwise, all of the + eligible topics will be presented. + +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)) + (block org-drill + (unless resume-p + (org-drill-free-markers t) + (setq *org-drill-current-item* nil + *org-drill-done-entries* nil + *org-drill-dormant-entry-count* 0 + *org-drill-due-entry-count* 0 + *org-drill-due-tomorrow-count* 0 + *org-drill-overdue-entry-count* 0 + *org-drill-new-entries* nil + *org-drill-overdue-entries* nil + *org-drill-young-mature-entries* nil + *org-drill-old-mature-entries* nil + *org-drill-failed-entries* nil + *org-drill-again-entries* nil) + (setq *org-drill-session-qualities* nil) + (setq *org-drill-start-time* (float-time (current-time)))) + (setq *random-state* (make-random-state t)) ; reseed RNG + (unwind-protect + (save-excursion + (unless resume-p + (let ((org-trust-scanner-tags t) + (warned-about-id-creation nil)) + (org-map-drill-entries + '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*)))) + (setq *org-drill-due-entry-count* (org-drill-pending-entry-count)) + (cond + ((and (null *org-drill-current-item*) + (null *org-drill-new-entries*) + (null *org-drill-failed-entries*) + (null *org-drill-overdue-entries*) + (null *org-drill-young-mature-entries*) + (null *org-drill-old-mature-entries*)) + (message "I did not find any pending drill items.")) + (t + (org-drill-entries resume-p) + (message "Drill session finished!")))) + (progn + (unless end-pos + (setq *org-drill-cram-mode* nil) + (org-drill-free-markers *org-drill-done-entries*))))) + (cond + (end-pos + (when (markerp end-pos) + (org-drill-goto-entry end-pos) + (org-reveal) + (org-show-entry)) + (let ((keystr (command-keybinding-to-string 'org-drill-resume))) + (message + "You can continue the drill session with the command `org-drill-resume'.%s" + (if keystr (format "\nYou can run this command by pressing %s." keystr) + "")))) + (t + (org-drill-final-report) + (if (eql 'sm5 org-drill-spaced-repetition-algorithm) + (org-drill-save-optimal-factor-matrix)) + (if org-drill-save-buffers-after-drill-sessions-p + (save-some-buffers)) + (message "Drill session finished!") + )))) + + +(defun org-drill-save-optimal-factor-matrix () + (savehist-autosave)) + + +(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 drill-match)) + + +(defun org-drill-tree () + "Run an interactive drill session using drill items within the +subtree at point." + (interactive) + (org-drill 'tree)) + + +(defun org-drill-directory () + "Run an interactive drill session using drill items from all org +files in the same directory as the current file." + (interactive) + (org-drill 'directory)) + + +(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 +scan will be performed." + (interactive) + (setq *org-drill-cram-mode* nil) + (cond + ((plusp (org-drill-pending-entry-count)) + (org-drill-free-markers *org-drill-done-entries*) + (if (markerp *org-drill-current-item*) + (free-marker *org-drill-current-item*)) + (setq *org-drill-start-time* (float-time (current-time)) + *org-drill-done-entries* nil + *org-drill-current-item* nil) + (org-drill scope drill-match t)) + (t + (org-drill scope drill-match)))) + + + +(defun org-drill-resume () + "Resume a suspended drill session. Sessions are suspended by +exiting them with the `edit' or `quit' options." + (interactive) + (cond + ((org-drill-entries-pending-p) + (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. + (y-or-n-p (format + "You have finished the drill session. However, %d items still +need reviewing. Start a new drill session? " + (org-drill-pending-entry-count)))) + (org-drill-again)) + (t + (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 '(4))) + + +(defun org-drill-strip-all-data (&optional scope) + "Delete scheduling data from every drill entry in scope. This +function may be useful if you want to give your collection of +entries to someone else. Scope defaults to the current buffer, +and is specified by the argument SCOPE, which accepts the same +values as `org-drill-scope'." + (interactive) + (when (yes-or-no-p + "Delete scheduling data from ALL items in scope: are you sure?") + (cond + ((null scope) + ;; Scope is the current buffer. This means we can use + ;; `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 '(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 + (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 ================================================= + + +(defvar *org-drill-dest-id-table* (make-hash-table :test 'equal)) + + +(defun org-drill-copy-entry-to-other-buffer (dest &optional path) + "Copy the subtree at point to the buffer DEST. The copy will receive +the tag 'imported'." + (block org-drill-copy-entry-to-other-buffer + (save-excursion + (let ((src (current-buffer)) + (m nil)) + (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) + (switch-to-buffer dest) + (setq m + (condition-case nil + (org-find-olp path t) + (error ; path does not exist in DEST + (return-from org-drill-copy-entry-to-other-buffer + (cond + ((cdr path) + (org-drill-copy-entry-to-other-buffer + dest (butlast path))) + (t + ;; We've looked all the way up the path + ;; Default to appending to the end of DEST + (goto-char (point-max)) + (newline) + (paste-tree-here))))))) + (goto-char m) + (outline-next-heading) + (newline) + (forward-line -1) + (paste-tree-here (1+ (or (org-current-level) 0))) + ))))) + + + +(defun org-drill-merge-buffers (src &optional dest ignore-new-items-p) + "SRC and DEST are two org mode buffers containing drill items. +For each drill item in DEST that shares an ID with an item in SRC, +overwrite scheduling data in DEST with data taken from the item in SRC. +This is intended for use when two people are sharing a set of drill items, +one person has made some updates to the item set, and the other person +wants to migrate to the updated set without losing their scheduling data. + +By default, any drill items in SRC which do not exist in DEST are +copied into DEST. We attempt to place the copied item in the +equivalent location in DEST to its location in SRC, by matching +the heading hierarchy. However if IGNORE-NEW-ITEMS-P is non-nil, +we simply ignore any items that do not exist in DEST, and do not +copy them across." + (interactive "bImport scheduling info from which buffer?") + (unless dest + (setq dest (current-buffer))) + (setq src (get-buffer src) + dest (get-buffer dest)) + (when (yes-or-no-p + (format + (concat "About to overwrite all scheduling data for drill items in `%s' " + "with information taken from matching items in `%s'. Proceed? ") + (buffer-name dest) (buffer-name src))) + ;; Compile list of all IDs in the destination buffer. + (clrhash *org-drill-dest-id-table*) + (with-current-buffer dest + (org-map-drill-entries + (lambda () + (let ((this-id (org-id-get))) + (when this-id + (puthash this-id (point-marker) *org-drill-dest-id-table*)))) + 'file)) + ;; Look through all entries in source buffer. + (with-current-buffer src + (org-map-drill-entries + (lambda () + (let ((id (org-id-get)) + (last-quality nil) (last-reviewed nil) + (scheduled-time nil)) + (cond + ((or (null id) + (not (org-drill-entry-p))) + nil) + ((gethash id *org-drill-dest-id-table*) + ;; This entry matches an entry in dest. Retrieve all its + ;; scheduling data, then go to the matching location in dest + ;; and write the data. + (let ((marker (gethash id *org-drill-dest-id-table*))) + (destructuring-bind (last-interval repetitions failures + total-repeats meanq ease) + (org-drill-get-item-data) + (setq last-reviewed (org-entry-get (point) "DRILL_LAST_REVIEWED") + last-quality (org-entry-get (point) "DRILL_LAST_QUALITY") + scheduled-time (org-get-scheduled-time (point))) + (save-excursion + ;; go to matching entry in destination buffer + (switch-to-buffer (marker-buffer marker)) + (goto-char marker) + (org-drill-strip-entry-data) + (unless (zerop total-repeats) + (org-drill-store-item-data last-interval repetitions failures + total-repeats meanq ease) + (if last-quality + (org-set-property "LAST_QUALITY" last-quality) + (org-delete-property "LAST_QUALITY")) + (if last-reviewed + (org-set-property "LAST_REVIEWED" last-reviewed) + (org-delete-property "LAST_REVIEWED")) + (if scheduled-time + (org-schedule nil scheduled-time))))) + (remhash id *org-drill-dest-id-table*) + (free-marker marker))) + (t + ;; item in SRC has ID, but no matching ID in DEST. + ;; It must be a new item that does not exist in DEST. + ;; Copy the entire item to the *end* of DEST. + (unless ignore-new-items-p + (org-drill-copy-entry-to-other-buffer dest)))))) + 'file)) + ;; Finally: there may be some items in DEST which are not in SRC, and + ;; which have been scheduled by another user of DEST. Clear out the + ;; scheduling info from all the unmatched items in DEST. + (with-current-buffer dest + (maphash (lambda (id m) + (goto-char m) + (org-drill-strip-entry-data) + (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 + +(defvar org-drill-verb-tense-alist + '(("present" "tomato") + ("simple present" "tomato") + ("present indicative" "tomato") + ;; past tenses + ("past" "purple") + ("simple past" "purple") + ("preterite" "purple") + ("imperfect" "darkturquoise") + ("present perfect" "royalblue") + ;; future tenses + ("future" "green") + ;; moods (backgrounds). + ("indicative" nil) ; default + ("subjunctive" "medium blue") + ("conditional" "grey30") + ("negative imperative" "red4") + ("positive imperative" "darkgreen") + ) + "Alist where each entry has the form (TENSE COLOUR), where +TENSE is a string naming a tense in which verbs can be +conjugated, and COLOUR is a string specifying a foreground colour +which will be used by `org-drill-present-verb-conjugation' and +`org-drill-show-answer-verb-conjugation' to fontify the verb and +the name of the tense.") + + +(defun org-drill-get-verb-conjugation-info () + "Auxiliary function used by `org-drill-present-verb-conjugation' and +`org-drill-show-answer-verb-conjugation'." + (let ((infinitive (org-entry-get (point) "VERB_INFINITIVE" t)) + (inf-hint (org-entry-get (point) "VERB_INFINITIVE_HINT" t)) + (translation (org-entry-get (point) "VERB_TRANSLATION" t)) + (tense (org-entry-get (point) "VERB_TENSE" nil)) + (mood (org-entry-get (point) "VERB_MOOD" nil)) + (highlight-face nil)) + (unless (and infinitive translation (or tense mood)) + (error "Missing information for verb conjugation card (%s, %s, %s, %s) at %s" + infinitive translation tense mood (point))) + (setq tense (if tense (downcase (car (read-from-string tense)))) + mood (if mood (downcase (car (read-from-string mood)))) + infinitive (car (read-from-string infinitive)) + inf-hint (if inf-hint (car (read-from-string inf-hint))) + translation (car (read-from-string translation))) + (setq highlight-face + (list :foreground + (or (second (assoc-string tense org-drill-verb-tense-alist t)) + "hotpink") + :background + (second (assoc-string mood org-drill-verb-tense-alist t)))) + (setq infinitive (propertize infinitive 'face highlight-face)) + (setq translation (propertize translation 'face highlight-face)) + (if tense (setq tense (propertize tense 'face highlight-face))) + (if mood (setq mood (propertize mood 'face highlight-face))) + (list infinitive inf-hint translation tense mood))) + + +(defun org-drill-present-verb-conjugation () + "Present a drill entry whose card type is 'conjugate'." + (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 + (cond + ((zerop (random* 2)) + (format "\nTranslate the verb\n\n%s\n\nand conjugate for the %s.\n\n" + infinitive (tense-and-mood-to-string tense mood))) + + (t + (format "\nGive the verb that means\n\n%s %s\n +and conjugate for the %s.\n\n" + translation + (if inf-hint (format " [HINT: %s]" inf-hint) "") + (tense-and-mood-to-string tense mood)))))))) + + +(defun org-drill-show-answer-verb-conjugation (reschedule-fn) + "Show the answer for a drill item whose card type is 'conjugate'. +RESCHEDULE-FN must be a function that calls `org-drill-reschedule' and +returns its return value." + (destructuring-bind (infinitive inf-hint translation tense mood) + (org-drill-get-verb-conjugation-info) + (with-replaced-entry-heading + (format "%s of %s ==> %s\n\n" + (capitalize + (cond + ((and tense mood) + (format "%s tense, %s mood" tense mood)) + (tense + (format "%s tense" tense)) + (mood + (format "%s mood" mood)))) + infinitive translation) + (org-cycle-hide-drawers 'all) + (funcall reschedule-fn)))) + + +;;; `decline_noun' card type ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defvar org-drill-noun-gender-alist + '(("masculine" "dodgerblue") + ("masc" "dodgerblue") + ("male" "dodgerblue") + ("m" "dodgerblue") + ("feminine" "orchid") + ("fem" "orchid") + ("female" "orchid") + ("f" "orchid") + ("neuter" "green") + ("neutral" "green") + ("neut" "green") + ("n" "green") + )) + + +(defun org-drill-get-noun-info () + "Auxiliary function used by `org-drill-present-noun-declension' and +`org-drill-show-answer-noun-declension'." + (let ((noun (org-entry-get (point) "NOUN" t)) + (noun-hint (org-entry-get (point) "NOUN_HINT" t)) + (noun-root (org-entry-get (point) "NOUN_ROOT" t)) + (noun-gender (org-entry-get (point) "NOUN_GENDER" t)) + (translation (org-entry-get (point) "NOUN_TRANSLATION" t)) + (highlight-face nil)) + (unless (and noun translation) + (error "Missing information for `decline_noun' card (%s, %s, %s, %s) at %s" + noun translation noun-hint noun-root (point))) + (setq noun-root (if noun-root (car (read-from-string noun-root))) + noun (car (read-from-string noun)) + noun-gender (downcase (car (read-from-string noun-gender))) + noun-hint (if noun-hint (car (read-from-string noun-hint))) + translation (car (read-from-string translation))) + (setq highlight-face + (list :foreground + (or (second (assoc-string noun-gender + org-drill-noun-gender-alist t)) + "red"))) + (setq noun (propertize noun 'face highlight-face)) + (setq translation (propertize translation 'face highlight-face)) + (list noun noun-root noun-gender noun-hint translation))) + + +(defun org-drill-present-noun-declension () + "Present a drill entry whose card type is 'decline_noun'." + (destructuring-bind (noun noun-root noun-gender noun-hint translation) + (org-drill-get-noun-info) + (let* ((props (org-entry-properties (point))) + (definite + (cond + ((assoc "DECLINE_DEFINITE" props) + (propertize (if (org-entry-get (point) "DECLINE_DEFINITE") + "definite" "indefinite") + 'face 'warning)) + (t nil))) + (plural + (cond + ((assoc "DECLINE_PLURAL" props) + (propertize (if (org-entry-get (point) "DECLINE_PLURAL") + "plural" "singular") + 'face 'warning)) + (t nil)))) + (org-drill-present-card-using-text + (cond + ((zerop (random* 2)) + (format "\nTranslate the noun\n\n%s (%s)\n\nand list its declensions%s.\n\n" + noun noun-gender + (if (or plural definite) + (format " for the %s %s form" definite plural) + ""))) + (t + (format "\nGive the noun that means\n\n%s %s\n +and list its declensions%s.\n\n" + translation + (if noun-hint (format " [HINT: %s]" noun-hint) "") + (if (or plural definite) + (format " for the %s %s form" definite plural) + "")))))))) + + +(defun org-drill-show-answer-noun-declension (reschedule-fn) + "Show the answer for a drill item whose card type is 'decline_noun'. +RESCHEDULE-FN must be a function that calls `org-drill-reschedule' and +returns its return value." + (destructuring-bind (noun noun-root noun-gender noun-hint translation) + (org-drill-get-noun-info) + (with-replaced-entry-heading + (format "Declensions of %s (%s) ==> %s\n\n" + noun noun-gender translation) + (org-cycle-hide-drawers 'all) + (funcall reschedule-fn)))) + + +;;; `translate_number' card type ============================================== +;;; See spanish.org for usage + + +(defun spelln-integer-in-language (n lang) + (let ((spelln-language lang)) + (spelln-integer-in-words n))) + +(defun org-drill-present-translate-number () + (let ((num-min (read (org-entry-get (point) "DRILL_NUMBER_MIN"))) + (num-max (read (org-entry-get (point) "DRILL_NUMBER_MAX"))) + (language (read (org-entry-get (point) "DRILL_LANGUAGE" t))) + (drilled-number 0) + (drilled-number-direction 'to-english) + (highlight-face 'font-lock-warning-face)) + (cond + ((not (fboundp 'spelln-integer-in-words)) + (message "`spell-number.el' not loaded, skipping 'translate_number' card...") + (sit-for 0.5) + 'skip) + ((not (and (numberp num-min) (numberp num-max) language)) + (error "Missing language or minimum or maximum numbers for number card")) + (t + (if (> num-min num-max) + (psetf num-min num-max + num-max num-min)) + (setq drilled-number + (+ num-min (random* (abs (1+ (- num-max num-min)))))) + (setq drilled-number-direction + (if (zerop (random* 2)) 'from-english 'to-english)) + (cond + ((eql 'to-english drilled-number-direction) + (org-drill-present-card-using-text + (format "\nTranslate into English:\n\n%s\n" + (propertize + (spelln-integer-in-language drilled-number language) + 'face highlight-face)) + (spelln-integer-in-language drilled-number 'english-gb))) + (t + (org-drill-present-card-using-text + (format "\nTranslate into %s:\n\n%s\n" + (capitalize (format "%s" language)) + (propertize + (spelln-integer-in-language drilled-number 'english-gb) + '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) +;; (non-english +;; (let ((spelln-language language)) +;; (propertize (spelln-integer-in-words *drilled-number*) +;; 'face highlight-face))) +;; (english +;; (let ((spelln-language 'english-gb)) +;; (propertize (spelln-integer-in-words *drilled-number*) +;; 'face 'highlight-face)))) +;; (with-replaced-entry-text +;; (cond +;; ((eql 'to-english *drilled-number-direction*) +;; (format "\nThe English translation of %s is:\n\n%s\n" +;; non-english english)) +;; (t +;; (format "\nThe %s translation of %s is:\n\n%s\n" +;; (capitalize (format "%s" language)) +;; english non-english))) +;; (funcall reschedule-fn)))) + + +;;; `spanish_verb' card type ================================================== +;;; Not very interesting, but included to demonstrate how a presentation +;;; function can manipulate which subheading are hidden versus shown. + + +(defun org-drill-present-spanish-verb () + (let ((prompt nil) + (reveal-headings nil)) + (with-hidden-comments + (with-hidden-cloze-hints + (with-hidden-cloze-text + (case (random* 6) + (0 + (org-drill-hide-all-subheadings-except '("Infinitive")) + (setq prompt + (concat "Translate this Spanish verb, and conjugate it " + "for the *present* tense.") + reveal-headings '("English" "Present Tense" "Notes"))) + (1 + (org-drill-hide-all-subheadings-except '("English")) + (setq prompt (concat "For the *present* tense, conjugate the " + "Spanish translation of this English verb.") + reveal-headings '("Infinitive" "Present Tense" "Notes"))) + (2 + (org-drill-hide-all-subheadings-except '("Infinitive")) + (setq prompt (concat "Translate this Spanish verb, and " + "conjugate it for the *past* tense.") + reveal-headings '("English" "Past Tense" "Notes"))) + (3 + (org-drill-hide-all-subheadings-except '("English")) + (setq prompt (concat "For the *past* tense, conjugate the " + "Spanish translation of this English verb.") + reveal-headings '("Infinitive" "Past Tense" "Notes"))) + (4 + (org-drill-hide-all-subheadings-except '("Infinitive")) + (setq prompt (concat "Translate this Spanish verb, and " + "conjugate it for the *future perfect* tense.") + reveal-headings '("English" "Future Perfect Tense" "Notes"))) + (5 + (org-drill-hide-all-subheadings-except '("English")) + (setq prompt (concat "For the *future perfect* tense, conjugate the " + "Spanish translation of this English verb.") + reveal-headings '("Infinitive" "Future Perfect Tense" "Notes")))) + (org-cycle-hide-drawers 'all) + (prog1 (org-drill-presentation-prompt) + (org-drill-hide-subheadings-if 'org-drill-entry-p))))))) + + +(provide 'org-drill) diff --git a/contrib/lisp/org-ebib.el b/contrib/lisp/org-ebib.el new file mode 100644 index 0000000..4ed5e50 --- /dev/null +++ b/contrib/lisp/org-ebib.el @@ -0,0 +1,47 @@ +;;; org-ebib.el - Support for links to Ebib's entries in Org +;; +;; Author: Grégoire Jadi <daimrod@gmail.com> +;; +;; This file is not yet part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +(require 'org) + +(org-link-set-parameters "ebib" + :follow #'org-ebib-open + :store #'org-ebib-store-link) + +(defun org-ebib-open (key) + "Open Ebib and jump to KEY." + (ebib nil key)) + +(defun org-ebib-store-link () + "Store a key to an Ebib entry." + (when (memq major-mode '(ebib-index-mode ebib-entry-mode)) + ;; This is an Ebib entry + (let* ((key (ebib-cur-entry-key)) + (link (concat "ebib:" key)) + (description (ignore-errors (ebib-db-get-field-value 'title key ebib-cur-db)))) + (org-store-link-props + :type "ebib" + :link link + :description description)))) + +(provide 'org-ebib) + +;;; org-ebib.el ends here diff --git a/contrib/lisp/org-effectiveness.el b/contrib/lisp/org-effectiveness.el new file mode 100644 index 0000000..a07084c --- /dev/null +++ b/contrib/lisp/org-effectiveness.el @@ -0,0 +1,369 @@ +;;; org-effectiveness.el --- Measuring the personal effectiveness + +;; Copyright (C) 2013-2017 Free Software Foundation, Inc. + +;; Author: David Arroyo Menéndez <davidam@es.gnu.org> +;; Keywords: effectiveness, plot +;; Homepage: http://orgmode.org +;; +;; This file is not part of GNU Emacs, yet. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file implements functions to measure the effectiveness in org. +;; Org-mode doesn't load this module by default - if this is not what +;; you want, configure the variable `org-modules'. Thanks to #emacs-es +;; irc channel for your support. + +;;; Code: + +(require 'org) + +(defcustom org-effectiveness-max-todo 50 + "This variable is useful to advice to the user about +many TODO pending" + :type 'integer + :group 'org-effectiveness) + +(defun org-effectiveness-advice() + "Advicing about a possible excess of TODOS" + (interactive) + (save-excursion + (goto-char (point-min)) + (if (< org-effectiveness-max-todo (count-matches "* TODO")) + (message "An excess of TODOS!")))) + +;; Check advice starting an org file +(add-hook 'org-mode-hook 'org-effectiveness-advice) + +(defun org-effectiveness-count-keyword(keyword) + "Print a message with the number of keyword outline in the current buffer" + (interactive "sKeyword: ") + (save-excursion + (goto-char (point-min)) + (message "Number of %s: %d" keyword (count-matches (concat "* " keyword))))) + +(defun org-effectiveness-count-todo() + "Print a message with the number of todo tasks in the current buffer" + (interactive) + (save-excursion + (goto-char (point-min)) + (message "Number of TODO: %d" (count-matches "* TODO")))) + +(defun org-effectiveness-count-done() + "Print a message with the number of done tasks in the current buffer" + (interactive) + (save-excursion + (goto-char (point-min)) + (message "Number of DONE: %d" (count-matches "* DONE")))) + +(defun org-effectiveness-count-canceled() + "Print a message with the number of canceled tasks in the current buffer" + (interactive) + (save-excursion + (goto-char (point-min)) + (message "Number of Canceled: %d" (count-matches "* CANCEL+ED")))) + +(defun org-effectiveness-count-task() + "Print a message with the number of tasks and subtasks in the current buffer" + (interactive) + (save-excursion + (goto-char (point-min)) + (message "Number of tasks: %d" (count-matches "^*")))) + +(defun org-effectiveness() + "Returns the effectiveness in the current org buffer" + (interactive) + (save-excursion + (goto-char (point-min)) + (let ((done (float (count-matches "* DONE.*\n.*"))) + (canc (float (count-matches "* CANCEL+ED.*\n.*")))) + (if (and (= done canc) (zerop done)) + (setq effectiveness 0) + (setq effectiveness (* 100 (/ done (+ done canc))))) + (message "Effectiveness: %f" effectiveness)))) + + +(defun org-effectiveness-keywords-in-date(keyword date) + (interactive "sKeyword: \nsDate: " keyword date) + (setq count (count-matches (concat keyword ".*\n.*" date))) + (message (concat "%sS: %d" keyword count))) + +(defun org-effectiveness-dones-in-date(date &optional notmessage) + (interactive "sGive me a date: " date) + (save-excursion + (goto-char (point-min)) + (let ((count (count-matches (concat "DONE.*\n.*" date)))) + (if (eq notmessage 1) + (message "%d" count) + (message "DONES: %d " count))))) + +(defun org-effectiveness-todos-in-date(date) + (interactive "sGive me a date: " date) + (save-excursion + (goto-char (point-min)) + (setq count (count-matches (concat "TODO.*\n.*" date))) + (message "TODOS: %d" count))) + +(defun org-effectiveness-canceled-in-date(date) + (interactive "sGive me a date: " date) + (save-excursion + (goto-char (point-min)) + (setq count (count-matches (concat "CANCEL+ED.*\n.*" date))) + (message "CANCELEDS: %d" count))) + +(defun org-effectiveness-ntasks-in-date(date &optional notmessage) + (interactive "sGive me a date: " date) + (save-excursion + (goto-char (point-min)) + (let ((tasks (float (count-matches (concat "^*.*\n.*" date))))) + (message "%d" tasks)))) + +(defun org-effectiveness-in-date(date &optional notmessage) + (interactive "sGive me a date: " date) + (save-excursion + (goto-char (point-min)) + (let ((done (float (count-matches (concat "* DONE.*\n.*" date)))) + (canc (float (count-matches (concat "* CANCEL+ED.*\n.*" date))))) + (if (and (= done canc) (zerop done)) + (setq effectiveness 0) + (setq effectiveness (* 100 (/ done (+ done canc))))) + (if (eq notmessage 1) + (message "%d" effectiveness) + (message "Effectiveness: %d " effectiveness))))) + +(defun org-effectiveness-month-to-string (m) + (if (< m 10) + (concat "0" (number-to-string m)) + (number-to-string m))) + +(defun org-effectiveness-plot(startdate enddate &optional save) + (interactive "sGive me the start date: \nsGive me the end date: " startdate enddate) + (setq dates (org-effectiveness-check-dates startdate enddate)) + (setq syear (cadr (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)) + (message "The start date must have the next format YYYY-MM")) + (if (not (string-match "[0-9][0-9][0-9][0-9]-[0-9][0-9]" enddate)) + (message "The end date must have the next format YYYY-MM")) +;; Checking if startdate < enddate + (if (string-match "^[0-9][0-9][0-9][0-9]" startdate) + (setq startyear (string-to-number (match-string 0 startdate)))) + (if (string-match "[0-9][0-9]$" startdate) + (setq startmonth (string-to-number (match-string 0 startdate)))) + (if (string-match "^[0-9][0-9][0-9][0-9]" enddate) + (setq endyear (string-to-number (match-string 0 enddate)))) + (if (string-match "[0-9][0-9]$" enddate) + (setq endmonth (string-to-number (match-string 0 enddate)))) + (if (> startyear endyear) + (message "The start date must be before that end date")) + (if (and (= startyear endyear) (> startmonth endmonth)) + (message "The start date must be before that end date")) +;; Create a file + (let ((month startmonth) + (year startyear) + (str "")) + (while (or (> endyear year) (and (= endyear year) (>= endmonth month))) + (setq str (concat str (number-to-string year) "-" (org-effectiveness-month-to-string month) " " (org-effectiveness-in-date (concat (number-to-string year) "-" (org-effectiveness-month-to-string month)) 1) "\n")) + (if (= month 12) + (progn + (setq year (+ 1 year)) + (setq month 1)) + (setq month (+ 1 month)))) + (write-region str nil "/tmp/org-effectiveness")) +;; Create the bar graph + (if (eq save t) + (setq strplot "/usr/bin/gnuplot -e 'set term png; set output \"/tmp/org-effectiveness.png\"; plot \"/tmp/org-effectiveness\" using 2:xticlabels(1) with histograms' -p") + (setq strplot "/usr/bin/gnuplot -e 'plot \"/tmp/org-effectiveness\" using 2:xticlabels(1) with histograms' -p")) + (if (file-exists-p "/usr/bin/gnuplot") + (call-process "/bin/bash" nil t nil "-c" strplot) + (message "gnuplot is not installed"))) + +(defun org-effectiveness-plot-save(startdate enddate &optional save) + (interactive "sGive me the start date: \nsGive me the end date: " startdate enddate) + (org-effectiveness-plot startdate enddate t)) + +;; (defun org-effectiveness-plot(startdate enddate) + + +(defun org-effectiveness-ascii-bar(n &optional label) + "Print a bar with the percentage from 0 to 100 printed in ascii" + (interactive "nPercentage: \nsLabel: ") + (if (or (< n 0) (> n 100)) + (message "The percentage must be between 0 to 100") + (let ((x 0) + (y 0) + (z 0)) + (insert (format "\n### %s ###" label)) + (insert "\n-") + (while (< x n) + (insert "-") + (setq x (+ x 1))) + (insert "+\n") + (insert (format "%d" n)) + (if (> n 10) + (setq y (+ y 1))) + (while (< y n) + (insert " ") + (setq y (+ y 1))) + (insert "|\n") + (insert "-") + (while (< z n) + (insert "-") + (setq z (+ z 1))) + (insert "+")))) + +(defun org-effectiveness-html-bar(n &optional label) + "Print a bar with the percentage from 0 to 100 printed in html" + (interactive "nPercentage: \nsLabel: ") + (if (or (< n 0) (> n 100)) + (message "The percentage must be between 0 to 100") + (let ((x 0) + (y 0) + (z 0)) + (insert (format "\n<div class='percentage-%d'>%d</div>" n n)) +))) + + +(defun org-effectiveness-check-dates (startdate enddate) + "Generate a list with ((startyear startmonth) (endyear endmonth))" + (setq str nil) + (if (not (string-match "[0-9][0-9][0-9][0-9]-[0-9][0-9]" startdate)) + (setq str "The start date must have the next format YYYY-MM")) + (if (not (string-match "[0-9][0-9][0-9][0-9]-[0-9][0-9]" enddate)) + (setq str "The end date must have the next format YYYY-MM")) +;; Checking if startdate < enddate + (if (string-match "^[0-9][0-9][0-9][0-9]" startdate) + (setq startyear (string-to-number (match-string 0 startdate)))) + (if (string-match "[0-9][0-9]$" startdate) + (setq startmonth (string-to-number (match-string 0 startdate)))) + (if (string-match "^[0-9][0-9][0-9][0-9]" enddate) + (setq endyear (string-to-number (match-string 0 enddate)))) + (if (string-match "[0-9][0-9]$" enddate) + (setq endmonth (string-to-number (match-string 0 enddate)))) + (if (> startyear endyear) + (setq str "The start date must be before that end date")) + (if (and (= startyear endyear) (> startmonth endmonth)) + (setq str "The start date must be before that end date")) + (if str + (message str) +;; (list (list startyear startmonth) (list endyear endmonth)))) + (list (list 'startyear startyear) (list 'startmonth startmonth) (list 'endyear endyear) (list 'endmonth endmonth)))) + +(defun org-effectiveness-plot-ascii (startdate enddate) + (interactive "sGive me the start date: \nsGive me the end date: " startdate enddate) + (setq dates (org-effectiveness-check-dates startdate enddate)) + (let ((syear (cadr (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-in-date (concat (number-to-string year) "-" (org-effectiveness-month-to-string month)) 1)) + (switch-to-buffer "*org-effectiveness*") + (org-effectiveness-ascii-bar (string-to-number str) (format "%s-%s" year month)) + (switch-to-buffer buffer) + (if (eq month 12) + (progn + (setq year (+ 1 year)) + (setq month 1)) + (setq month (+ 1 month))))) + (switch-to-buffer "*org-effectiveness*")) + + +(defun org-effectiveness-plot-ascii-ntasks (startdate enddate) + (interactive "sGive me the start date: \nsGive me the end date: " startdate enddate) + (setq dates (org-effectiveness-check-dates startdate enddate)) + (let ((syear (cadr (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 --- /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 new file mode 100644 index 0000000..a089914 --- /dev/null +++ b/contrib/lisp/org-elisp-symbol.el @@ -0,0 +1,161 @@ +;;; org-elisp-symbol.el --- Org links to emacs-lisp symbols +;; +;; Copyright 2007-2017 Free Software Foundation, Inc. +;; +;; Author: Bastien Guerry +;; Version: 0.2 +;; Keywords: org, remember, lisp +;; URL: http://www.cognition.ens.fr/~guerry/u/org-elisp-symbol.el +;; +;; 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: +;; +;; Org-mode already lets you store/insert links to emacs-lisp files, +;; just like any other file. This package lets you precisely link to +;; any emacs-lisp symbol and access useful information about the symbol. +;; +;; Here is the list of available properties when linking from a elisp-symbol: +;; +;; :name The symbol's name. +;; :stype The symbol's type (commandp, function, etc.) +;; :def The function used to set the symbol's value (defun, etc.) +;; :keys The keys associated with the command. +;; :args The arguments of the function. +;; :docstring The docstring of the symbol. +;; :doc The first line of the dostring. +;; :comment A comment line just above the sexp, if any. +;; :fixme A FIXME comment line just above the sexp, if any. +;; +;; Let's say we have a defun like this one: +;; +;; ;; FIXME update docstring +;; (defun org-export-latex-lists () +;; "Convert lists to LaTeX." +;; (goto-char (point-min)) +;; (while (re-search-forward org-export-latex-list-beginning-re nil t) +;; (beginning-of-line) +;; (insert (org-list-to-latex (org-list-parse-list t)) "\n"))) +;; +;; And a remember template like: +;; +;; (setq org-remember-templates +;; '((?s "* DEBUG `%:name' (%:args)\n\n%?\n\nFixme: %:fixme\n \ +;; Doc: \"%:doc\"\n\n%a"))) +;; +;; Then M-x `org-remember' on this sexp will produce this buffer: +;; +;; ===================================================================== +;; * DEBUG `org-export-latex-lists' () +;; +;; <== point +;; +;; Fixme: update the docstring +;; Doc: "Convert lists to LaTeX." +;; +;; [[file:~/path/file.el::defun%20my-func][Function: my-func]] +;; ===================================================================== +;; +;; Put this file into your load-path and the following into your ~/.emacs: +;; (require 'org-elisp-symbol) + +;;; Code: + +(provide 'org-elisp-symbol) + +(require 'org) + +(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." + (let* ((search (when (string-match "::\\(.+\\)\\'" path) + (match-string 1 path))) + (path (substring path 0 (match-beginning 0)))) + (org-open-file path t nil search))) + +(defun org-elisp-symbol-store-link () + "Store a link to an emacs-lisp elisp-symbol." + (when (eq major-mode 'emacs-lisp-mode) + (save-excursion + (or (looking-at "^(") (beginning-of-defun)) + (looking-at "^(\\([a-z]+\\) \\([^)\n ]+\\) ?\n?[ \t]*\\(?:(\\(.*\\))\\)?") + (let* ((end (save-excursion + (save-match-data + (end-of-defun) (point)))) + (def (match-string 1)) + (name (match-string 2)) + (sym-name (intern-soft name)) + (stype (cond ((commandp sym-name) "Command") + ((functionp sym-name) "Function") + ((user-variable-p sym-name) "User variable") + ((string= def "defvar") "Variable") + ((string= def "defmacro") "Macro") + ((string= def "defun") "Function or command") + (t "Symbol"))) + (args (if (match-string 3) + (mapconcat (lambda (a) (unless (string-match "^&" a) a)) + (split-string (match-string 3)) " ") + "no arg")) + (docstring (cond ((functionp sym-name) + (or (documentation sym-name) + "[no documentation]")) + ((string-match "[Vv]ariable" stype) + (documentation-property sym-name + 'variable-documentation)) + (t "no documentation"))) + (doc (and (string-match "^\\([^\n]+\\)$" docstring) + (match-string 1 docstring))) + (fixme (save-excursion + (beginning-of-defun) (end-of-defun) + (if (re-search-forward "^;+ ?FIXME[ :]*\\(.*\\)$" end t) + (match-string 1) "nothing to fix"))) + (comment (save-excursion + (beginning-of-defun) (end-of-defun) + (if (re-search-forward "^;;+ ?\\(.*\\)$" end t) + (match-string 1) "no comment"))) + keys keys-desc link description) + (if (equal stype "Command") + (setq keys (where-is-internal sym-name) + keys-desc + (if keys (mapconcat 'key-description keys " ") "none"))) + (setq link (concat "file:" (abbreviate-file-name buffer-file-name) + "::" def " " name)) + (setq description (concat stype ": " name)) + (org-store-link-props + :type "elisp-symbol" + :link link + :description description + :def def + :name name + :stype stype + :args args + :keys keys-desc + :docstring docstring + :doc doc + :fixme fixme + :comment comment))))) + +(provide 'org-elisp-symbol) + + +;;;;########################################################################## +;;;; User Options, Variables +;;;;########################################################################## + +;;; org-elisp-symbol.el ends here diff --git a/contrib/lisp/org-eval-light.el b/contrib/lisp/org-eval-light.el new file mode 100644 index 0000000..57ac290 --- /dev/null +++ b/contrib/lisp/org-eval-light.el @@ -0,0 +1,199 @@ +;;; org-eval-light.el --- Display result of evaluating code in various languages (light) + +;; 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> +;; Keywords: outlines, hypermedia, calendar, wp, literate programming, +;; reproducible research +;; Homepage: http://orgmode.org +;; Version: 0.04 + +;; This file is not yet part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file is based off of org-eval, with the following changes. +;; +;; 1) forms are only executed manually, (allowing for the execution of +;; an entire subtree of forms) +;; 2) use the org-mode style src blocks, rather than the muse style +;; <code></code> blocks +;; 3) forms are not replaced by their outputs, but rather the output +;; is placed in the buffer immediately following the src block +;; commented by `org-eval-light-make-region-example' (when +;; evaluated with a prefix argument no output is placed in the +;; buffer) +;; 4) add defadvice to org-ctrl-c-ctrl-c so that when called inside of +;; a source block it will call `org-eval-light-current-snippet' + +;;; Code: +(require 'org) + +(defgroup org-eval-light nil + "Options concerning including output from commands into the Org-mode buffer." + :tag "Org Eval" + :group 'org) + +(defvar org-eval-light-example-size-cutoff 10 + "The number of lines under which an example is considered +'small', and is exported with the '^:' syntax instead of in a +large example block") + +(defvar org-eval-light-regexp nil) + +(defun org-eval-light-set-interpreters (var value) + (set-default var value) + (setq org-eval-light-regexp + (concat "#\\+begin_src \\(" + (mapconcat 'regexp-quote value "\\|") + "\\)\\([^\000]+?\\)#\\+end_src"))) + +(defcustom org-eval-light-interpreters '("lisp" "emacs-lisp" "ruby" "shell") + "Interpreters allows for evaluation tags. +This is a list of program names (as strings) that can evaluate code and +insert the output into an Org-mode buffer. Valid choices are + +lisp Interpret Emacs Lisp code and display the result +shell Pass command to the shell and display the result +perl The perl interpreter +python Thy python interpreter +ruby The ruby interpreter" + :group 'org-eval-light + :set 'org-eval-light-set-interpreters + :type '(set :greedy t + (const "lisp") + (const "emacs-lisp") + (const "perl") + (const "python") + (const "ruby") + (const "shell"))) + +;;; functions +(defun org-eval-light-inside-snippet () + (interactive) + (save-excursion + (let ((case-fold-search t) + (start-re "^#\\+begin_src\\( \\([^ \t\n]+\\)\\)?.*\n") + (end-re "\n#\\+end_src") + (pos (point)) + beg end) + (if (and (setq beg (re-search-backward start-re nil t)) + (setq end (re-search-forward end-re nil t)) + (<= beg pos) (>= end pos)) + t)))) + +(defun org-eval-light-make-region-example (beg end) + "Comment out region using either the '^:' or the BEGIN_EXAMPLE +syntax based on the size of the region as compared to +`org-eval-light-example-size-cutoff'." + (interactive "*r") + (let ((size (abs (- (line-number-at-pos end) + (line-number-at-pos beg))))) + (if (= size 0) + (let ((result (buffer-substring beg end))) + (delete-region beg end) + (insert (concat ": " result))) + (if (<= size org-eval-light-example-size-cutoff) + (save-excursion + (goto-char beg) + (dotimes (n size) + (move-beginning-of-line 1) (insert ": ") (forward-line 1))) + (let ((result (buffer-substring beg end))) + (delete-region beg end) + (insert (concat "#+BEGIN_EXAMPLE\n" result "#+END_EXAMPLE\n"))))))) + +(defun org-eval-light-current-snippet (&optional arg) + "Execute the current #+begin_src #+end_src block, and dump the +results into the buffer immediately following the src block, +commented by `org-eval-light-make-region-example'." + (interactive "P") + (let ((line (org-current-line)) + (case-fold-search t) + (info (org-edit-src-find-region-and-lang)) + beg end lang result) + (setq beg (nth 0 info) + end (nth 1 info) + lang (nth 2 info)) + (unless (member lang org-eval-light-interpreters) + (error "Language is not in `org-eval-light-interpreters': %s" lang)) + (goto-line line) + (setq result (org-eval-light-code lang (buffer-substring beg end))) + (unless arg + (save-excursion + (re-search-forward "^#\\+end_src" nil t) (open-line 1) (forward-char 2) + (let ((beg (point)) + (end (progn (insert result) + (point)))) + (message (format "from %S %S" beg end)) + (org-eval-light-make-region-example beg end)))))) + +(defun org-eval-light-eval-subtree (&optional arg) + "Replace EVAL snippets in the entire subtree." + (interactive "P") + (save-excursion + (org-narrow-to-subtree) + (goto-char (point-min)) + (while (re-search-forward org-eval-light-regexp nil t) + (org-eval-light-current-snippet arg)) + (widen))) + +(defun org-eval-light-code (interpreter code) + (cond + ((member interpreter '("lisp" "emacs-lisp")) + (org-eval-light-lisp (concat "(progn\n" code "\n)"))) + ((equal interpreter "shell") + (shell-command-to-string code)) + ((member interpreter '("perl" "python" "ruby")) + (org-eval-light-run (executable-find interpreter) code)) + (t (error "Cannot evaluate code type %s" interpreter)))) + +(defun org-eval-light-lisp (form) + "Evaluate the given form and return the result as a string." + (require 'pp) + (save-match-data + (condition-case err + (let ((object (eval (read form)))) + (cond + ((stringp object) object) + ((and (listp object) + (not (eq object nil))) + (let ((string (pp-to-string object))) + (substring string 0 (1- (length string))))) + ((numberp object) + (number-to-string object)) + ((eq object nil) "") + (t + (pp-to-string object)))) + (error + (org-display-warning (format "%s: Error evaluating %s: %s" + "???" form err)) + "; INVALID LISP CODE")))) + +(defun org-eval-light-run (cmd code) + (with-temp-buffer + (insert code) + (shell-command-on-region (point-min) (point-max) cmd nil 'replace) + (buffer-string))) + +(defadvice org-ctrl-c-ctrl-c (around org-cc-eval-source activate) + (if (org-eval-light-inside-snippet) + (call-interactively 'org-eval-light-current-snippet) + ad-do-it)) + +(provide 'org-eval-light) + +;;; org-eval-light.el ends here diff --git a/contrib/lisp/org-eval.el b/contrib/lisp/org-eval.el new file mode 100644 index 0000000..ecea46a --- /dev/null +++ b/contrib/lisp/org-eval.el @@ -0,0 +1,216 @@ +;;; org-eval.el --- Display result of evaluating code in various languages +;; Copyright (C) 2008-2017 Free Software Foundation, Inc. +;; +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 0.04 +;; +;; This file is not yet part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; This modules allows to include output from various commands into an +;; Org-mode buffer, both for live display, and for export. +;; This technique has been copied from emacs-wiki and Emacs Muse, and +;; we try to make it work here in a way as similar as possible to +;; Muse, so that people who move between both worlds don't need to learn +;; new syntax. +;; +;; Basically it works like this: +;; +;; <lisp>(concat "aaa" "bbb")</lisp> +;; +;; will display "aaabbb" in the buffer and export like that as well. +;; The leading lisp tag will also accept the attributes "markup" and +;; "lang", to specify how the text should be formatted during export. +;; For example, +;; +;; <lisp markup="src" lang="emacs-lisp"> .... </lisp> +;; +;; will format the result of the lisp form as if it was lisp source +;; code. Internally, it will wrap the text into a +;; +;; #+begin_src emacs-lisp +;; #+end_src +;; +;; structure so that the right things happen when the exporter is running. +;; +;; By default, only the <lisp> tag is turned on, but you can configure +;; the variable `org-eval-interpreters' to add more interpreters like +;; `perl', `python', or the `shell'. +;; +;; You can edit the code snippets with "C-c '" (org-edit-src-code). +;; +;; Please note that this mechanism is potentially dangerous, because it +;; executes code that you don't even see. This gives you great power, +;; but also enough rope to hang yourself. And, it gives your friends +;; who send you Org files plenty of opportunity for good and bad jokes. +;; This is also why this module is not turned on by default, but only +;; available as a contributed package. +;; +;; +;; +(require 'org) + +;;; Customization + +(defgroup org-eval nil + "Options concerning including output from commands into the Org-mode buffer." + :tag "Org Eval" + :group 'org) + +(defface org-eval + (org-compatible-face nil + '((((class color grayscale) (min-colors 88) (background light)) + (:foreground "grey40")) + (((class color grayscale) (min-colors 88) (background dark)) + (:foreground "grey60")) + (((class color) (min-colors 8) (background light)) + (:foreground "green")) + (((class color) (min-colors 8) (background dark)) + (:foreground "yellow")))) + "Face for command output that is included into an Org-mode buffer." + :group 'org-eval + :group 'org-faces) + +(defvar org-eval-regexp nil) + +(defun org-eval-set-interpreters (var value) + (set-default var value) + (setq org-eval-regexp + (concat "<\\(" + (mapconcat 'regexp-quote value "\\|") + "\\)" + "\\([^>]\\{0,50\\}?\\)>" + "\\([^\000]+?\\)</\\1>"))) + +(defcustom org-eval-interpreters '("lisp") + "Interpreters allows for evaluation tags. +This is a list of program names (as strings) that can evaluate code and +insert the output into an Org-mode buffer. Valid choices are + +lisp Interpret Emacs Lisp code and display the result +shell Pass command to the shell and display the result +perl The perl interpreter +python Thy python interpreter +ruby The ruby interpreter" + :group 'org-eval + :set 'org-eval-set-interpreters + :type '(set :greedy t + (const "lisp") + (const "perl") + (const "python") + (const "ruby") + (const "shell"))) + +(defun org-eval-handle-snippets (limit &optional replace) + "Evaluate code snippets and display the results as display property. +When REPLACE is non-nil, replace the code region with the result (used +for export)." + (let (a) + (while (setq a (text-property-any (point) (or limit (point-max)) + 'org-eval t)) + (remove-text-properties + a (next-single-property-change a 'org-eval nil limit) + '(display t intangible t org-eval t)))) + (while (re-search-forward org-eval-regexp limit t) + (let* ((beg (match-beginning 0)) + (end (match-end 0)) + (kind (match-string 1)) + (attr (match-string 2)) + (code (match-string 3)) + (value (org-eval-code kind code)) + markup lang) + (if replace + (progn + (setq attr (save-match-data (org-eval-get-attributes attr)) + markup (cdr (assoc "markup" attr)) + lang (cdr (assoc "lang" attr))) + (replace-match + (concat (if markup (format "#+BEGIN_%s" (upcase markup))) + (if (and markup (equal (downcase markup) "src")) + (concat " " (or lang "fundamental"))) + "\n" + value + (if markup (format "\n#+END_%s\n" (upcase markup)))) + t t)) + (add-text-properties + beg end + (list 'display value 'intangible t 'font-lock-multiline t + 'face 'org-eval + 'org-eval t)))))) + +(defun org-eval-replace-snippts () + "Replace EVAL snippets in the entire buffer. +This should go into the `org-export-preprocess-hook'." + (goto-char (point-min)) + (org-eval-handle-snippets nil 'replace)) + +(add-hook 'org-export-preprocess-hook 'org-eval-replace-snippts) +(add-hook 'org-font-lock-hook 'org-eval-handle-snippets) + +(defun org-eval-get-attributes (str) + (let ((start 0) key value rtn) + (while (string-match "\\<\\([a-zA-Z]+\\)\\>=\"\\([^\"]+\\)\"" str start) + (setq key (match-string 1 str) + value (match-string 2 str) + start (match-end 0)) + (push (cons key value) rtn)) + rtn)) + +(defun org-eval-code (interpreter code) + (cond + ((equal interpreter "lisp") + (org-eval-lisp (concat "(progn\n" code "\n)"))) + ((equal interpreter "shell") + (shell-command-to-string code)) + ((member interpreter '("perl" "python" "ruby")) + (org-eval-run (executable-find interpreter) code)) + (t (error "Cannot evaluate code type %s" interpreter)))) + +(defun org-eval-lisp (form) + "Evaluate the given form and return the result as a string." + (require 'pp) + (save-match-data + (condition-case err + (let ((object (eval (read form)))) + (cond + ((stringp object) object) + ((and (listp object) + (not (eq object nil))) + (let ((string (pp-to-string object))) + (substring string 0 (1- (length string))))) + ((numberp object) + (number-to-string object)) + ((eq object nil) "") + (t + (pp-to-string object)))) + (error + (org-display-warning (format "%s: Error evaluating %s: %s" + "???" form err)) + "; INVALID LISP CODE")))) + +(defun org-eval-run (cmd code) + (with-temp-buffer + (insert code) + (shell-command-on-region (point-min) (point-max) cmd nil 'replace) + (buffer-string))) + +(provide 'org-eval) + +;;; org-eval.el ends here diff --git a/contrib/lisp/org-expiry.el b/contrib/lisp/org-expiry.el new file mode 100644 index 0000000..2b8c050 --- /dev/null +++ b/contrib/lisp/org-expiry.el @@ -0,0 +1,361 @@ +;;; org-expiry.el --- expiry mechanism for Org entries +;; +;; Copyright 2007-2017 Free Software Foundation, Inc. +;; +;; Author: Bastien Guerry +;; Version: 0.2 +;; Keywords: org expiry + +;; 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: +;; +;; This gives you a chance to get rid of old entries in your Org files +;; by expiring them. +;; +;; By default, entries that have no EXPIRY property are considered to be +;; new (i.e. 0 day old) and only entries older than one year go to the +;; expiry process, which consist in adding the ARCHIVE tag. None of +;; your tasks will be deleted with the default settings. +;; +;; When does an entry expires? +;; +;; Consider this entry: +;; +;; * Stop watching TV +;; :PROPERTIES: +;; :CREATED: <2008-01-07 lun 08:01> +;; :EXPIRY: <2008-01-09 08:01> +;; :END: +;; +;; This entry will expire on the 9th, january 2008. + +;; * Stop watching TV +;; :PROPERTIES: +;; :CREATED: <2008-01-07 lun 08:01> +;; :EXPIRY: +1w +;; :END: +;; +;; This entry will expire on the 14th, january 2008, one week after its +;; creation date. +;; +;; What happen when an entry is expired? Nothing until you explicitely +;; M-x org-expiry-process-entries When doing this, org-expiry will check +;; for expired entries and request permission to process them. +;; +;; Processing an expired entries means calling the function associated +;; with `org-expiry-handler-function'; the default is to add the tag +;; :ARCHIVE:, but you can also add a EXPIRED keyword or even archive +;; the subtree. +;; +;; Is this useful? Well, when you're in a brainstorming session, it +;; might be useful to know about the creation date of an entry, and be +;; able to archive those entries that are more than xxx days/weeks old. +;; +;; When you're in such a session, you can insinuate org-expiry like +;; this: M-x org-expiry-insinuate +;; +;; Then, each time you're pressing M-RET to insert an item, the CREATION +;; property will be automatically added. Same when you're scheduling or +;; deadlining items. You can deinsinuate: M-x org-expiry-deinsinuate + +;;; Code: + +;;; User variables: + +(defgroup org-expiry nil + "Org expiry process." + :tag "Org Expiry" + :group 'org) + +(defcustom org-expiry-inactive-timestamps nil + "Insert inactive timestamps for created/expired properties." + :type 'boolean + :group 'org-expiry) + +(defcustom org-expiry-created-property-name "CREATED" + "The name of the property for setting the creation date." + :type 'string + :group 'org-expiry) + +(defcustom org-expiry-expiry-property-name "EXPIRY" + "The name of the property for setting the expiry date/delay." + :type 'string + :group 'org-expiry) + +(defcustom org-expiry-keyword "EXPIRED" + "The default keyword for `org-expiry-add-keyword'." + :type 'string + :group 'org-expiry) + +(defcustom org-expiry-wait "+1y" + "Time span between the creation date and the expiry. +The default value for this variable (\"+1y\") means that entries +will expire if there are at least one year old. + +If the expiry delay cannot be retrieved from the entry or the +subtree above, the expiry process compares the expiry delay with +`org-expiry-wait'. This can be either an ISO date or a relative +time specification. See `org-read-date' for details." + :type 'string + :group 'org-expiry) + +(defcustom org-expiry-created-date "+0d" + "The default creation date. +The default value of this variable (\"+0d\") means that entries +without a creation date will be handled as if they were created +today. + +If the creation date cannot be retrieved from the entry or the +subtree above, the expiry process will compare the expiry delay +with this date. This can be either an ISO date or a relative +time specification. See `org-read-date' for details on relative +time specifications." + :type 'string + :group 'org-expiry) + +(defcustom org-expiry-handler-function 'org-toggle-archive-tag + "Function to process expired entries. +Possible candidates for this function are: + +`org-toggle-archive-tag' +`org-expiry-add-keyword' +`org-expiry-archive-subtree'" + :type 'function + :group 'org-expiry) + +(defcustom org-expiry-confirm-flag t + "Non-nil means confirm expiration process." + :type '(choice + (const :tag "Always require confirmation" t) + (const :tag "Do not require confirmation" nil) + (const :tag "Require confirmation in interactive expiry process" + interactive)) + :group 'org-expiry) + +(defcustom org-expiry-advised-functions + '(org-scheduled org-deadline org-time-stamp) + "A list of advised functions. +`org-expiry-insinuate' will activate the expiry advice for these +functions. `org-expiry-deinsinuate' will deactivate them." + :type 'boolean + :group 'list) + +;;; Advices and insinuation: + +(defadvice org-schedule (after org-schedule-update-created) + "Update the creation-date property when calling `org-schedule'." + (org-expiry-insert-created)) + +(defadvice org-deadline (after org-deadline-update-created) + "Update the creation-date property when calling `org-deadline'." + (org-expiry-insert-created)) + +(defadvice org-time-stamp (after org-time-stamp-update-created) + "Update the creation-date property when calling `org-time-stamp'." + (org-expiry-insert-created)) + +(defun org-expiry-insinuate (&optional arg) + "Add hooks and activate advices for org-expiry. +If ARG, also add a hook to `before-save-hook' in `org-mode' and +restart `org-mode' if necessary." + (interactive "P") + (ad-activate 'org-schedule) + (ad-activate 'org-time-stamp) + (ad-activate 'org-deadline) + (add-hook 'org-insert-heading-hook 'org-expiry-insert-created) + (add-hook 'org-after-todo-state-change-hook 'org-expiry-insert-created) + (add-hook 'org-after-tags-change-hook 'org-expiry-insert-created) + (when arg + (add-hook 'org-mode-hook + (lambda() (add-hook 'before-save-hook + 'org-expiry-process-entries t t))) + ;; need this to refresh org-mode hooks + (when (eq major-mode 'org-mode) + (org-mode) + (if (called-interactively-p 'any) + (message "Org-expiry insinuated, `org-mode' restarted."))))) + +(defun org-expiry-deinsinuate (&optional arg) + "Remove hooks and deactivate advices for org-expiry. +If ARG, also remove org-expiry hook in Org's `before-save-hook' +and restart `org-mode' if necessary." + (interactive "P") + (ad-deactivate 'org-schedule) + (ad-deactivate 'org-time-stamp) + (ad-deactivate 'org-deadline) + (remove-hook 'org-insert-heading-hook 'org-expiry-insert-created) + (remove-hook 'org-after-todo-state-change-hook 'org-expiry-insert-created) + (remove-hook 'org-after-tags-change-hook 'org-expiry-insert-created) + (remove-hook 'org-mode-hook + (lambda() (add-hook 'before-save-hook + 'org-expiry-process-entries t t))) + (when arg + ;; need this to refresh org-mode hooks + (when (eq major-mode 'org-mode) + (org-mode) + (if (called-interactively-p 'any) + (message "Org-expiry de-insinuated, `org-mode' restarted."))))) + +;;; org-expiry-expired-p: + +(defun org-expiry-expired-p () + "Check if the entry at point is expired. +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-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) + 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)) + (org-read-date nil t ex-field)))) + (if (time-less-p ex ct) + (time-subtract ct ex)))) + +;;; Expire an entry or a region/buffer: + +(defun org-expiry-process-entry (&optional force) + "Call `org-expiry-handler-function' on entry. +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 (called-interactively-p) (org-reveal)) + (when (org-expiry-expired-p) + (org-back-to-heading) + (looking-at org-complex-heading-regexp) + (let* ((ov (make-overlay (point) (match-end 0))) + (e (org-expiry-expired-p)) + (d (time-to-number-of-days e))) + (overlay-put ov 'face 'secondary-selection) + (if (or force + (null org-expiry-confirm-flag) + (and (eq org-expiry-confirm-flag 'interactive) + (not (interactive))) + (and org-expiry-confirm-flag + (y-or-n-p (format "Entry expired by %d days. Process? " d)))) + (funcall org-expiry-handler-function)) + (delete-overlay ov))))) + +(defun org-expiry-process-entries (beg end) + "Process all expired entries between BEG and END. +The expiry process will run the function defined by +`org-expiry-handler-functions'." + (interactive "r") + (save-excursion + (let ((beg (if (org-region-active-p) + (region-beginning) (point-min))) + (end (if (org-region-active-p) + (region-end) (point-max)))) + (goto-char beg) + (let ((expired 0) (processed 0)) + (while (and (outline-next-heading) (< (point) end)) + (when (org-expiry-expired-p) + (setq expired (1+ expired)) + (if (if (called-interactively-p 'any) + (call-interactively 'org-expiry-process-entry) + (org-expiry-process-entry)) + (setq processed (1+ processed))))) + (if (equal expired 0) + (message "No expired entry") + (message "Processed %d on %d expired entries" + processed expired)))))) + +;;; Insert created/expiry property: + +(defun org-expiry-insert-created (&optional arg) + "Insert or update a property with the creation date. +If ARG, always update it. With one `C-u' prefix, silently update +to today's date. With two `C-u' prefixes, prompt the user for to +update the date." + (interactive "P") + (let* ((d (org-entry-get (point) org-expiry-created-property-name)) + d-time d-hour timestr) + (when (or (null d) arg) + ;; update if no date or non-nil prefix argument + ;; FIXME Use `org-time-string-to-time' + (setq d-time (if d (org-time-string-to-time d) + (current-time))) + (setq d-hour (format-time-string "%H:%M" d-time)) + (setq timestr + ;; two C-u prefixes will call org-read-date + (if (equal arg '(16)) + (concat "<" (org-read-date + nil nil nil nil d-time d-hour) ">") + (format-time-string (cdr org-time-stamp-formats)))) + ;; maybe transform to inactive timestamp + (if org-expiry-inactive-timestamps + (setq timestr (concat "[" (substring timestr 1 -1) "]"))) + (save-excursion + (org-entry-put + (point) org-expiry-created-property-name timestr))))) + +(defun org-expiry-insert-expiry (&optional today) + "Insert a property with the expiry date. +With one `C-u' prefix, don't prompt interactively for the date +and insert today's date." + (interactive "P") + (let* ((d (org-entry-get (point) org-expiry-expiry-property-name)) + d-time d-hour) + (setq d-time (if d (org-time-string-to-time d) + (current-time))) + (setq d-hour (format-time-string "%H:%M" d-time)) + (setq timestr (if today + (format-time-string (cdr org-time-stamp-formats)) + (concat "<" (org-read-date + nil nil nil nil d-time d-hour) ">"))) + ;; maybe transform to inactive timestamp + (if org-expiry-inactive-timestamps + (setq timestr (concat "[" (substring timestr 1 -1) "]"))) + + (save-excursion + (org-entry-put + (point) org-expiry-expiry-property-name timestr)))) + +;;; Functions to process expired entries: + +(defun org-expiry-archive-subtree () + "Archive the entry at point if it is expired." + (interactive) + (save-excursion + (if (org-expiry-expired-p) + (org-archive-subtree) + (if (called-interactively-p 'any) + (message "Entry at point is not expired."))))) + +(defun org-expiry-add-keyword (&optional keyword) + "Add KEYWORD to the entry at point if it is expired." + (interactive "sKeyword: ") + (if (or (member keyword org-todo-keywords-1) + (setq keyword org-expiry-keyword)) + (save-excursion + (if (org-expiry-expired-p) + (org-todo keyword) + (if (called-interactively-p 'any) + (message "Entry at point is not expired.")))) + (error "\"%s\" is not a to-do keyword in this buffer" keyword))) + +;; FIXME what about using org-refile ? + +(provide 'org-expiry) + +;;; org-expiry.el ends here diff --git a/contrib/lisp/org-git-link.el b/contrib/lisp/org-git-link.el new file mode 100644 index 0000000..0028daf --- /dev/null +++ b/contrib/lisp/org-git-link.el @@ -0,0 +1,229 @@ +;;; org-git-link.el --- Provide org links to specific file version + +;; Copyright (C) 2009-2014 Reimar Finken + +;; Author: Reimar Finken <reimar.finken@gmx.de> +;; Keywords: files, calendar, hypermedia + +;; 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/>. + +;;; Commentary: + +;; `org-git-link.el' defines two new link types. The `git' link +;; type is meant to be used in the typical scenario and mimics the +;; `file' link syntax as closely as possible. The `gitbare' link +;; type exists mostly for debugging reasons, but also allows e.g. +;; linking to files in a bare git repository for the experts. + +;; * User friendy form +;; [[git:/path/to/file::searchstring]] + +;; This form is the familiar from normal org file links +;; including search options. However, its use is +;; restricted to files in a working directory and does not +;; handle bare repositories on purpose (see the bare form for +;; that). + +;; The search string references a commit (a tree-ish in Git +;; terminology). The two most useful types of search strings are + +;; - A symbolic ref name, usually a branch or tag name (e.g. +;; master or nobelprize). +;; - A ref followed by the suffix @ with a date specification +;; enclosed in a brace pair (e.g. {yesterday}, {1 month 2 +;; weeks 3 days 1 hour 1 second ago} or {1979-02-26 18:30:00}) +;; to specify the value of the ref at a prior point in time +;; +;; * Bare git form +;; [[gitbare:$GIT_DIR::$OBJECT]] +;; +;; This is the more bare metal version, which gives the user most +;; control. It directly translates to the git command +;; git --no-pager --git-dir=$GIT_DIR show $OBJECT +;; Using this version one can also view files from a bare git +;; repository. For detailed information on how to specify an +;; object, see the man page of `git-rev-parse' (section +;; SPECIFYING REVISIONS). A specific blob (file) can be +;; specified by a suffix clolon (:) followed by a path. + +;;; Code: + +(require 'org) +(defcustom org-git-program "git" + "Name of the git executable used to follow git links." + :type '(string) + :group 'org) + +;; org link functions +;; bare git link +(org-link-set-parameters "gitbare" :follow #'org-gitbare-open) + +(defun org-gitbare-open (str) + (let* ((strlist (org-git-split-string str)) + (gitdir (nth 0 strlist)) + (object (nth 1 strlist))) + (org-git-open-file-internal gitdir object))) + + +(defun org-git-open-file-internal (gitdir object) + (let* ((sha (org-git-blob-sha gitdir object)) + (tmpdir (concat temporary-file-directory "org-git-" sha)) + (filename (org-git-link-filename object)) + (tmpfile (expand-file-name filename tmpdir))) + (unless (file-readable-p tmpfile) + (make-directory tmpdir) + (with-temp-file tmpfile + (org-git-show gitdir object (current-buffer)))) + (org-open-file tmpfile) + (set-buffer (get-file-buffer tmpfile)) + (setq buffer-read-only t))) + +;; user friendly link +(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 (nth 0 strlist)) + (commit (nth 1 strlist)) + (line (nth 2 strlist)) + (dirlist (org-git-find-gitdir (file-truename filepath))) + (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) + +(defun org-git-split-dirpath (dirpath) + "Given a directory name, return '(dirname basname)" + (let ((dirname (file-name-directory (directory-file-name dirpath))) + (basename (file-name-nondirectory (directory-file-name dirpath)))) + (list dirname basename))) + +;; finding the git directory +(defun org-git-find-gitdir (path) + "Given a file (not necessarily existing) file path, return the + a pair (gitdir relpath), where gitdir is the path to the first + .git subdirectory found updstream and relpath is the rest of + 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 (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= (nth 1 dirlist) "") ; at top level + (throw 'toplevel nil)) + (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 + (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 three parts separated by a double colon (::). +(defun org-git-split-string (str) + "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) "" "")) + ((= 2 (length strlist)) + (append strlist (list ""))) + ((= 3 (length strlist)) + strlist) + (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) + "Given an object description (see the man page of + git-rev-parse), return the nondirectory part of the referenced + filename, if it can be extracted. Otherwise, return a valid + filename." + (let* ((match (and (string-match "[^:]+$" str) + (match-string 0 str))) + (filename (and match (file-name-nondirectory match)))) ;extract the final part without slash + filename)) + +;; creating a link +(defun org-git-create-searchstring (branch timestring) + (concat branch "@{" timestring "}")) + + +(defun org-git-create-git-link (file &optional line) + "Create git link part to file at specific time" + (interactive "FFile: ") + (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) + (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))) + (line (line-number-at-pos))) + (when (org-git-gitrepos-p file) + (org-store-link-props + :type "git" + :link (org-git-create-git-link file line)))))) + +(defun org-git-insert-link-interactively (file searchstring &optional description) + (interactive "FFile: \nsSearch string: \nsDescription: ") + (insert (org-make-link-string (concat "git:" file "::" searchstring) description))) + +;; Calling git +(defun org-git-show (gitdir object buffer) + "Show the output of git --git-dir=gitdir show object in buffer." + (unless + (zerop (call-process org-git-program nil buffer nil + "--no-pager" (concat "--git-dir=" gitdir) "show" object)) + (error "git error: %s " (with-current-buffer buffer (buffer-string))))) + +(defun org-git-blob-sha (gitdir object) + "Return sha of the referenced object" + (with-temp-buffer + (if (zerop (call-process org-git-program nil t nil + "--no-pager" (concat "--git-dir=" gitdir) "rev-parse" object)) + (buffer-substring (point-min) (1- (point-max))) ; to strip off final newline + (error "git error: %s " (buffer-string))))) + +(defun org-git-get-current-branch (gitdir) + "Return the name of the current branch." + (with-temp-buffer + (if (not (zerop (call-process org-git-program nil t nil + "--no-pager" (concat "--git-dir=" gitdir) "symbolic-ref" "-q" "HEAD"))) + (error "git error: %s " (buffer-string)) + (goto-char (point-min)) + (if (looking-at "^refs/heads/") ; 11 characters + (buffer-substring 12 (1- (point-max))))))) ; to strip off final newline + +(provide 'org-git-link) + +;;; org-git-link.el ends here diff --git a/contrib/lisp/org-index.el b/contrib/lisp/org-index.el new file mode 100644 index 0000000..9efa510 --- /dev/null +++ b/contrib/lisp/org-index.el @@ -0,0 +1,3006 @@ +;;; org-index.el --- A personal adaptive index for org + +;; Copyright (C) 2011-2017 Free Software Foundation, Inc. + +;; Author: Marc Ihm <org-index@2484.de> +;; Version: 5.1.3 +;; Keywords: outlines index + +;; This file is not part of GNU Emacs. + +;;; License: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Purpose: +;; +;; Fast search for selected org nodes and things outside of org. +;; +;; org-index creates and updates an index table with keywords; each line +;; either points to a heading in org, references something outside or +;; carries a snippet of text to yank. When searching the index, the set +;; of matching lines is updated with every keystroke; results are sorted +;; by usage count and date, so that frequently used entries appear first +;; in the list of results. +;; +;; References are decorated numbers (e.g. 'R237' or '--455--'); they are +;; well suited to be used outside of org, e.g. in folder names, ticket +;; systems or on printed documents. +;; +;; On first invocation org-index will assist you in creating the index +;; table. +;; +;; To start using your index, invoke subcommands 'add', 'ref' and 'yank' +;; to create entries and 'occur' to find them. +;; +;; +;; Setup: +;; +;; - Place this file in a directory from your load-path, +;; e.g. org-mode/contrib/lisp. +;; +;; - Add these lines to your .emacs: +;; +;; (require 'org-index) +;; (global-set-key (kbd "C-c i") 'org-index-dispatch) ; this is optional +;; +;; - Restart your Emacs to make these lines effective. +;; +;; - Invoke `org-index'; on first run it will assist in creating your +;; index table. +;; +;; - Optionally invoke `M-x org-customize' to tune some settings (choose +;; group org-index). +;; +;; +;; Further information: +;; +;; - Watch the screencast at http://2484.de/org-index.html. +;; +;; - See the documentation of `org-index', which can also be read by +;; invoking `org-index' and choosing the command help or '?'. +;; +;; +;; Updates: +;; +;; The latest published version of this file can always be found at: +;; +;; http://orgmode.org/w/?p=org-mode.git;a=blob_plain;f=contrib/lisp/org-index.el;hb=HEAD +;; +;; Development version under: +;; +;; https://github.com/marcIhm/org-index + +;;; Change Log: + +;; [2016-08-26 Fr] Version 5.1.3 +;; - Offering help during query for subcommands +;; - Removed org-index-default-keybindings +;; - Renamed subcommand multi-occur to find-ref +;; - Subcommands add and need no longer be invoked from heading +;; - Many Bugfixes +;; +;; [2015-12-29 Tu] Version 5.0.2 +;; - New commands yank, column and edit +;; - New column tags +;; - All columns are now required +;; - References are now optional +;; - Subcommand enter has been renamed to index +;; - Subcommands kill and edit can be invoked from an occur buffer +;; - Many Bugfixes +;; - Added link to screencast +;; +;; [2015-08-20 Th] Version 4.3.0 +;; - Configuration is done now via standard customize +;; - New sorting strategy 'mixed' +;; - Silenced some compiler warnings +;; +;; [2015-03-18 We] Version 4.2.1 +;; - No garbage in kill-ring +;; - No recentering after add +;; +;; [2015-03-08 Su] Version 4.2.0 +;; - Reference numbers for subcommands can be passed as a prefix argument +;; - New variable org-index-default-keybindings-list with a list of +;; default keybindings for org-index-default-keybindings +;; - Added new column level +;; - removed flags get-category-on-add and get-heading-on-add +;; +;; [2015-02-26 Th] to [2015-03-05 Th] Version 4.0.0 to 4.1.2 +;; - Removed command "leave"; rather go back with org-mark-ring-goto +;; - Renamed column "link" to "id" +;; - Added maintainance options to find duplicate rows, to check ids, +;; update index or remove property org-index-ref from nodes +;; - Shortened versin history +;; +;; [2014-12-08 Mo] to [2015-01-31 Sa] Version 3.0.0 to 3.2.0: +;; - Complete sorting of index only occurs in idle-timer +;; - New command "maintain" with some subcommands +;; - Rewrote command "occur" with overlays in an indirect buffer +;; - Command "add" updates index, if node is already present +;; - New commands "add" and "delete" to easily add and remove +;; the current node to or from your index. +;; - New command "example" to create an example index. +;; - Several new flags that are explained within index node. +;; - Removed commands "reuse", "missing", "put", "goto", +;; "update", "link", "fill", "unhighlight" +;; - New function `org-index-default-keybindings' +;; +;; [2012-12-07 Fr] to [2014-04-26 Sa] Version 2.0.0 to 2.4.3: +;; - New functions org-index-new-line and org-index-get-line +;; offer access to org-index from other lisp programs +;; - Regression tests with ert +;; - Renamed from "org-favtable" to "org-index" +;; - Added an assistant to set up the index table +;; - occur is now incremental, searching as you type +;; - Integrated with org-mark-ring-goto +;; - Added full support for ids +;; - Renamed the package from "org-reftable" to "org-favtable" +;; - Additional columns are required (e.g. "link"). Error messages will +;; guide you +;; - Ask user explicitly, which command to invoke +;; - Renamed the package from "org-refer-by-number" to "org-reftable" +;; +;; [2011-12-10 Sa] to [2012-09-22 Sa] Version Version 1.2.0 to 1.5.0: +;; - New command "sort" to sort a buffer or region by reference number +;; - New commands "highlight" and "unhighlight" to mark references +;; - New command "head" to find a headline with a reference number +;; - New commands occur and multi-occur +;; - Started this Change Log + +;;; Code: + +(require 'org-table) +(require 'cl-lib) +(require 'widget) + +;; Version of this package +(defvar org-index-version "5.1.3" "Version of `org-index', format is major.minor.bugfix, where \"major\" are incompatible changes and \"minor\" are new features.") + +;; customizable options +(defgroup org-index nil + "Options concerning the optional index for org." + :tag "Org Index" + :group 'org) + +(defcustom org-index-id nil + "Id of the Org-mode node, which contains the index table." + :group 'org-index) + +(defcustom org-index-sort-by 'mixed + "Strategy for sorting index table (and whence entries in occur). +Valid values are: + +last-access Sort index by date and time of last access; show + more recent entries first. +count Sort by usage count; more often used entries first. +mixed First, show all index entries, which have been + used today; sort them by last access. Then show + older entries sorted by usage count." + :group 'org-index + :set (lambda (s v) + (set-default s v) + (if (and org-index-id + org-index--buffer + (functionp 'org-index--sort-silent)) + (org-index--sort-silent))) + :initialize 'custom-initialize-default + :type '(choice + (const last-accessed) + (const count) + (const mixed))) + +(defcustom org-index-yank-after-add 'ref + "Specifies which column should be yanked after adding a new index row. +Valid values are some columns of index table." + :group 'org-index + :type '(choice + (const ref) + (const category) + (const keywords))) + +(defcustom org-index-point-on-add 'keywords + "Specifies in which column point will land when adding a new index row. +Valid values are some columns of index table." + :group 'org-index + :type '(choice + (const category) + (const keywords))) + +(defcustom org-index-copy-heading-to-keywords t + "When adding a new node to index: Copy heading to keywords-column ?" + :group 'org-index + :type '(choice (const :tag "Yes" t) + (const :tag "No" nil))) + +(defcustom org-index-strip-ref-and-date-from-heading t + "When adding a node to index: strip leading ref or timestamps ? + +This can be useful, if you have the habit of adding refs and +dates to the start of your headings; then, if you change your +heading and want to update your index, you do not need to remove +those pieces." + :group 'org-index + :type '(choice (const :tag "Yes" t) + (const :tag "No" nil))) + +(defcustom org-index-edit-on-add '(category keywords) + "List of columns to edit when adding a new row." + :group 'org-index + :type '(repeat (choice + (const category) + (const keywords)))) + +(defcustom org-index-edit-on-yank '(yank keywords) + "List of columns to edit when adding new text to yank." + :group 'org-index + :type '(repeat (choice + (const yank) + (const category) + (const keywords)))) + +(defcustom org-index-edit-on-ref '(category keywords) + "List of columns to edit when adding new ref." + :group 'org-index + :type '(repeat (choice + (const category) + (const keywords)))) + +;; Variables to hold the configuration of the index table +(defvar org-index--maxrefnum nil "Maximum number from reference table, e.g. 153.") +(defvar org-index--nextref nil "Next reference, that can be used, e.g. 'R154'.") +(defvar org-index--head nil "Header before number (e.g. 'R').") +(defvar org-index--tail nil "Tail after number (e.g. '}' or ')'.") +(defvar org-index--numcols nil "Number of columns in index table.") +(defvar org-index--ref-regex nil "Regular expression to match a reference.") +(defvar org-index--ref-format nil "Format, that can print a reference.") +(defvar org-index--columns nil "Columns of index-table.") +(defvar org-index--buffer nil "Buffer of index table.") +(defvar org-index--point nil "Position at start of headline of index table.") +(defvar org-index--below-hline nil "Position of first cell in first line below hline.") +(defvar org-index--saved-positions nil "Saved positions within current buffer and index buffer; filled by ‘org-index--save-positions’.") +(defvar org-index--headings nil "Headlines of index-table as a string.") +(defvar org-index--headings-visible nil "Visible part of headlines of index-table as a string.") + +;; Variables to hold context and state +(defvar org-index--last-fingerprint nil "Fingerprint of last line created.") +(defvar org-index--category-before nil "Category of node before.") +(defvar org-index--active-region nil "Active region, initially. I.e. what has been marked.") +(defvar org-index--below-cursor nil "Word below cursor.") +(defvar org-index--within-index-node nil "True, if we are within node of the index table.") +(defvar org-index--within-occur nil "True, if we are within the occur-buffer.") +(defvar org-index--message-text nil "Text that was issued as an explanation; helpful for regression tests.") +(defvar org-index--occur-help-text nil "Text for help in occur buffer.") +(defvar org-index--occur-help-overlay nil "Overlay for help in occur buffer.") +(defvar org-index--occur-stack nil "Stack with overlays for hiding lines.") +(defvar org-index--occur-tail-overlay nil "Overlay to cover invisible lines.") +(defvar org-index--occur-lines-collected 0 "Number of lines collected in occur buffer; helpful for tests.") +(defvar org-index--last-sort nil "Last column, the index has been sorted after.") +(defvar org-index--sort-timer nil "Timer to sort index in correct order.") +(defvar org-index--aligned nil "Remember for this Emacs session, if table has been aligned at least once.") +(defvar org-index--edit-widgets nil "List of widgets used to edit.") +(defvar org-index--context-index nil "Position and line used for index in edit buffer.") +(defvar org-index--context-occur nil "Position and line used for occur in edit buffer.") +(defvar org-index--context-node nil "Buffer and position for node in edit buffer.") +(defvar org-index--short-help-buffer-name "*org-index commands*" "Name of buffer to display short help.") +(defvar org-index--display-short-help nil "True, if short help should be displayed.") +(defvar org-index--short-help-displayed nil "True, if short help message has been displayed.") +(defvar org-index--minibuffer-saved-key nil "Temporarily save entry of minibuffer keymap.") + +;; static information for this program package +(defconst org-index--commands '(occur add kill head ping index ref yank column edit help short-help example sort find-ref highlight maintain) "List of commands available.") +(defconst org-index--valid-headings '(ref id created last-accessed count keywords category level yank tags) "All valid headings.") +(defconst org-index--occur-buffer-name "*org-index-occur*" "Name of occur buffer.") +(defconst org-index--edit-buffer-name "*org-index-edit*" "Name of edit buffer.") +(defconst org-index--sort-idle-delay 300 "Delay in seconds after which buffer will sorted.") +(defvar org-index--short-help-text nil "Cache for result of `org-index--get-short-help-text.") +(defvar org-index--shortcut-chars nil "Cache for result of `org-index--get-shortcut-chars.") + + +(defmacro org-index--on (column value &rest body) + "Execute the forms in BODY with point on index line whose COLUMN is VALUE. +The value returned is the value of the last form in BODY or nil, +if VALUE cannot be found." + (declare (indent 2) (debug t)) + (let ((pointvar (make-symbol "point")) ; avoid clash with same-named variables in body + (foundvar (make-symbol "found")) + (retvar (make-symbol "ret"))) + `(save-current-buffer + (let ((,pointvar (point)) + ,foundvar + ,retvar) + + (set-buffer org-index--buffer) + + (setq ,foundvar (org-index--go ,column ,value)) + (when ,foundvar + (setq ,retvar (progn ,@body))) + + (goto-char ,pointvar) + + ,retvar)))) + + +(defun org-index (&optional command search-ref arg) + "Fast search-index for selected org nodes and things outside of org. + +org-index creates and updates an index table with keywords; each line +either points to a heading in org, references something outside or +carries a snippet of text to yank. The index table is searched for +keywords through an incremental occur; results are sorted by usage +count and date, so that frequently used entries appear first among +the results. + +References are decorated numbers (e.g. 'R237' or '--455--'); they are +well suited to be used outside of org, e.g. in folder names, ticket +systems or on printed documents. + +On first invocation org-index will help to create a dedicated node +for its index table. + +To start building up your index, use subcommands 'add', 'ref' and +'yank' to create entries and use 'occur' to find them. + +This is version 5.1.3 of org-index.el. + + +The function `org-index' is the only interactive function of this +package and its main entry point; it will present you with a list +of subcommands to choose from: + +\(Note the one-letter shortcuts, e.g. [o]; used like 'C-c i o'.) + + occur: [o] Incrementally show matching lines from index. + Result is updated after every keystroke. You may enter a + list of words seperated by space or comma (`,'), to select + lines that contain all of the given words. + + add: [a] Add the current node to index. + So that (e.g.) it can be found through the subcommand + 'occur'. Update index, if node is already present. + + kill: [k] Kill (delete) the current node from index. + Can be invoked from index, from occur or from a headline. + + head: [h] Search for heading, by ref or from index line. + If invoked from within index table, go to associated + node (if any), otherwise ask for ref to search. + + index: [i] Enter index table and maybe go to a specific reference. + Use `org-mark-ring-goto' (\\[org-mark-ring-goto]) to go back. + + ping: [p] Echo line from index table for current node. + If current node is not in index, than search among its + parents. + + ref: [r] Create a new index line with a reference. + This line will not be associated with a node. + + yank: [y] Store a new string, that can be yanked from occur. + The index line will not be associated with a node. + + column: [c] From within index table: read char and jump to column. + Shortcut for column movement; stays within one index line. + + edit: [e] Present current line in edit buffer. + Can be invoked from index, from occur or from a headline. + + help: Show complete help text of org-index. + + short-help: [?] Show one-line description of each subcommand. + I.e. show this list but only first sentence each. + + example: Create an example index, that will not be saved. + May serve as an example. + + sort: Sort lines in index, in region or buffer. + Region or buffer can be sorted by contained reference; Index + by count, reference or last access. + + find-ref: Search for given reference in all org-buffers. + A wrapper to employ emacs standard `multi-occur' function; + asks for reference. + + highlight: Highlight or unhighlight all references. + Operates on active region or whole buffer. Call with prefix + argument (`C-u') to remove highlights. + + maintain: Index maintainance. + Offers some choices to check, update or fix your index. + +If you invoke `org-index' for the first time, an assistant will be +invoked, that helps you to create your own index. + +Invoke `org-customize' to tweak the behaviour of org-index. + +Optionally bind `org-index-dispatch' to a key, e.g. 'C-c i' in +the global keymap to invoke the most important subcommands with +a single key. + +A numeric prefix argument is used as a reference number for +commands, that need one (e.g. 'head'). + +Use from elisp: Optional argument COMMAND is a symbol naming the +command to execute. SEARCH-REF specifies a reference to search +for, if needed. ARG allows passing in a prefix argument as in +interactive calls." + + (interactive "i\ni\nP") + + (let (search-id ; id to search for + search-fingerprint ; fingerprint to search for + sort-what ; sort what ? + kill-new-text ; text that will be appended to kill ring + message-text) ; text that will be issued as an explanation + + (catch 'new-index + + ;; + ;; Initialize and parse + ;; + + ;; creates index table, if necessary + (org-index--verify-id) + + ;; Get configuration of index table + (org-index--parse-table) + + ;; store context information + (org-index--retrieve-context) + + + ;; + ;; Arrange for proper sorting of index + ;; + + ;; lets assume, that it has been sorted this way (we try hard to make sure) + (unless org-index--last-sort (setq org-index--last-sort org-index-sort-by)) + ;; rearrange for index beeing sorted into default sort order after 300 secs of idle time + (unless org-index--sort-timer + (setq org-index--sort-timer + (run-with-idle-timer org-index--sort-idle-delay t 'org-index--sort-silent))) + + + ;; + ;; Find out, what we are supposed to do + ;; + + ;; Check or read command + (if (and command (not (eq command 'short-help))) + (unless (memq command org-index--commands) + (error "Unknown command '%s' passed as argument, valid choices are any of these symbols: %s" + command (mapconcat 'symbol-name org-index--commands ","))) + + ;; read command; if requested display help in read-loop + (setq org-index--display-short-help (eq command 'short-help)) + (setq command (org-index--read-command)) + (setq org-index--display-short-help nil)) + + ;; + ;; Get search string, if required; process possible sources one after + ;; another (lisp argument, prefix argument, user input). + ;; + + ;; Try prefix, if no lisp argument given + (if (and (not search-ref) + (numberp arg)) + (setq search-ref (format "%s%d%s" org-index--head arg org-index--tail))) + + ;; These actions really need a search string and may even prompt for it + (when (memq command '(index head find-ref)) + + ;; search from surrounding text ? + (unless search-ref + (if org-index--within-index-node + + (if (org-at-table-p) + (setq search-ref (org-index--get-or-set-field 'ref))) + + (if (and org-index--below-cursor + (string-match (concat "\\(" org-index--ref-regex "\\)") + org-index--below-cursor)) + (setq search-ref (match-string 1 org-index--below-cursor))))) + + ;; If we still do not have a search string, ask user explicitly + (unless search-ref + (if (eq command 'index) + (let ((r (org-index--read-search-for-index))) + (setq search-ref (first r)) + (setq search-id (second r)) + (setq search-fingerprint (third r))) + (unless (and (eq command 'head) + org-index--within-index-node + (org-at-table-p)) + (setq search-ref (read-from-minibuffer "Search reference number: "))))) + + ;; Clean up search string + (when search-ref + (setq search-ref (org-trim search-ref)) + (if (string-match "^[0-9]+$" search-ref) + (setq search-ref (concat org-index--head search-ref org-index--tail))) + (if (string= search-ref "") (setq search-ref nil))) + + (if (and (not search-ref) + (not (eq command 'index)) + (not (and (eq command 'head) + org-index--within-index-node + (org-at-table-p)))) + (error "Command %s needs a reference number" command))) + + + ;; + ;; Command sort needs to know in advance, what to sort for + ;; + + (when (eq command 'sort) + (setq sort-what (intern (org-completing-read "You may sort:\n - index : your index table by various columns\n - region : the active region by contained reference\n - buffer : the whole current buffer\nPlease choose what to sort: " (list "index" "region" "buffer") nil t)))) + + + ;; + ;; Enter table + ;; + + ;; Arrange for beeing able to return + (when (and (memq command '(occur head index example sort maintain)) + (not (string= (buffer-name) org-index--occur-buffer-name))) + (org-mark-ring-push)) + + ;; These commands will leave user in index table after they are finished + (when (or (memq command '(index maintain)) + (and (eq command 'sort) + (eq sort-what 'index))) + + (pop-to-buffer-same-window org-index--buffer) + (goto-char org-index--point) + (org-index--unfold-buffer)) + + + ;; + ;; Actually do, what is requested + ;; + + (cond + + ((eq command 'help) + + ;; bring up help-buffer for this function + (describe-function 'org-index)) + + + ((eq command 'short-help) + + (org-index--display-short-help)) + + + ((eq command 'find-ref) + + ;; Construct list of all org-buffers + (let (org-buffers) + (dolist (buff (buffer-list)) + (set-buffer buff) + (if (string= major-mode "org-mode") + (setq org-buffers (cons buff org-buffers)))) + + ;; Do multi-occur + (multi-occur org-buffers (org-index--make-guarded-search search-ref)) + + ;; Present results + (if (get-buffer "*Occur*") + (progn + (setq message-text (format "Found '%s'" search-ref)) + (other-window 1) + (toggle-truncate-lines 1)) + (setq message-text (format "Did not find '%s'" search-ref))))) + + + ((eq command 'add) + + (let ((r (org-index--do-add-or-update (if (equal arg '(4)) t nil) + (if (numberp arg) arg nil)))) + (setq message-text (car r)) + (setq kill-new-text (cdr r)))) + + + ((eq command 'kill) + (setq message-text (org-index--do-kill))) + + + ((eq command 'head) + + (if (and org-index--within-index-node + (org-at-table-p)) + (setq search-id (org-index--get-or-set-field 'id))) + + (if (and (not search-id) search-ref) + (setq search-id (org-index--id-from-ref search-ref))) + + (setq message-text + (if search-id + (org-index--find-id search-id) + "Current line has no id"))) + + + ((eq command 'index) + + (goto-char org-index--below-hline) + + (setq message-text + + (if search-ref + (if (org-index--go 'ref search-ref) + (progn + (org-index--update-current-line) + (org-table-goto-column (org-index--column-num 'ref)) + (format "Found index line '%s'" search-ref)) + (format "Did not find index line with reference '%s'" search-ref)) + + (if search-id + (if (org-index--go 'id search-id) + (progn + (org-index--update-current-line) + (org-table-goto-column (org-index--column-num 'ref)) + (format "Found index line '%s'" (org-index--get-or-set-field 'ref))) + (format "Did not find index line with id '%s'" search-id)) + + (if search-fingerprint + (if (org-index--go 'fingerprint org-index--last-fingerprint) + (progn + (org-index--update-current-line) + (beginning-of-line) + (format "Found latest index line")) + (format "Did not find index line")) + + ;; simply go into table + "At index table")))) + + (recenter)) + + + ((eq command 'ping) + + (let ((moved-up 0) id info reached-top) + + (unless (string= major-mode "org-mode") (error "No node at point")) + ;; take id from current node or reference + (setq id (if search-ref + (org-index--id-from-ref search-ref) + (org-id-get))) + + ;; move up until we find a node in index + (save-excursion + (outline-back-to-heading) + (while (not (or info + reached-top)) + (if id + (setq info (org-index--on 'id id + (mapcar (lambda (x) (org-index--get-or-set-field x)) + (list 'ref 'count 'created 'last-accessed 'category 'keywords 'ref))))) + + (setq reached-top (= (org-outline-level) 1)) + + (unless (or info + reached-top) + (outline-up-heading 1 t) + (cl-incf moved-up)) + + (setq id (org-id-get)))) + + (if info + (progn + (setq message-text + (apply 'format + (append (list "'%s'%shas been accessed %s times between %s and %s; category is '%s', keywords are '%s'" + (pop info) + (if (> moved-up 0) (format " (parent node, %d level up) " moved-up) " ")) + info))) + (setq kill-new-text (car (last info)))) + (setq message-text "Neither this node nor any of its parents is part of index")))) + + + ((eq command 'occur) + + (set-buffer org-index--buffer) + (org-index--do-occur)) + + + ((eq command 'ref) + + (let (args) + + (setq args (org-index--collect-values-from-user org-index-edit-on-ref)) + (setq args (plist-put args 'category "yank")) + (setq args (plist-put args 'ref org-index--nextref)) + (apply 'org-index--do-new-line args) + + (setq kill-new-text org-index--nextref) + + (setq message-text (format "Added new row with ref '%s'" org-index--nextref)))) + + + ((eq command 'yank) + + (let (args) + + (setq args (org-index--collect-values-from-user org-index-edit-on-yank)) + (if (plist-get args 'yank) + (plist-put args 'yank (replace-regexp-in-string "|" "\\vert" (plist-get args 'yank) nil 'literal))) + (setq args (plist-put args 'category "yank")) + (apply 'org-index--do-new-line args) + + (setq message-text "Added new row with text to yank"))) + + + ((eq command 'column) + + (if (and org-index--within-index-node + (org-at-table-p)) + (let (char col num) + (setq char (read-char "Please specify, which column to go to (r=ref, k=keywords, c=category, y=yank): ")) + (unless (memq char (list ?r ?k ?c ?y)) + (error (format "Invalid char '%c', cannot goto this column" char))) + (setq col (cdr (assoc char '((?r . ref) (?k . keywords) (?c . category) (?y . yank))))) + (setq num (org-index--column-num col)) + (if num + (progn + (org-table-goto-column num) + (setq message-text (format "At column %s" (symbol-name col)))) + + (error (format "Column '%s' is not present" col)))) + (error "Need to be in index table to go to a specific column"))) + + + ((eq command 'edit) + + (setq message-text (org-index--do-edit))) + + + ((eq command 'sort) + + (let ((sorts (list "count" "last-accessed" "mixed" "id" "ref")) + sort groups-and-counts) + + (cond + ((eq sort-what 'index) + (setq sort + (intern + (completing-read + "Please choose column to sort index table: " + (cl-copy-list sorts) + nil t nil nil (symbol-name org-index-sort-by)))) + + (org-index--do-sort-index sort) + (org-table-goto-column (org-index--column-num (if (eq sort 'mixed) 'last-access sort))) + ;; When saving index, it should again be sorted correctly + (with-current-buffer org-index--buffer + (add-hook 'before-save-hook 'org-index--sort-silent t)) + + (setq message-text + (format + (concat "Your index has been sorted temporarily by %s and will be sorted again by %s after %d seconds of idle time" + (if groups-and-counts + "; %d groups with equal %s and a total of %d lines have been found" + "")) + (symbol-name sort) + org-index-sort-by + org-index--sort-idle-delay + (second groups-and-counts) + (symbol-name sort) + (third groups-and-counts)))) + + ((memq sort-what '(region buffer)) + (org-index--do-sort-lines sort-what) + (setq message-text (format "Sorted %s by contained references" sort-what)))))) + + + ((eq command 'highlight) + + (let ((where "buffer")) + (save-excursion + (save-restriction + (when (and transient-mark-mode + mark-active) + (narrow-to-region (region-beginning) (region-end)) + (setq where "region")) + + (if arg + (progn + (unhighlight-regexp org-index--ref-regex) + (setq message-text (format "Removed highlights for references in %s" where))) + (highlight-regexp org-index--ref-regex 'isearch) + (setq message-text (format "Highlighted references in %s" where))))))) + + + ((eq command 'maintain) + (setq message-text (org-index--do-maintain))) + + + ((eq command 'example) + + (if (y-or-n-p "This assistant will help you to create a temporary index with detailed comments.\nDo you want to proceed ? ") + (org-index--create-index t))) + + + ((not command) (setq message-text "No command given")) + + + (t (error "Unknown subcommand '%s'" command))) + + + ;; tell, what we have done and what can be yanked + (if kill-new-text (setq kill-new-text + (substring-no-properties kill-new-text))) + (if (string= kill-new-text "") (setq kill-new-text nil)) + (let ((m (concat + message-text + (if (and message-text kill-new-text) + " and r" + (if kill-new-text "R" "")) + (if kill-new-text (format "eady to yank '%s'." kill-new-text) (if message-text "." ""))))) + (unless (string= m "") + (message m) + (setq org-index--message-text m))) + (if kill-new-text (kill-new kill-new-text))))) + + +(defun org-index-dispatch (&optional arg) + "Read additional chars and call subcommands of `org-index'. +Can be bound in global keyboard map as central entry point. +Optional argument ARG is passed on." + (interactive "P") + (let (char command) + (if (sit-for 1) + (message "org-index (? for detailed prompt) -")) + (setq char (key-description (read-key-sequence nil))) + (if (string= char "C-g") (keyboard-quit)) + (if (string= char "SPC") (setq char "?")) + (setq command (cdr (assoc char (org-index--get-shortcut-chars)))) + (unless command + (message "No subcommand for '%s'; switching to detailed prompt" char) + (sit-for 1) + (setq command 'short-help)) + (org-index command nil arg))) + + +(defun org-index-new-line (&rest keys-values) + "Create a new line within the index table, returning its reference. + +The function takes a varying number of argument pairs; each pair +is a symbol for an existing column heading followed by its value. +The return value is the new reference. + +Example: + + (message \"Created reference %s\" + (org-index-new-line 'keywords \"foo bar\" 'category \"baz\")) + +Optional argument KEYS-VALUES specifies content of new line." + + (let ((ref (plist-get keys-values 'ref))) + (org-index--verify-id) + (org-index--parse-table) + (if (not (memq ref '(t nil))) + (error "Column 'ref' accepts only 't' or 'nil'")) + (when ref + (setq ref org-index--nextref) + (setq keys-values (plist-put keys-values 'ref ref))) + + (apply 'org-index--do-new-line keys-values) + ref)) + + +(defun org-index--read-command (&optional with-short-help) + "Read subcommand for ‘org-index’ from minibuffer. +Optional argument WITH-SHORT-HELP displays help screen upfront." + (let (minibuffer-scroll-window + minibuffer-setup-fun + command) + (setq org-index--short-help-displayed nil) + (add-hook 'minibuffer-setup-hook 'org-index--minibuffer-setup-function) + (add-hook 'minibuffer-exit-hook 'org-index--minibuffer-exit-function) + (unwind-protect + (setq command + (intern + (completing-read + (concat + "Please choose" + (if org-index--display-short-help "" " (? for short help)") + ": ") + (mapcar 'symbol-name org-index--commands) nil t))) + (remove-hook 'minibuffer-setup-hook 'org-index--minibuffer-setup-function) + (remove-hook 'minibuffer-exit-hook 'org-index--minibuffer-exit-function) + (when org-index--short-help-displayed + (quit-windows-on org-index--short-help-buffer-name))) + command)) + + +(defun org-index--minibuffer-setup-function () + "Prepare minibuffer for `org-index--read-command'." + (setq org-index--minibuffer-saved-key (local-key-binding (kbd "?"))) + (local-set-key (kbd "?") 'org-index--display-short-help) + (if org-index--display-short-help (org-index--display-short-help))) + + +(defun org-index--minibuffer-exit-function () + "Restore minibuffer after `org-index--read-command'." + (local-set-key (kbd "?") org-index--minibuffer-saved-key) + (setq org-index--minibuffer-saved-key nil)) + + +(defun org-index--display-short-help () + "Helper function to show help in minibuffer." + (interactive) + + (with-temp-buffer-window + org-index--short-help-buffer-name nil nil + (setq org-index--short-help-displayed t) + (princ "Short help; all subcommands of `org-index', shortcuts in []\n") + (princ (org-index--get-short-help-text))) + (with-current-buffer org-index--short-help-buffer-name + (let ((inhibit-read-only t) + height-before height-after win) + (setq win (get-buffer-window)) + (setq height-before (window-height win)) + (shrink-window-if-larger-than-buffer win) + (setq height-after (window-height win)) + (goto-char (point-min)) + (end-of-line) + (insert + (if (> height-before height-after) + "." + (concat ", " + (substitute-command-keys "\\[scroll-other-window]") + " to scroll:"))) + (goto-char (point-min))))) + + +(defun org-index--get-short-help-text () + "Extract text for short help message from long help." + (or org-index--short-help-text + (with-temp-buffer + (insert (documentation 'org-index)) + (goto-char (point-min)) + (search-forward (concat " " (symbol-name (first org-index--commands)) ": ")) + (forward-line 0) + (kill-region (point-min) (point)) + (search-forward (concat " " (symbol-name (car (last org-index--commands))) ": ")) + (forward-line 1) + (kill-region (point) (point-max)) + (keep-lines "^ [-a-z]+:" (point-min) (point-max)) + (align-regexp (point-min) (point-max) "\\(\\s-*\\):") + (goto-char (point-min)) + (while (re-search-forward "\\. *$" nil t) + (replace-match "" nil nil)) + (goto-char (point-min)) + (re-search-forward "short-help") + (end-of-line) + (insert " (this text)") + (goto-char (point-min)) + (unless (= (line-number-at-pos (point-max)) (1+ (length org-index--commands))) + (error "Internal error, unable to properly extract one-line descriptions of subcommands")) + (setq org-index--short-help-text (buffer-string))))) + + +(defun org-index--get-shortcut-chars () + "Collect shortcut chars from short help message." + (or org-index--shortcut-chars + (with-temp-buffer + (insert (org-index--get-short-help-text)) + (goto-char (point-min)) + (while (< (point) (point-max)) + (when (looking-at "^ \\([-a-z]+\\) +: +\\[\\([a-z?]\\)\\] ") + (setq org-index--shortcut-chars + (cons (cons (match-string 2) (intern (match-string 1))) + org-index--shortcut-chars))) + (forward-line 1)) + (unless (> (length org-index--shortcut-chars) 0) + (error "Internal error, did not find shortcut chars")) + org-index--shortcut-chars))) + + +(defun org-index--do-edit () + "Perform command edit." + (let ((maxlen 0) cols-vals buffer-keymap field-keymap keywords-pos val) + + (setq org-index--context-node nil) + (setq org-index--context-occur nil) + + ;; change to index, if whithin occur + (if org-index--within-occur + (let ((pos (get-text-property (point) 'org-index-lbp))) + (org-index--occur-test-stale pos) + (setq org-index--context-occur (cons (point) (org-index--line-in-canonical-form))) + (set-buffer org-index--buffer) + (goto-char pos)) + + ;; change to index, if still not within + (if (not org-index--within-index-node) + (let ((id (org-id-get))) + (setq org-index--context-node (cons (current-buffer) (point))) + (set-buffer org-index--buffer) + (unless (and id (org-index--go 'id id)) + (setq org-index--context-node nil) + (error "This node is not in index"))))) + + ;; retrieve current content of index line + (dolist (col (mapcar 'car (reverse org-index--columns))) + (if (> (length (symbol-name col)) maxlen) + (setq maxlen (length (symbol-name col)))) + (setq val (org-index--get-or-set-field col)) + (if (and val (eq col 'yank)) (setq val (replace-regexp-in-string (regexp-quote "\\vert") "|" val nil 'literal))) + (setq cols-vals (cons (cons col val) + cols-vals))) + + ;; we need two different keymaps + (setq buffer-keymap (make-sparse-keymap)) + (set-keymap-parent buffer-keymap widget-keymap) + (define-key buffer-keymap (kbd "C-c C-c") 'org-index--edit-c-c-c-c) + (define-key buffer-keymap (kbd "C-c C-k") 'org-index--edit-c-c-c-k) + + (setq field-keymap (make-sparse-keymap)) + (set-keymap-parent field-keymap widget-field-keymap) + (define-key field-keymap (kbd "C-c C-c") 'org-index--edit-c-c-c-c) + (define-key field-keymap (kbd "C-c C-k") 'org-index--edit-c-c-c-k) + + ;; prepare buffer + (setq org-index--context-index (cons (point) (org-index--line-in-canonical-form))) + (if (get-buffer org-index--edit-buffer-name) (kill-buffer org-index--edit-buffer-name)) + (switch-to-buffer (get-buffer-create org-index--edit-buffer-name)) + + ;; create and fill widgets + (setq org-index--edit-widgets nil) + (widget-insert "Edit this line from index; type C-c C-c when done, C-c C-k to abort.\n\n") + (dolist (col-val cols-vals) + (if (eq (car col-val) 'keywords) (setq keywords-pos (point))) + (setq org-index--edit-widgets (cons + (cons (car col-val) + (widget-create 'editable-field + :format (format (format "%%%ds: %%%%v" maxlen) (symbol-name (car col-val))) + :keymap field-keymap + (or (cdr col-val) ""))) + org-index--edit-widgets))) + + (widget-setup) + (goto-char keywords-pos) + (beginning-of-line) + (forward-char (+ maxlen 2)) + (use-local-map buffer-keymap) + "Editing a single line from index")) + + +(defun org-index--edit-c-c-c-c () + "Function to invoked on C-c C-c in Edit buffer." + (interactive) + + (let ((obuf (get-buffer org-index--occur-buffer-name)) + val line) + + ;; Time might have passed + (org-index--refresh-parse-table) + + (with-current-buffer org-index--buffer + + ;; check, if buffer has become stale + (save-excursion + (goto-char (car org-index--context-index)) + (unless (string= (cdr org-index--context-index) + (org-index--line-in-canonical-form)) + (switch-to-buffer org-index--edit-buffer-name) + (error "Index table has changed: Cannot find line, that this buffer is editing"))) + + (pop-to-buffer-same-window org-index--buffer) + (goto-char (car org-index--context-index)) + + ;; write back line to index + (dolist (col-widget org-index--edit-widgets) + (setq val (widget-value (cdr col-widget))) + (if (eq (car col-widget) 'yank) (setq val (replace-regexp-in-string "|" (regexp-quote "\\vert") val))) + (org-index--get-or-set-field (car col-widget) val)) + + (setq line (org-index--align-and-fontify-current-line)) + (beginning-of-line)) + + ;; write line to occur if appropriate + (if org-index--context-occur + (if obuf + (if (string= (cdr org-index--context-index) + (cdr org-index--context-occur)) + (progn + (pop-to-buffer-same-window obuf) + (goto-char (car org-index--context-occur)) + (beginning-of-line) + (let ((inhibit-read-only t)) + (delete-region (line-beginning-position) (line-end-position)) + (insert line) + (put-text-property (line-beginning-position) (line-end-position) + 'org-index-lbp (cdr org-index--context-index)))) + (error "Occur buffer and index buffer do not match any longer")) + (message "Occur buffer has gone, cannot switch back.")) + (setq org-index--context-occur nil)) + + ;; return to node, if invoked from there + (when org-index--context-node + (pop-to-buffer-same-window (car org-index--context-node)) + (goto-char (cdr org-index--context-node))) + + ;; clean up + (kill-buffer org-index--edit-buffer-name) + (setq org-index--context-index nil) + (setq org-index--edit-widgets nil) + (beginning-of-line) + (message "Index line has been edited."))) + + +(defun org-index--edit-c-c-c-k () + "Function invoked on C-c C-k in Edit buffer." + (interactive) + (kill-buffer org-index--edit-buffer-name) + (setq org-index--context-index nil) + (setq org-index--edit-widgets nil) + (beginning-of-line) + (message "Edit aborted.")) + + +(defun org-index--do-new-line (&rest keys-values) + "Do the work for `org-index-new-line'. +Optional argument KEYS-VALUES specifies content of new line." + + (org-index--retrieve-context) + (with-current-buffer org-index--buffer + (goto-char org-index--point) + + ;; check arguments early; they might come from userland + (let ((kvs keys-values) + k v) + (while kvs + (setq k (car kvs)) + (setq v (cadr kvs)) + (if (or (not (symbolp k)) + (and (symbolp v) (not (eq v t)) (not (eq v nil)))) + (error "Arguments must be alternation of key and value")) + (unless (org-index--column-num k) + (error "Unknown column or column not defined in table: '%s'" (symbol-name k))) + (setq kvs (cddr kvs)))) + + (let (yank) + ;; create new line + (org-index--create-new-line) + + ;; fill columns + (let ((kvs keys-values) + k v) + (while kvs + (setq k (car kvs)) + (setq v (cadr kvs)) + (org-table-goto-column (org-index--column-num k)) + (insert (org-trim (or v ""))) + (setq kvs (cddr kvs)))) + + ;; align and fontify line + (org-index--promote-current-line) + (org-index--align-and-fontify-current-line) + + ;; remember fingerprint to be able to return + (setq org-index--last-fingerprint (org-index--get-or-set-field 'fingerprint)) + + ;; get column to yank + (setq yank (org-index--get-or-set-field org-index-yank-after-add)) + + yank))) + + +(defun org-index-get-line (column value) + "Retrieve an existing line within the index table by ref or id. +Return its contents as a property list. + +The function `plist-get' may be used to retrieve specific elements +from the result. + +Example: + + (plist-get (org-index-get-line 'ref \"R12\") 'count) + +retrieves the value of the count-column for reference number 12. + +Argument COLUMN is a symbol, either ref or id, +argument VALUE specifies the value to search for." + ;; check arguments + (unless (memq column '(ref id)) + (error "Argument column can only be 'ref' or 'id'")) + + (unless value + (error "Need a value to search for")) + + (org-index--verify-id) + (org-index--parse-table) + + (org-index--get-line column value)) + + +(defun org-index--get-line (column value) + "Find a line by ID, return its contents. +Argument COLUMN and VALUE specify line to get." + (let (content) + (org-index--on + column value + (mapc (lambda (x) + (if (and (numberp (cdr x)) + (> (cdr x) 0)) + (setq content (cons (car x) (cons (or (org-index--get-or-set-field (car x)) "") content))))) + (reverse org-index--columns))) + content)) + + +(defun org-index--ref-from-id (id) + "Get reference from line ID." + (org-index--on 'id id (org-index--get-or-set-field 'ref))) + + +(defun org-index--id-from-ref (ref) + "Get id from line REF." + (org-index--on 'ref ref (org-index--get-or-set-field 'id))) + + +(defun org-index--get-fingerprint () + "Get fingerprint of current line." + (replace-regexp-in-string + "\\s " "" + (mapconcat (lambda (x) (org-index--get-or-set-field x)) '(id ref yank keywords created) ""))) + + +(defun org-index--read-search-for-index () + "Special input routine for command index." + + ;; Accept single char commands or switch to reading a sequence of digits + (let (char prompt search-ref search-id search-fingerprint) + + ;; start with short prompt but give more help on next iteration + (setq prompt "Please specify, where to go in index (0-9,.,space,backspace,return or ? for short help) - ") + + ;; read one character + (while (not (memq char (append (number-sequence ?0 ?9) (list ?\d ?\b ?\r ?\j ?\s ?.)))) + (setq char (read-char prompt)) + (setq prompt "Go to specific position in index table. Digits specify a reference number, <space> goes to top of index, <backspace> or <delete> to last line created and <return> or `.' to index line of current node. Please choose - ")) + + (if (memq char (number-sequence ?0 ?9)) + ;; read rest of digits + (setq search-ref (read-from-minibuffer "Search reference number: " (char-to-string char)))) + ;; decode single chars + (if (memq char '(?\r ?\n ?.)) (setq search-id (org-id-get))) + (if (memq char '(?\d ?\b)) (setq search-fingerprint org-index--last-fingerprint)) + + (list search-ref search-id search-fingerprint))) + + +(defun org-index--verify-id () + "Check, that we have a valid id." + + ;; Check id + (unless org-index-id + (let ((answer (org-completing-read "Cannot find an index (org-index-id is not set). You may:\n - read-help : to learn more about org-index\n - create-index : invoke an assistant to create an initial index\nPlease choose: " (list "read-help" "create-index") nil t nil nil "read-help"))) + (if (string= answer "create-index") + (org-index--create-missing-index "Variable org-index-id is not set, so probably no index table has been created yet.") + (describe-function 'org-index) + (throw 'new-index nil)))) + + ;; Find node + (let (marker) + (setq marker (org-id-find org-index-id 'marker)) + (unless marker (org-index--create-missing-index "Cannot find the node with id \"%s\" (as specified by variable org-index-id)." org-index-id)) + ; Try again with new node + (setq marker (org-id-find org-index-id 'marker)) + (unless marker (error "Could not create node")) + (setq org-index--buffer (marker-buffer marker) + org-index--point (marker-position marker)) + (move-marker marker nil))) + + +(defun org-index--retrieve-context () + "Collect context information before starting with command." + + ;; Get the content of the active region or the word under cursor + (setq org-index--active-region + (if (and transient-mark-mode mark-active) + (buffer-substring (region-beginning) (region-end)) + nil)) + (setq org-index--below-cursor (thing-at-point 'symbol)) + + ;; get category of current node + (setq org-index--category-before + (save-excursion ; workaround: org-get-category does not give category when at end of buffer + (beginning-of-line) + (org-get-category (point) t))) + + ;; Find out, if we are within index table or occur buffer + (setq org-index--within-index-node (string= (org-id-get) org-index-id)) + (setq org-index--within-occur (string= (buffer-name) org-index--occur-buffer-name))) + + +(defun org-index--parse-table () + "Parse content of index table." + + (let (ref-field + id-field + initial-point + end-of-headings + start-of-headings) + + (with-current-buffer org-index--buffer + + (setq org-index--maxrefnum 0) + (setq initial-point (point)) + + (org-index--go-below-hline) + + ;; align and fontify table once for this emacs session + (unless org-index--aligned + (org-table-align) ; needs to happen before fontification to be effective ? + (let ((is-modified (buffer-modified-p)) + (below (point))) + (while (org-at-table-p) + (forward-line)) + (font-lock-fontify-region below (point)) + (org-index--go-below-hline) + (setq org-index--aligned t) + (set-buffer-modified-p is-modified))) + + (org-index--go-below-hline) + (beginning-of-line) + + ;; get headings to display during occur + (setq end-of-headings (point)) + (while (org-at-table-p) (forward-line -1)) + (forward-line) + (setq start-of-headings (point)) + (setq org-index--headings-visible (substring-no-properties (org-index--copy-visible start-of-headings end-of-headings))) + (setq org-index--headings (buffer-substring start-of-headings end-of-headings)) + + ;; count columns + (org-table-goto-column 100) + (setq org-index--numcols (- (org-table-current-column) 1)) + + ;; go to top of table + (while (org-at-table-p) + (forward-line -1)) + (forward-line) + + ;; parse line of headings + (org-index--parse-headings) + + ;; parse list of flags + (goto-char org-index--point) + + ;; Retrieve any decorations around the number within the first nonempty ref-field + (goto-char org-index--below-hline) + (while (and (org-at-table-p) + (not (setq ref-field (org-index--get-or-set-field 'ref)))) + (forward-line)) + + ;; Some Checking + (unless ref-field + (org-index--report-index-error "Reference column is empty")) + + (unless (string-match "^\\([^0-9]*\\)\\([0-9]+\\)\\([^0-9]*\\)$" ref-field) + (org-index--report-index-error + "First reference in index table ('%s') does not contain a number" ref-field)) + + ;; These are the decorations used within the first ref of index + (setq org-index--head (match-string 1 ref-field)) + (setq org-index--tail (match-string 3 ref-field)) + (setq org-index--ref-regex (concat (regexp-quote org-index--head) + "\\([0-9]+\\)" + (regexp-quote org-index--tail))) + (setq org-index--ref-format (concat org-index--head "%d" org-index--tail)) + + ;; check if the table still seems to be sorted mixed + (goto-char org-index--below-hline) + (when (eq org-index-sort-by 'mixed) + (org-index--go-below-hline) + (if (string< (org-index--get-or-set-field 'last-accessed) + (org-index--get-mixed-time)) + (org-index--do-sort-index org-index-sort-by))) + + ;; Go through table to find maximum number and do some checking + (let ((refnum 0)) + + (while (org-at-table-p) + + (setq ref-field (org-index--get-or-set-field 'ref)) + (setq id-field (org-index--get-or-set-field 'id)) + + (if ref-field + (if (string-match org-index--ref-regex ref-field) + ;; grab number + (setq refnum (string-to-number (match-string 1 ref-field))) + (kill-whole-line) + (message "Removing line from index-table whose ref does not contain a number"))) + + ;; check, if higher ref + (if (> refnum org-index--maxrefnum) (setq org-index--maxrefnum refnum)) + + (forward-line 1))) + + (setq org-index--nextref (format "%s%d%s" org-index--head (1+ org-index--maxrefnum) org-index--tail)) + ;; go back to initial position + (goto-char initial-point)))) + + +(defun org-index--refresh-parse-table () + "Fast refresh of selected results of parsing index table." + + (setq org-index--point (marker-position (org-id-find org-index-id 'marker))) + (with-current-buffer org-index--buffer + (save-excursion + (org-index--go-below-hline)))) + + +(defun org-index--do-maintain () + "Choose among and perform some tasks to maintain index." + (let ((check-what) (max-mini-window-height 1.0) message-text) + (setq check-what (intern (org-completing-read "These checks and fixes are available:\n - statistics : compute statistics about index table\n - check : check ids by visiting their nodes\n - duplicates : check index for duplicate rows (ref or id)\n - clean : remove obsolete property org-index-id\n - update : update content of index lines, with an id \nPlease choose: " (list "statistics" "check" "duplicates" "clean" "update") nil t nil nil "statistics"))) + (message nil) + + (cond + ((eq check-what 'check) + (setq message-text (or (org-index--check-ids) + "No problems found"))) + + ((eq check-what 'statistics) + (setq message-text (org-index--do-statistics))) + + ((eq check-what 'duplicates) + (setq message-text (org-index--find-duplicates))) + + ((eq check-what 'clean) + (let ((lines 0)) + (org-map-entries + (lambda () + (when (org-entry-get (point) "org-index-ref") + (cl-incf lines) + (org-entry-delete (point) "org-index-ref"))) + nil 'agenda) + (setq message-text (format "Removed property 'org-index-ref' from %d lines" lines)))) + + ((eq check-what 'update) + (if (y-or-n-p "Updating your index will overwrite certain columns with content from the associated heading and category. If unsure, you may try this for a single, already existing line of your index by invoking `add'. Are you SURE to proceed for ALL INDEX LINES ? ") + (setq message-text (org-index--update-all-lines)) + (setq message-text "Canceled.")))) + message-text)) + + +(defun org-index--get-mixed-time () + "Get timestamp for sorting order mixed." + (format-time-string + (org-time-stamp-format t t) + (apply 'encode-time (append '(0 0 0) (nthcdr 3 (decode-time)))))) + + +(defun org-index--do-sort-index (sort) + "Sort index table according to SORT." + + (let ((is-modified (buffer-modified-p)) + top + bottom + mixed-time) + + (unless buffer-read-only + + (message "Sorting index table for %s..." (symbol-name sort)) + (undo-boundary) + + (let ((message-log-max nil)) ; we have just issued a message, dont need those of sort-subr + + ;; if needed for mixed sort + (if (eq sort 'mixed) + (setq mixed-time (org-index--get-mixed-time))) + + ;; get boundaries of table + (org-index--go-below-hline) + (forward-line 0) + (setq top (point)) + (while (org-at-table-p) (forward-line)) + + ;; kill all empty rows at bottom + (while (progn + (forward-line -1) + (org-table-goto-column 1) + (and + (not (org-index--get-or-set-field 'ref)) + (not (org-index--get-or-set-field 'id)) + (not (org-index--get-or-set-field 'yank)))) + (org-table-kill-row)) + (forward-line 1) + (setq bottom (point)) + + ;; sort lines + (save-restriction + (narrow-to-region top bottom) + (goto-char top) + (sort-subr t + 'forward-line + 'end-of-line + (lambda () + (org-index--get-sort-key sort t mixed-time)) + nil + 'string<) + (goto-char (point-min)) + + ;; restore modification state + (set-buffer-modified-p is-modified))) + + (setq org-index--last-sort sort)))) + + +(defun org-index--do-sort-lines (what) + "Sort lines in WHAT according to contained reference." + (save-restriction + (cond + ((eq what 'region) + (if (region-active-p) + (narrow-to-region (region-beginning) (region-end)) + (error "No active region, cannot sort"))) + ((eq what 'buffer) + (unless (y-or-n-p "Sort whole current buffer ? ") + (error "Canceled")) + (narrow-to-region (point-min) (point-max)))) + + (goto-char (point-min)) + (sort-subr nil 'forward-line 'end-of-line + (lambda () + (if (looking-at (concat ".*" + (org-index--make-guarded-search org-index--ref-regex 'dont-quote))) + (string-to-number (match-string 1)) + 0))))) + + +(defun org-index--go-below-hline () + "Move below hline in index-table." + + (let ((errstring (format "index table within node %s" org-index-id))) + + (goto-char org-index--point) + + ;; go to heading of node + (while (not (org-at-heading-p)) (forward-line -1)) + (forward-line 1) + + ;; go to first table, but make sure we do not get into another node + (while (and (not (org-at-table-p)) + (not (org-at-heading-p)) + (not (eobp))) + (forward-line)) + + ;; check, if there really is a table + (unless (org-at-table-p) + (org-index--create-missing-index "Cannot find %s." errstring)) + + ;; go just after hline + (while (and (not (org-at-table-hline-p)) + (org-at-table-p)) + (forward-line)) + (forward-line) + + ;; and check + (unless (org-at-table-p) + (org-index--report-index-error "Cannot find a hline within %s" errstring)) + + (org-table-goto-column 1) + (setq org-index--below-hline (point)))) + + +(defun org-index--parse-headings () + "Parse headings of index table." + + (let (field ;; field content + field-symbol) ;; and as a symbol + + (setq org-index--columns nil) + + ;; For each column + (dotimes (col org-index--numcols) + + (setq field (substring-no-properties (downcase (org-trim (org-table-get-field (+ col 1)))))) + + (if (string= field "") + (error "Heading of column cannot be empty")) + (if (and (not (string= (substring field 0 1) ".")) + (not (member (intern field) org-index--valid-headings))) + (error "Column name '%s' is not a valid heading (custom headings may start with a dot, e.g. '.foo')" field)) + + (setq field-symbol (intern field)) + + ;; check if heading has already appeared + (if (assoc field-symbol org-index--columns) + (org-index--report-index-error + "'%s' appears two times as column heading" (downcase field)) + ;; add it to list at front, reverse later + (setq org-index--columns (cons (cons field-symbol (+ col 1)) org-index--columns))))) + + (setq org-index--columns (reverse org-index--columns)) + + ;; check if all necessary headings have appeared + (mapc (lambda (head) + (unless (cdr (assoc head org-index--columns)) + (org-index--report-index-error "No column has heading '%s'" head))) + org-index--valid-headings)) + + +(defun org-index--create-missing-index (&rest reasons) + "Create a new empty index table with detailed explanation. Argument REASONS explains why." + + (org-index--ask-before-create-index "Cannot find index table: " + "new permanent" "." + reasons) + (org-index--create-index)) + + +(defun org-index--report-index-error (&rest reasons) + "Report an error (explained by REASONS) with the existing index and offer to create a valid one to compare with." + + (when org-index--buffer + (pop-to-buffer-same-window org-index--buffer) + (goto-char org-index--below-hline) + (org-reveal t)) + (org-index--ask-before-create-index "The existing index contains this error: " + "temporary" ", to compare with." + reasons) + (org-index--create-index t t)) + + +(defun org-index--ask-before-create-index (explanation type for-what reasons) + ; checkdoc-params: (explanation type for-what reasons) + "Ask the user before creating an index or throw error. Arguments specify bits of issued message." + (let (reason prompt) + + (setq reason (apply 'format reasons)) + + (setq prompt (concat explanation reason "\n" + "However, this assistant can help you to create a " + type " index with detailed comments" for-what "\n\n" + "Do you want to proceed ?")) + + (unless (let ((max-mini-window-height 1.0)) + (y-or-n-p prompt)) + (error (concat explanation reason))))) + + +(defun org-index--create-index (&optional temporary compare) + "Create a new empty index table with detailed explanation. +specify flag TEMPORARY for th new table temporary, maybe COMPARE it with existing index." + (let (buffer + title + firstref + id) + + (if temporary + (let ((file-name (concat temporary-file-directory "org-index--example-index.org")) + (buffer-name "*org-index-example-index*")) + (setq buffer (get-buffer-create buffer-name)) + (with-current-buffer buffer + ;; but it needs a file for its index to be found + (unless (string= (buffer-file-name) file-name) + (set-visited-file-name file-name)) + (rename-buffer buffer-name) ; name is change by line above + + (erase-buffer) + (org-mode))) + + (setq buffer (get-buffer (org-completing-read "Please choose the buffer, where the new node for the index table should be created; the new node will be inserted at its end.\n\nBuffer: " (mapcar 'buffer-name (org-buffer-list)))))) + + (setq title (read-from-minibuffer "Please enter the title of the index node (leave empty for default 'index'): ")) + (if (string= title "") (setq title "index")) + + (while (progn + (setq firstref (read-from-minibuffer "Please enter your first reference-number. This is an integer number preceeded by some and optionally followed by some non-numeric chars; e.g. 'R1', '-1-' or '#1#' (and your initial number does not need to be '1'). The format of your reference-numbers only needs to make sense for yourself, so that you can spot it easily in your texts or write it on a piece of paper; it should however not already appear frequently within your existing notes, to avoid too many false hits when searching.\n\nPlease choose (leave empty for default 'R1'): ")) + (if (string= firstref "") (setq firstref "R1")) + (let (desc) + (when (string-match "[[:blank:]]" firstref) + (setq desc "Contains whitespace")) + (when (string-match "[[:cntrl:]]" firstref) + (setq desc "Contains control characters")) + (unless (string-match "^[^0-9]+[0-9]+[^0-9]*$" firstref) + ;; firstref not okay, report details + (setq desc + (cond ((string= firstref "") "is empty") + ((not (string-match "^[^0-9]+" firstref)) "starts with a digit") + ((not (string-match "^[^0-9]+[0-9]+" firstref)) "does not contain a number") + ((not (string-match "^[^0-9]+[0-9]+[^0-9]*$" firstref)) "contains more than one sequence of digits") + + ))) + (if desc + (progn + (read-from-minibuffer (format "Your input '%s' does not meet the requirements because it %s.\nPlease hit RET and try again: " firstref desc)) + t) + nil)))) + + (with-current-buffer buffer + (goto-char (point-max)) + (insert (format "* %s %s\n" firstref title)) + (if temporary + (insert " + Below you find your temporary index table, which WILL NOT LAST LONGER + THAN YOUR CURRENT EMACS SESSION; please use it only for evaluation. +") + (insert " + Below you find your initial index table, which will grow over time. +")) + (insert " You may start using it by adding some lines. Just + move to another heading within org, invoke `org-index' and + choose the command 'add'. After adding a few nodes, try the + command 'occur' to search among them. + + To gain further insight you may invoke the subcommand 'help', or + (same content) read the help of `org-index'. + + Within the index table below, the sequence of columns does not + matter. You may reorder them in any way you like. You may also + add your own columns, which should start with a dot + (e.g. '.my-column'). + + Invoke `org-customize' to tweak the behaviour of org-index + (see the group org-index). + + This node needs not be a top level node; its name is completely + at your choice; it is found through its ID only. +") + (unless temporary + (insert " + Remark: These lines of explanation can be removed at any time. +")) + + (setq id (org-id-get-create)) + (insert (format " + + | ref | category | keywords | tags | count | level | last-accessed | created | id | yank | + | | | | | | | | | <4> | <4> | + |-----+----------+----------+------+-------+-------+---------------+---------+-----+------| + | %s | | %s | | | | | %s | %s | | + +" + firstref + title + (with-temp-buffer (org-insert-time-stamp nil nil t)) + id)) + + ;; make sure, that node can be found + (org-id-add-location id (buffer-file-name)) + (setq buffer-save-without-query t) + (basic-save-buffer) + + (while (not (org-at-table-p)) (forward-line -1)) + (unless buffer-read-only (org-table-align)) + (while (not (org-at-heading-p)) (forward-line -1)) + + ;; read back some info about new index + (let ((org-index-id id)) + (org-index--verify-id)) + + ;; remember at least for this session + (setq org-index-id id) + + ;; present results to user + (if temporary + (progn + ;; Present existing and temporary index together + (when compare + (pop-to-buffer-same-window org-index--buffer) + (goto-char org-index--point) + (org-index--unfold-buffer) + (delete-other-windows) + (select-window (split-window-vertically))) + ;; show new index + (pop-to-buffer-same-window buffer) + (org-id-goto id) + (org-index--unfold-buffer) + (if compare + (progn + (message "Please compare your existing index (upper window) and a temporary new one (lower window) to fix your index") + (throw 'new-index nil)) + (message "This is your new temporary index, use command add to populate, occur to search."))) + (progn + ;; Only show the new index + (pop-to-buffer-same-window buffer) + (delete-other-windows) + (org-id-goto id) + (org-index--unfold-buffer) + (if (y-or-n-p "This is your new index table. It is already set for this Emacs session, so you may try it out. Do you want to save its id to make it available for future Emacs sessions too ? ") + (progn + (customize-save-variable 'org-index-id id) + (message "Saved org-index-id '%s' to %s." id (or custom-file + user-init-file)) + (throw 'new-index nil)) + (let (sq) + (setq sq (format "(setq org-index-id \"%s\")" id)) + (kill-new sq) + (message "Did not make the id of this new index permanent; you may want to put\n\n %s\n\ninto your own initialization; it is copied already, just yank it." sq) + (throw 'new-index nil)))))))) + + +(defun org-index--unfold-buffer () + "Helper function to unfold buffer." + (org-show-context) + (org-show-subtree) + (recenter 1) + (save-excursion + (org-back-to-heading) + (forward-line) ;; on property drawer + (org-cycle))) + + +(defun org-index--update-line (&optional ref-or-id-or-pos) + "Update columns count and last-accessed in line REF-OR-ID-OR-POS." + + (let (initial) + + (with-current-buffer org-index--buffer + (unless buffer-read-only + + ;; search reference or id, if given (or assume, that we are already positioned right) + (when ref-or-id-or-pos + (setq initial (point)) + (goto-char org-index--below-hline) + (while (and (org-at-table-p) + (not (if (integerp ref-or-id-or-pos) + (and (>= ref-or-id-or-pos (line-beginning-position)) + (< ref-or-id-or-pos (line-end-position))) + (or (string= ref-or-id-or-pos (org-index--get-or-set-field 'ref)) + (string= ref-or-id-or-pos (org-index--get-or-set-field 'id)))))) + (forward-line))) + + (if (not (org-at-table-p)) + (error "Did not find reference or id '%s'" ref-or-id-or-pos) + (org-index--update-current-line)) + + (if initial (goto-char initial)))))) + + +(defun org-index--update-current-line () + "Update current lines columns count and last-accessed." + (let (newcount (count-field (org-index--get-or-set-field 'count))) + + ;; update count field only if number or empty + (when (or (not count-field) + (string-match "^[0-9]+$" count-field)) + (setq newcount (+ 1 (string-to-number (or count-field "0")))) + (org-index--get-or-set-field 'count + (number-to-string newcount))) + + ;; update timestamp + (org-table-goto-column (org-index--column-num 'last-accessed)) + (org-table-blank-field) + (org-insert-time-stamp nil t t) + + ;; move line according to new content + (org-index--promote-current-line) + (org-index--align-and-fontify-current-line))) + + +(defun org-index--align-and-fontify-current-line (&optional num) + "Make current line (or NUM lines) blend well among others." + (let (lines) + ;; get current content + (unless num (setq num 1)) + (setq lines (delete-and-extract-region (line-beginning-position) (line-end-position num))) + ;; create minimum table with fixed-width columns to align and fontify new line + (insert (with-temp-buffer + (org-set-font-lock-defaults) + (insert org-index--headings-visible) + ;; fill columns, so that aligning cannot shrink them + (goto-char (point-min)) + (search-forward "|") + (while (search-forward " " (line-end-position) t) + (replace-match "." nil t)) + (goto-char (point-min)) + (while (search-forward ".|." (line-end-position) t) + (replace-match " | " nil t)) + (goto-char (point-min)) + (while (search-forward "|." (line-end-position) t) + (replace-match "| " nil t)) + (goto-char (point-max)) + (insert lines) + (forward-line 0) + (let ((start (point))) + (while (re-search-forward "^\s +|-" nil t) + (replace-match "| -")) + (goto-char start)) + (org-mode) + (org-table-align) + (font-lock-fontify-region (point-min) (point-max)) + (goto-char (point-max)) + (if (eq -1 (skip-chars-backward "\n")) + (delete-char 1)) + (forward-line (- 1 num)) + (buffer-substring (line-beginning-position) (line-end-position num)))) + lines)) + + +(defun org-index--promote-current-line () + "Move current line up in table according to changed sort fields." + (let (begin end key + (to-skip 0)) + + (forward-line 0) ; stay at beginning of line + + (setq key (org-index--get-sort-key)) + (setq begin (point)) + (setq end (line-beginning-position 2)) + + (forward-line -1) + (while (and (org-at-table-p) + (not (org-at-table-hline-p)) + (string< (org-index--get-sort-key) key)) + + (cl-incf to-skip) + (forward-line -1)) + (forward-line 1) + + ;; insert line at new position + (when (> to-skip 0) + (insert (delete-and-extract-region begin end)) + (forward-line -1)))) + + +(defun org-index--get-sort-key (&optional sort with-ref mixed-time) + "Get value for sorting from column SORT, optional WITH-REF; if mixes use MIXED-TIME." + (let (ref + ref-field + key) + + (unless sort (setq sort org-index--last-sort)) ; use default value + + (when (or with-ref + (eq sort 'ref)) + ;; get reference with leading zeroes, so it can be + ;; sorted as text + (setq ref-field (org-index--get-or-set-field 'ref)) + (if ref-field + (progn + (string-match org-index--ref-regex ref-field) + (setq ref (format + "%06d" + (string-to-number + (match-string 1 ref-field))))) + (setq ref "000000"))) + + (setq key + (cond + ((eq sort 'count) + (format "%08d" (string-to-number (or (org-index--get-or-set-field 'count) "")))) + ((eq sort 'mixed) + (let ((last-accessed (org-index--get-or-set-field 'last-accessed))) + (unless mixed-time (setq mixed-time (org-index--get-mixed-time))) + (concat + (if (string< mixed-time last-accessed) last-accessed mixed-time) + (format "%08d" (string-to-number (or (org-index--get-or-set-field 'count) "")))))) + ((eq sort 'ref) + ref) + ((memq sort '(id last-accessed created)) + (org-index--get-or-set-field sort)) + (t (error "This is a bug: unmatched case '%s'" sort)))) + + (if with-ref (setq key (concat key ref))) + + key)) + + +(defun org-index--get-or-set-field (key &optional value) + "Retrieve field KEY from index table or set it to VALUE." + (let (field) + (save-excursion + (if (eq key 'fingerprint) + (progn + (if value (error "Internal error, pseudo-column fingerprint cannot be set")) + (setq field (org-index--get-fingerprint))) + (setq field (org-trim (org-table-get-field (cdr (assoc key org-index--columns)) value)))) + (if (string= field "") (setq field nil)) + + (org-no-properties field)))) + + +(defun org-index--column-num (key) + "Return number of column KEY." + (if (numberp key) + key + (cdr (assoc key org-index--columns)))) + + +(defun org-index--make-guarded-search (ref &optional dont-quote) + "Make robust search string from REF; DONT-QUOTE it, if requested." + (concat "\\_<" (if dont-quote ref (regexp-quote ref)) "\\_>")) + + +(defun org-index--find-duplicates () + "Find duplicate references or ids in index table." + (let (ref-duplicates id-duplicates) + + (setq ref-duplicates (org-index--find-duplicates-helper 'ref)) + (setq id-duplicates (org-index--find-duplicates-helper 'id)) + (goto-char org-index--below-hline) + (if (or ref-duplicates id-duplicates) + (progn + ;; show results + (pop-to-buffer-same-window + (get-buffer-create "*org-index-duplicates*")) + (when ref-duplicates + (insert "These references appear more than once:\n") + (mapc (lambda (x) (insert " " x "\n")) ref-duplicates) + (insert "\n\n")) + (when id-duplicates + (insert "These ids appear more than once:\n") + (mapc (lambda (x) (insert " " x "\n")) id-duplicates)) + + "Some references or ids are duplicates") + "No duplicate references or ids found"))) + + +(defun org-index--find-duplicates-helper (column) + "Helper for `org-index--find-duplicates': Go through table and count given COLUMN." + (let (counts duplicates field found) + + ;; go through table + (goto-char org-index--below-hline) + (while (org-at-table-p) + + ;; get column + (setq field (org-index--get-or-set-field column)) + + ;; and increment + (setq found (assoc field counts)) + (if found + (cl-incf (cdr found)) + (setq counts (cons (cons field 1) counts))) + + (forward-line)) + + (mapc (lambda (x) (if (and (> (cdr x) 1) + (car x)) + (setq duplicates (cons (car x) duplicates)))) counts) + + duplicates)) + + +(defun org-index--do-statistics () + "Compute statistics about index table." + (let ((total-lines 0) (total-refs 0) + ref ref-field min max message) + + ;; go through table + (goto-char org-index--below-hline) + (while (org-at-table-p) + + ;; get ref + (setq ref-field (org-index--get-or-set-field 'ref)) + + (when ref-field + (string-match org-index--ref-regex ref-field) + (setq ref (string-to-number (match-string 1 ref-field))) + + ;; record min and max + (if (or (not min) (< ref min)) (setq min ref)) + (if (or (not max) (> ref max)) (setq max ref)) + + (setq total-refs (1+ total-refs))) + + ;; count + (setq total-lines (1+ total-lines)) + + (forward-line)) + + (setq message (format "%d Lines in index table. First reference is %s, last %s; %d of them are used (%d percent)" + total-lines + (format org-index--ref-format min) + (format org-index--ref-format max) + total-refs + (truncate (* 100 (/ (float total-refs) (1+ (- max min))))))) + + (goto-char org-index--below-hline) + message)) + + +(defun org-index--do-add-or-update (&optional create-ref tag-with-ref) + "For current node or current line in index, add or update in index table. +CREATE-REF and TAG-WITH-REF if given." + + (let* (id id-from-index ref args yank ret) + + (org-index--save-positions) + (unless (or org-index--within-index-node + org-index--within-occur) + (org-back-to-heading)) + + ;; try to do the same things from within index and from outside + (if org-index--within-index-node + + (progn + (unless (org-at-table-p) + (error "Within index node but not on table")) + + (setq id (org-index--get-or-set-field 'id)) + (setq ref (org-index--get-or-set-field 'ref)) + (setq args (org-index--collect-values-for-add-update-remote id)) + (org-index--write-fields args) + (setq yank (org-index--get-or-set-field org-index-yank-after-add)) + + (setq ret + (if ref + (cons (format "Updated index line %s" ref) yank) + (cons "Updated index line" nil)))) + + (setq id (org-id-get-create)) + (org-index--refresh-parse-table) + (setq id-from-index (org-index--on 'id id id)) + (setq ref (org-index--on 'id id (org-index--get-or-set-field 'ref))) + + (if tag-with-ref + (org-toggle-tag (format "%s%d%s" org-index--head tag-with-ref org-index--tail) 'on)) + (setq args (org-index--collect-values-for-add-update id)) + + (when (and create-ref + (not ref)) + (setq ref org-index--nextref) + (setq args (plist-put args 'ref ref))) + + + (if id-from-index + ;; already have an id in index, find it and update fields + (progn + + (org-index--on + 'id id + (org-index--write-fields args) + (setq yank (org-index--get-or-set-field org-index-yank-after-add))) + + (setq ret + (if ref + (cons (format "Updated index line %s" ref) yank) + (cons "Updated index line" nil)))) + + ;; no id here, create new line in index + (if ref (setq ref (plist-put args 'ref org-index--nextref))) + (setq yank (apply 'org-index--do-new-line args)) + + (setq ret + (if ref + (cons + (format "Added new index line %s" ref) + (concat yank " ")) + (cons + "Added new index line" + nil))))) + + (org-index--restore-positions) + + ret)) + + +(defun org-index--check-ids () + "Check, that ids really point to a node." + + (let ((lines 0) + id ids marker) + + (goto-char org-index--below-hline) + + (catch 'problem + (while (org-at-table-p) + + (when (setq id (org-index--get-or-set-field 'id)) + + ;; check for double ids + (when (member id ids) + (org-table-goto-column (org-index--column-num 'id)) + (throw 'problem "This id appears twice in index; please use command 'maintain' to check for duplicate ids")) + (cl-incf lines) + (setq ids (cons id ids)) + + ;; check, if id is valid + (setq marker (org-id-find id t)) + (unless marker + (org-table-goto-column (org-index--column-num 'id)) + (throw 'problem "This id cannot be found"))) + + (forward-line)) + + (goto-char org-index--below-hline) + nil))) + + +(defun org-index--update-all-lines () + "Update all lines of index at once." + + (let ((lines 0) + id ref kvs) + + ;; check for double ids + (or + (org-index--check-ids) + + (progn + (goto-char org-index--below-hline) + (while (org-at-table-p) + + ;; update single line + (when (setq id (org-index--get-or-set-field 'id)) + (setq ref (org-index--get-or-set-field 'ref)) + (setq kvs (org-index--collect-values-for-add-update-remote id)) + (org-index--write-fields kvs) + (cl-incf lines)) + (forward-line)) + + (goto-char org-index--below-hline) + (org-table-align) + (format "Updated %d lines" lines))))) + + +(defun org-index--collect-values-for-add-update (id &optional silent category) + "Collect values for adding or updating line specified by ID, do not ask if SILENT, use CATEGORY, if given." + + (let ((args (list 'id id)) + content) + + (dolist (col (mapcar 'car org-index--columns)) + + (setq content "") + + (cond + ((eq col 'keywords) + (if org-index-copy-heading-to-keywords + (setq content (nth 4 (org-heading-components)))) + + ;; Shift ref and timestamp ? + (if org-index-strip-ref-and-date-from-heading + (dotimes (i 2) + (if (or (string-match (concat "^\\s-*" org-index--ref-regex) content) + (string-match (concat "^\\s-*" org-ts-regexp-both) content)) + (setq content (substring content (match-end 0))))))) + + ((eq col 'category) + (setq content (or category org-index--category-before))) + + ((eq col 'level) + (setq content (number-to-string (org-outline-level)))) + + ((eq col 'tags) + (setq content (org-get-tags-string)))) + + (unless (string= content "") + (setq args (plist-put args col content)))) + + (if (not silent) + (let ((args-edited (org-index--collect-values-from-user org-index-edit-on-add args))) + (setq args (append args-edited args)))) + + args)) + + +(defun org-index--collect-values-for-add-update-remote (id) + "Wrap `org-index--collect-values-for-add-update' by prior moving to remote node identified by ID." + + (let (marker point args) + + (setq marker (org-id-find id t)) + ;; enter buffer and collect information + (with-current-buffer (marker-buffer marker) + (setq point (point)) + (goto-char marker) + (setq args (org-index--collect-values-for-add-update id t (org-get-category (point) t))) + (goto-char point)) + + args)) + + +(defun org-index--collect-values-from-user (cols &optional defaults) + "Collect values for adding a new yank-line. +Argument COLS gives list of columns to edit. +Optional argument DEFAULTS gives default values." + + (let (content args) + + (dolist (col cols) + + (setq content "") + + (setq content (read-from-minibuffer + (format "Enter text for column '%s': " (symbol-name col)) + (plist-get col defaults))) + + (unless (string= content "") + (setq args (plist-put args col content)))) + args)) + + +(defun org-index--write-fields (kvs) + "Update current line with values from KVS (keys-values)." + (while kvs + (org-index--get-or-set-field (car kvs) (org-trim (cadr kvs))) + (setq kvs (cddr kvs)))) + + +(defun org-index--do-kill () + "Perform command kill from within occur, index or node." + + (let (id ref chars-deleted-index text-deleted-from pos-in-index) + + (org-index--save-positions) + (unless (or org-index--within-index-node + org-index--within-occur) + (org-back-to-heading)) + + ;; Collect information: What should be deleted ? + (if (or org-index--within-occur + org-index--within-index-node) + + (progn + (if org-index--within-index-node + ;; In index + (setq pos-in-index (point)) + ;; In occur + (setq pos-in-index (get-text-property (point) 'org-index-lbp)) + (org-index--occur-test-stale pos-in-index) + (set-buffer org-index--buffer) + (goto-char pos-in-index)) + ;; In Index (maybe moved there) + (setq id (org-index--get-or-set-field 'id)) + (setq ref (org-index--get-or-set-field 'ref))) + + ;; At a headline + (setq id (org-entry-get (point) "ID")) + (setq ref (org-index--ref-from-id id)) + (setq pos-in-index (org-index--on 'id id (point))) + (unless pos-in-index (error "This node is not in index"))) + + ;; Remark: Current buffer is not certain here, but we have all the information to delete + + ;; Delete from node + (when id + (let ((m (org-id-find id 'marker))) + (set-buffer (marker-buffer m)) + (goto-char m) + (move-marker m nil) + (unless (string= (org-id-get) id) + (error "Could not find node with id %s" id))) + + (org-index--delete-any-ref-from-tags) + (if ref (org-index--delete-ref-from-heading ref)) + (setq text-deleted-from (cons "node" text-deleted-from))) + + ;; Delete from index + (set-buffer org-index--buffer) + (unless pos-in-index "Internal error, pos-in-index should be defined here") + (goto-char pos-in-index) + (setq chars-deleted-index (length (delete-and-extract-region (line-beginning-position) (line-beginning-position 2)))) + (setq text-deleted-from (cons "index" text-deleted-from)) + + ;; Delete from occur only if we started there, accept that it will be stale otherwise + (if org-index--within-occur + (let ((inhibit-read-only t)) + (set-buffer org-index--occur-buffer-name) + (delete-region (line-beginning-position) (line-beginning-position 2)) + ;; correct positions + (while (org-at-table-p) + (put-text-property (line-beginning-position) (line-end-position) 'org-index-lbp + (- (get-text-property (point) 'org-index-lbp) chars-deleted-index)) + (forward-line)) + (setq text-deleted-from (cons "occur" text-deleted-from)))) + + (org-index--restore-positions) + (concat "Deleted from: " (mapconcat 'identity (sort text-deleted-from 'string<) ",")))) + + +(defun org-index--save-positions () + "Save current buffer and positions in index- and current buffer; not in occur-buffer." + + (let (cur-buf cur-mrk idx-pnt idx-mrk) + (setq cur-buf (current-buffer)) + (setq cur-mrk (point-marker)) + (set-buffer org-index--buffer) + (if (string= (org-id-get) org-index-id) + (setq idx-pnt (point)) + (setq idx-mrk (point-marker))) + (set-buffer cur-buf) + (setq org-index--saved-positions (list cur-buf cur-mrk idx-pnt idx-mrk)))) + + +(defun org-index--restore-positions () + "Restore positions as saved by `org-index--save-positions'." + + (cl-multiple-value-bind + (cur-buf cur-mrk idx-pnt idx-mrk buf) + org-index--saved-positions + (setq buf (current-buffer)) + (set-buffer cur-buf) + (goto-char cur-mrk) + (set-buffer org-index--buffer) + (goto-char (or idx-pnt idx-mrk)) + (set-buffer buf)) + (setq org-index--saved-positions nil)) + + +(defun org-index--delete-ref-from-heading (ref) + "Delete given REF from current heading." + (save-excursion + (end-of-line) + (let ((end (point))) + (beginning-of-line) + (when (search-forward ref end t) + (delete-char (- (length ref))) + (just-one-space))))) + + +(defun org-index--delete-any-ref-from-tags () + "Delete any reference from list of tags." + (let (new-tags) + (mapc (lambda (tag) + (unless (string-match org-index--ref-regex tag) + (setq new-tags (cons tag new-tags) ))) + (org-get-tags)) + (org-set-tags-to new-tags))) + + +(defun org-index--go (&optional column value) + "Position cursor on index line where COLUMN equals VALUE. +Return t or nil, leave point on line or at top of table, needs to be in buffer initially." + (let (found) + + (unless (eq (current-buffer) org-index--buffer) + (error "This is a bug: Not in index buffer")) + + ;; loop over lines + (goto-char org-index--below-hline) + (if column + (progn + (forward-line -1) + (while (and (not found) + (forward-line) + (org-at-table-p)) + (setq found (string= value (org-index--get-or-set-field column))))) + (setq found t)) + + ;; return value + (if found + t + (goto-char org-index--below-hline) + nil))) + + +(defun org-index--find-id (id &optional other) + "Perform command head: Find node with REF or ID and present it. +If OTHER in separate window." + + (let (message marker) + + (setq marker (org-id-find id t)) + + (if marker + (progn + (org-index--update-line id) + (if other + (progn + (pop-to-buffer (marker-buffer marker))) + (pop-to-buffer-same-window (marker-buffer marker))) + + (goto-char marker) + (org-reveal t) + (org-show-entry) + (recenter) + (unless (string= (org-id-get) id) + (setq message (format "Could not go to node with id %s (narrowed ?)" id))) + (setq message "Found headline")) + (setq message (format "Did not find node with %s" id))) + message)) + + +(defun org-index--do-occur () + "Perform command occur." + (let ((word "") ; last word to search for growing and shrinking on keystrokes + (prompt "Search for: ") + (these-commands " NOTE: If you invoke the org-index subcommands edit or kill from within the occur buffer, the index is updated accordingly.") + (lines-wanted (window-body-height)) + (lines-found 0) ; number of lines found + words ; list words that should match + occur-buffer + begin ; position of first line + narrow ; start of narrowed buffer + help-text ; cons with help text short and long + search-text ; description of text to search for + done ; true, if loop is done + in-c-backspace ; true, while processing C-backspace + help-overlay ; Overlay with help text + last-point ; Last position before end of search + initial-frame ; Frame when starting occur + key ; input from user in various forms + key-sequence + key-sequence-raw) + + + ;; make and show buffer + (if (get-buffer org-index--occur-buffer-name) + (kill-buffer org-index--occur-buffer-name)) + (setq occur-buffer (make-indirect-buffer org-index--buffer org-index--occur-buffer-name)) + (pop-to-buffer-same-window occur-buffer) + (setq initial-frame (selected-frame)) + + ;; avoid modifying direct buffer + (setq buffer-read-only t) + (toggle-truncate-lines 1) + (setq font-lock-keywords-case-fold-search t) + (setq case-fold-search t) + + ;; reset stack and overlays + (setq org-index--occur-stack nil) + (setq org-index--occur-tail-overlay nil) + + ;; narrow to table rows and one line before + (goto-char org-index--below-hline) + (forward-line 0) + (setq begin (point)) + (forward-line -1) + (setq narrow (point)) + (while (org-at-table-p) + (forward-line)) + (narrow-to-region narrow (point)) + (goto-char (point-min)) + (forward-line) + + ;; initialize help text + (setq help-text (cons + (concat + (propertize "Incremental occur" 'face 'org-todo) + (propertize "; ? toggles help and headlines.\n" 'face 'org-agenda-dimmed-todo-face)) + (concat + (propertize + (org-index--wrap + (concat + "Normal keys add to search word; <space> or <comma> start additional word; <backspace> erases last char, <C-backspace> last word; <return> jumps to heading, <tab> jumps to heading in other window, <S-return> jumps to matching line in index; all other keys end search." these-commands "\n")) + 'face 'org-agenda-dimmed-todo-face) + org-index--headings))) + + ;; insert overlays for help text and to cover unsearched lines + (setq help-overlay (make-overlay (point-min) begin)) + (overlay-put help-overlay 'display (car help-text)) + (setq org-index--occur-tail-overlay (make-overlay (point-max) (point-max))) + (overlay-put org-index--occur-tail-overlay 'invisible t) + + (while (not done) + + (if in-c-backspace + (setq key "<backspace>") + (setq search-text (mapconcat 'identity (reverse (cons word words)) ",")) + (message "foo") + + ;; read key, if selected frame has not changed + (if (eq initial-frame (selected-frame)) + (progn + (setq key-sequence + (let ((echo-keystrokes 0) + (full-prompt (format "%s%s%s" + prompt + search-text + (if (string= search-text "") "" " ")))) + (read-key-sequence full-prompt nil nil t t))) + (setq key (key-description key-sequence)) + (setq key-sequence-raw (this-single-command-raw-keys))) + (setq done t) + (setq key-sequence nil) + (setq key nil) + (setq key-sequence-raw nil))) + + + (cond + + + ((string= key "<C-backspace>") + (setq in-c-backspace t)) + + + ((member key (list "<backspace>" "DEL")) ; erase last char + + (if (= (length word) 0) + + ;; nothing more to delete from current word; try next + (progn + (setq word (car words)) + (setq words (cdr words)) + (setq in-c-backspace nil)) + + ;; unhighlight longer match + (unhighlight-regexp (regexp-quote word)) + + ;; some chars are left; shorten word + (setq word (substring word 0 -1)) + (when (= (length word) 0) ; when nothing left, use next word from list + (setq word (car words)) + (setq words (cdr words)) + (setq in-c-backspace nil)) + + ;; free top list of overlays and remove list + (setq lines-found (or (org-index--unhide) lines-wanted)) + (move-overlay org-index--occur-tail-overlay + (if org-index--occur-stack (cdr (assq :end-of-visible (car org-index--occur-stack))) + (point-max)) + (point-max)) + + + ;; highlight shorter word + (unless (= (length word) 0) + (highlight-regexp (regexp-quote word) 'isearch)) + + ;; make sure, point is still visible + (goto-char begin))) + + + ((member key (list "SPC" ",")) ; space or comma: enter an additional search word + + ;; push current word and clear, no need to change display + (unless (string= word "") + (setq words (cons word words)) + (setq word ""))) + + + ((string= key "?") ; question mark: toggle display of headlines and help + (setq help-text (cons (cdr help-text) (car help-text))) + (overlay-put help-overlay 'display (car help-text))) + + ((and (= (length key) 1) + (aref printable-chars (elt key 0))) ; any printable char: add to current search word + + ;; unhighlight short word + (unless (= (length word) 0) + (unhighlight-regexp (regexp-quote word))) + + ;; add to word + (setq word (concat word key)) + + ;; make overlays to hide lines, that do not match longer word any more + (goto-char begin) + (setq lines-found (org-index--hide-with-overlays (cons word words) lines-wanted)) + (move-overlay org-index--occur-tail-overlay + (if org-index--occur-stack (cdr (assq :end-of-visible (car org-index--occur-stack))) + (point-max)) + (point-max)) + + (goto-char begin) + + ;; highlight longer word + (highlight-regexp (regexp-quote word) 'isearch) + + ;; make sure, point is on a visible line + (line-move -1 t) + (line-move 1 t)) + + ;; anything else terminates loop + (t (setq done t)))) + + ;; put back input event, that caused the loop to end + (unless (string= key "C-g") + (setq unread-command-events (listify-key-sequence key-sequence-raw)) + (message key)) + + ;; postprocessing + (setq last-point (point)) + + ;; For performance reasons do not show matching lines for rest of table. So no code here. + + ;; make permanent copy + ;; copy visible lines + (let ((lines-collected 0) + keymap line all-lines all-lines-lbp header-lines lbp) + + (setq cursor-type t) + (goto-char begin) + + ;; collect all visible lines + (while (and (not (eobp)) + (< lines-collected lines-wanted)) + ;; skip over invisible lines + (while (and (invisible-p (point)) + (not (eobp))) + (goto-char (1+ (overlay-end (car (overlays-at (point))))))) + (setq lbp (line-beginning-position)) + (setq line (buffer-substring-no-properties lbp (line-end-position))) + (unless (string= line "") + (cl-incf lines-collected) + (setq all-lines (cons (concat line + "\n") + all-lines)) + (setq all-lines-lbp (cons lbp all-lines-lbp))) + (forward-line 1)) + + (kill-buffer org-index--occur-buffer-name) ; cannot keep this buffer; might become stale soon + + ;; create new buffer + (setq occur-buffer (get-buffer-create org-index--occur-buffer-name)) + (pop-to-buffer-same-window occur-buffer) + (insert org-index--headings) + (setq header-lines (line-number-at-pos)) + + ;; insert into new buffer + (save-excursion + (apply 'insert (reverse all-lines)) + (if (= lines-collected lines-wanted) + (insert "\n(more lines omitted)\n"))) + (setq org-index--occur-lines-collected lines-collected) + + (org-mode) + (setq truncate-lines t) + (if all-lines (org-index--align-and-fontify-current-line (length all-lines))) + (font-lock-ensure) + (font-lock-flush) + (when all-lines-lbp + (while (not (org-at-table-p)) + (forward-line -1)) + (while all-lines-lbp + (put-text-property (line-beginning-position) (line-end-position) 'org-index-lbp (car all-lines-lbp)) + (setq all-lines-lbp (cdr all-lines-lbp)) + (forward-line -1))) + + ;; prepare help text + (goto-char (point-min)) + (forward-line (1- header-lines)) + (setq org-index--occur-help-overlay (make-overlay (point-min) (point))) + (setq org-index--occur-help-text + (cons + (org-index--wrap + (propertize "Search is done; ? toggles help and headlines.\n" 'face 'org-agenda-dimmed-todo-face)) + (concat + (org-index--wrap + (propertize + (format + (concat "Search is done." + (if (< lines-collected lines-wanted) + " Showing all %d matches for " + " Showing one window of matches for ") + "\"" search-text + "\". <return> jumps to heading, <tab> jumps to heading in other window, <S-return> jumps to matching line in index, <space> increments count.\n" these-commands "\n") + (length all-lines)) + 'face 'org-agenda-dimmed-todo-face)) + org-index--headings))) + + (overlay-put org-index--occur-help-overlay 'display (car org-index--occur-help-text)) + + ;; highlight words + (setq case-fold-search t) + (setq font-lock-keywords-case-fold-search t) + (mapc (lambda (w) (unless (or (not w) (string= w "")) (highlight-regexp (regexp-quote w) 'isearch))) + (cons word words)) + + (setq buffer-read-only t) + + ;; install keyboard-shortcuts + (setq keymap (make-sparse-keymap)) + (set-keymap-parent keymap org-mode-map) + + (mapc (lambda (x) (define-key keymap (kbd x) + (lambda () (interactive) + (message "%s" (org-index--occur-action))))) + (list "<return>" "RET")) + + (define-key keymap (kbd "<tab>") + (lambda () (interactive) + (message (org-index--occur-action t)))) + + (define-key keymap (kbd "SPC") + (lambda () (interactive) + (org-index--refresh-parse-table) + ;; increment in index + (let ((ref (org-index--get-or-set-field 'ref)) + count) + (org-index--on + 'ref ref + (setq count (+ 1 (string-to-number (org-index--get-or-set-field 'count)))) + (org-index--get-or-set-field 'count (number-to-string count)) + (org-index--promote-current-line) + (org-index--align-and-fontify-current-line)) + ;; increment in this buffer + (let ((inhibit-read-only t)) + (org-index--get-or-set-field 'count (number-to-string count))) + (message "Incremented count to %d" count)))) + + (define-key keymap (kbd "<S-return>") + (lambda () (interactive) + (let ((pos (get-text-property (point) 'org-index-lbp))) + (org-index--refresh-parse-table) + (org-index--occur-test-stale pos) + (pop-to-buffer org-index--buffer) + (goto-char pos) + (org-reveal t) + (org-index--update-current-line) + (beginning-of-line)))) + + (define-key keymap (kbd "?") + (lambda () (interactive) + (org-index--refresh-parse-table) + (setq-local org-index--occur-help-text (cons (cdr org-index--occur-help-text) (car org-index--occur-help-text))) + (overlay-put org-index--occur-help-overlay 'display (car org-index--occur-help-text)))) + + (use-local-map keymap)))) + + +(defun org-index--occur-test-stale (pos) + "Test, if current line in occur buffer has become stale at POS." + (let (here there) + (org-index--refresh-parse-table) + (setq here (org-index--line-in-canonical-form)) + (with-current-buffer org-index--buffer + (goto-char pos) + (setq there (org-index--line-in-canonical-form))) + (unless (string= here there) + (error "Occur buffer has become stale")))) + + +(defun org-index--line-in-canonical-form () + "Return current line in its canonical form." + (org-trim (substring-no-properties (replace-regexp-in-string "\s +" " " (buffer-substring (line-beginning-position) (line-beginning-position 2)))))) + + +(defun org-index--wrap (text) + "Wrap TEXT at fill column." + (with-temp-buffer + (insert text) + (fill-region (point-min) (point-max) nil t) + (buffer-string))) + + +(defun org-index--occur-action (&optional other) + "Helper for `org-index--occur', find heading with ref or id; if OTHER, in other window; or copy yank column." + (if (org-at-table-p) + (let ((id (org-index--get-or-set-field 'id)) + (ref (org-index--get-or-set-field 'ref)) + (yank (org-index--get-or-set-field 'yank))) + (if id + (org-index--find-id id other) + (if ref + (progn + (org-mark-ring-goto) + (format "Found reference %s (no node is associated)" ref)) + (if yank + (progn + (org-index--update-line (get-text-property (point) 'org-index-lbp)) + (setq yank (replace-regexp-in-string (regexp-quote "\\vert") "|" yank nil 'literal)) + (kill-new yank) + (org-mark-ring-goto) + (format "Copied '%s' (no node is associated)" yank)) + (error "Internal error, this line contains neither id, nor reference, nor text to yank"))))) + (message "Not at table"))) + + +(defun org-index--hide-with-overlays (words lines-wanted) + "Hide text that is currently visible and does not match WORDS by creating overlays; leave LINES-WANTED lines visible." + (let ((lines-found 0) + (end-of-visible (point)) + overlay overlays start matched) + + ;; main loop + (while (and (not (eobp)) + (< lines-found lines-wanted)) + + ;; skip invisible lines + (while (and (not (eobp)) + (and + (invisible-p (point)) + (< (point) (overlay-start org-index--occur-tail-overlay)))) + (goto-char (overlay-end (car (overlays-at (point)))))) + + ;; find stretch of lines, that are currently visible but should be invisible now + (setq matched nil) + (setq start (point)) + (while (and (not (eobp)) + (not + (and + (invisible-p (point)) + (< (point) (overlay-start org-index--occur-tail-overlay)))) + (not (and (org-index--test-words words) + (setq matched t)))) ; for its side effect + (forward-line 1)) + + ;; create overlay to hide this stretch + (when (< start (point)) ; avoid creating an empty overlay + (setq overlay (make-overlay start (point))) + (overlay-put overlay 'invisible t) + (setq overlays (cons overlay overlays))) + + ;; skip and count line, that matched + (when matched + (forward-line 1) + (setq end-of-visible (point)) + (cl-incf lines-found))) + + ;; put new list on top of stack + (setq org-index--occur-stack + (cons (list (cons :overlays overlays) + (cons :end-of-visible end-of-visible) + (cons :lines lines-found)) + org-index--occur-stack)) + + lines-found)) + + +(defun org-index--unhide () + "Unhide text that does has been hidden by `org-index--hide-with-overlays'." + (when org-index--occur-stack + ;; delete overlays and make visible again + (mapc (lambda (y) + (delete-overlay y)) + (cdr (assq :overlays (car org-index--occur-stack)))) + ;; remove from stack + (setq org-index--occur-stack (cdr org-index--occur-stack)) + ;; return number of lines, that are now visible + (if org-index--occur-stack (cdr (assq :lines (car org-index--occur-stack)))))) + + +(defun org-index--test-words (words) + "Test current line for match against WORDS." + (let (line) + (setq line (downcase (buffer-substring (line-beginning-position) (line-beginning-position 2)))) + (catch 'not-found + (dolist (w words) + (or (cl-search w line) + (throw 'not-found nil))) + t))) + + +(defun org-index--create-new-line () + "Do the common work for `org-index-new-line' and `org-index'." + + ;; insert ref or id as last or first line, depending on sort-column + (goto-char org-index--below-hline) + (if (eq org-index-sort-by 'count) + (progn + (while (org-at-table-p) + (forward-line)) + (forward-line -1) + (org-table-insert-row t)) + (org-table-insert-row)) + + ;; insert some of the standard values + (org-table-goto-column (org-index--column-num 'created)) + (org-insert-time-stamp nil nil t) + (org-table-goto-column (org-index--column-num 'count)) + (insert "1")) + + +(defun org-index--sort-silent () + "Sort index for default column to remove any effects of temporary sorting." + (save-excursion + (org-index--verify-id) + (org-index--parse-table) + (org-index--on nil nil + (org-index--do-sort-index org-index-sort-by) + (org-table-align) + (remove-hook 'before-save-hook 'org-index--sort-silent)))) + + +(defun org-index--copy-visible (beg end) + "Copy the visible parts of the region between BEG and END without adding it to `kill-ring'; copy of `org-copy-visible'." + (let (snippets s) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (setq s (goto-char (point-min))) + (while (not (= (point) (point-max))) + (goto-char (org-find-invisible)) + (push (buffer-substring s (point)) snippets) + (setq s (goto-char (org-find-visible)))))) + (apply 'concat (nreverse snippets)))) + + +(provide 'org-index) + +;; Local Variables: +;; fill-column: 75 +;; comment-column: 50 +;; End: + +;;; org-index.el ends here diff --git a/contrib/lisp/org-interactive-query.el b/contrib/lisp/org-interactive-query.el new file mode 100644 index 0000000..147ddae --- /dev/null +++ b/contrib/lisp/org-interactive-query.el @@ -0,0 +1,311 @@ +;;; org-interactive-query.el --- Interactive modification of agenda query +;; +;; Copyright 2007-2017 Free Software Foundation, Inc. +;; +;; Author: Christopher League <league at contrapunctus dot net> +;; Version: 1.0 +;; Keywords: org, wp +;; +;; 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: +;; + +;; This library implements interactive modification of a tags/todo query +;; in the org-agenda. It adds 4 keys to the agenda +;; +;; / add a keyword as a positive selection criterion +;; \ add a keyword as a newgative selection criterion +;; = clear a keyword from the selection string +;; ; + +(require 'org) + +(org-defkey org-agenda-mode-map "=" 'org-agenda-query-clear-cmd) +(org-defkey org-agenda-mode-map "/" 'org-agenda-query-and-cmd) +(org-defkey org-agenda-mode-map ";" 'org-agenda-query-or-cmd) +(org-defkey org-agenda-mode-map "\\" 'org-agenda-query-not-cmd) + +;;; Agenda interactive query manipulation + +(defcustom org-agenda-query-selection-single-key t + "Non-nil means query manipulation exits after first change. +When nil, you have to press RET to exit it. +During query selection, you can toggle this flag with `C-c'. +This variable can also have the value `expert'. In this case, the window +displaying the tags menu is not even shown, until you press C-c again." + :group 'org-agenda + :type '(choice + (const :tag "No" nil) + (const :tag "Yes" t) + (const :tag "Expert" expert))) + +(defun org-agenda-query-selection (current op table &optional todo-table) + "Fast query manipulation with single keys. +CURRENT is the current query string, OP is the initial +operator (one of \"+|-=\"), TABLE is an alist of tags and +corresponding keys, possibly with grouping information. +TODO-TABLE is a similar table with TODO keywords, should these +have keys assigned to them. If the keys are nil, a-z are +automatically assigned. Returns the new query string, or nil to +not change the current one." + (let* ((fulltable (append table todo-table)) + (maxlen (apply 'max (mapcar + (lambda (x) + (if (stringp (car x)) (string-width (car x)) 0)) + fulltable))) + (fwidth (+ maxlen 3 1 3)) + (ncol (/ (- (window-width) 4) fwidth)) + (expert (eq org-agenda-query-selection-single-key 'expert)) + (exit-after-next org-agenda-query-selection-single-key) + (done-keywords org-done-keywords) + tbl char cnt e groups ingroup + tg c2 c c1 ntable rtn) + (save-window-excursion + (if expert + (set-buffer (get-buffer-create " *Org tags*")) + (delete-other-windows) + (split-window-vertically) + (org-switch-to-buffer-other-window (get-buffer-create " *Org tags*"))) + (erase-buffer) + (setq-local org-done-keywords done-keywords) + (insert "Query: " current "\n") + (org-agenda-query-op-line op) + (insert "\n\n") + (org-fast-tag-show-exit exit-after-next) + (setq tbl fulltable char ?a cnt 0) + (while (setq e (pop tbl)) + (cond + ((equal e '(:startgroup)) + (push '() groups) (setq ingroup t) + (when (not (= cnt 0)) + (setq cnt 0) + (insert "\n")) + (insert "{ ")) + ((equal e '(:endgroup)) + (setq ingroup nil cnt 0) + (insert "}\n")) + (t + (setq tg (car e) c2 nil) + (if (cdr e) + (setq c (cdr e)) + ;; automatically assign a character. + (setq c1 (string-to-char + (downcase (substring + tg (if (= (string-to-char tg) ?@) 1 0))))) + (if (or (rassoc c1 ntable) (rassoc c1 table)) + (while (or (rassoc char ntable) (rassoc char table)) + (setq char (1+ char))) + (setq c2 c1)) + (setq c (or c2 char))) + (if ingroup (push tg (car groups))) + (setq tg (org-add-props tg nil 'face + (cond + ((not (assoc tg table)) + (org-get-todo-face tg)) + (t nil)))) + (if (and (= cnt 0) (not ingroup)) (insert " ")) + (insert "[" c "] " tg (make-string + (- fwidth 4 (length tg)) ?\ )) + (push (cons tg c) ntable) + (when (= (setq cnt (1+ cnt)) ncol) + (insert "\n") + (if ingroup (insert " ")) + (setq cnt 0))))) + (setq ntable (nreverse ntable)) + (insert "\n") + (goto-char (point-min)) + (if (and (not expert) (fboundp 'fit-window-to-buffer)) + (fit-window-to-buffer)) + (setq rtn + (catch 'exit + (while t + (message "[a-z..]:Toggle [SPC]:clear [RET]:accept [TAB]:free%s%s" + (if groups " [!] no groups" " [!]groups") + (if expert " [C-c]:window" (if exit-after-next " [C-c]:single" " [C-c]:multi"))) + (setq c (let ((inhibit-quit t)) (read-char-exclusive))) + (cond + ((= c ?\r) (throw 'exit t)) + ((= c ?!) + (setq groups (not groups)) + (goto-char (point-min)) + (while (re-search-forward "[{}]" nil t) (replace-match " "))) + ((= c ?\C-c) + (if (not expert) + (org-fast-tag-show-exit + (setq exit-after-next (not exit-after-next))) + (setq expert nil) + (delete-other-windows) + (split-window-vertically) + (org-switch-to-buffer-other-window " *Org tags*") + (and (fboundp 'fit-window-to-buffer) + (fit-window-to-buffer)))) + ((or (= c ?\C-g) + (and (= c ?q) (not (rassoc c ntable)))) + (setq quit-flag t)) + ((= c ?\ ) + (setq current "") + (if exit-after-next (setq exit-after-next 'now))) + ((= c ?\[) ; clear left + (org-agenda-query-decompose current) + (setq current (concat "/" (match-string 2 current))) + (if exit-after-next (setq exit-after-next 'now))) + ((= c ?\]) ; clear right + (org-agenda-query-decompose current) + (setq current (match-string 1 current)) + (if exit-after-next (setq exit-after-next 'now))) + ((= c ?\t) + (condition-case nil + (setq current (read-string "Query: " current)) + (quit)) + (if exit-after-next (setq exit-after-next 'now))) + ;; operators + ((or (= c ?/) (= c ?+)) (setq op "+")) + ((or (= c ?\;) (= c ?|)) (setq op "|")) + ((or (= c ?\\) (= c ?-)) (setq op "-")) + ((= c ?=) (setq op "=")) + ;; todos + ((setq e (rassoc c todo-table) tg (car e)) + (setq current (org-agenda-query-manip + current op groups 'todo tg)) + (if exit-after-next (setq exit-after-next 'now))) + ;; tags + ((setq e (rassoc c ntable) tg (car e)) + (setq current (org-agenda-query-manip + current op groups 'tag tg)) + (if exit-after-next (setq exit-after-next 'now)))) + (if (eq exit-after-next 'now) (throw 'exit t)) + (goto-char (point-min)) + (beginning-of-line 1) + (delete-region (point) (point-at-eol)) + (insert "Query: " current) + (beginning-of-line 2) + (delete-region (point) (point-at-eol)) + (org-agenda-query-op-line op) + (goto-char (point-min))))) + (if rtn current nil)))) + +(defun org-agenda-query-op-line (op) + (insert "Operator: " + (org-agenda-query-op-entry (equal op "+") "/+" "and") + (org-agenda-query-op-entry (equal op "|") ";|" "or") + (org-agenda-query-op-entry (equal op "-") "\\-" "not") + (org-agenda-query-op-entry (equal op "=") "=" "clear"))) + +(defun org-agenda-query-op-entry (matchp chars str) + (if matchp + (org-add-props (format "[%s %s] " chars (upcase str)) + nil 'face 'org-todo) + (format "[%s]%s " chars str))) + +(defun org-agenda-query-decompose (current) + (string-match "\\([^/]*\\)/?\\(.*\\)" current)) + +(defun org-agenda-query-clear (current prefix tag) + (if (string-match (concat prefix "\\b" (regexp-quote tag) "\\b") current) + (replace-match "" t t current) + current)) + +(defun org-agenda-query-manip (current op groups kind tag) + "Apply an operator to a query string and a tag. +CURRENT is the current query string, OP is the operator, GROUPS is a +list of lists of tags that are mutually exclusive. KIND is 'tag for a +regular tag, or 'todo for a TODO keyword, and TAG is the tag or +keyword string." + ;; If this tag is already in query string, remove it. + (setq current (org-agenda-query-clear current "[-\\+&|]?" tag)) + (if (equal op "=") current + ;; When using AND, also remove mutually exclusive tags. + (if (equal op "+") + (loop for g in groups do + (if (member tag g) + (mapc (lambda (x) + (setq current + (org-agenda-query-clear current "\\+" x))) + g)))) + ;; Decompose current query into q1 (tags) and q2 (TODOs). + (org-agenda-query-decompose current) + (let* ((q1 (match-string 1 current)) + (q2 (match-string 2 current))) + (cond + ((eq kind 'tag) + (concat q1 op tag "/" q2)) + ;; It's a TODO; when using AND, drop all other TODOs. + ((equal op "+") + (concat q1 "/+" tag)) + (t + (concat q1 "/" q2 op tag)))))) + +(defun org-agenda-query-global-todo-keys (&optional files) + "Return alist of all TODO keywords and their fast keys, in all FILES." + (let (alist) + (unless (and files (car files)) + (setq files (org-agenda-files))) + (save-excursion + (loop for f in files do + (set-buffer (find-file-noselect f)) + (loop for k in org-todo-key-alist do + (setq alist (org-agenda-query-merge-todo-key + alist k))))) + alist)) + +(defun org-agenda-query-merge-todo-key (alist entry) + (let (e) + (cond + ;; if this is not a keyword (:startgroup, etc), ignore it + ((not (stringp (car entry)))) + ;; if keyword already exists, replace char if it's null + ((setq e (assoc (car entry) alist)) + (when (null (cdr e)) (setcdr e (cdr entry)))) + ;; if char already exists, prepend keyword but drop char + ((rassoc (cdr entry) alist) + (message "TRACE POSITION 2") + (setq alist (cons (cons (car entry) nil) alist))) + ;; else, prepend COPY of entry + (t + (setq alist (cons (cons (car entry) (cdr entry)) alist))))) + alist) + +(defun org-agenda-query-generic-cmd (op) + "Activate query manipulation with OP as initial operator." + (let ((q (org-agenda-query-selection org-agenda-query-string op + org-tag-alist + (org-agenda-query-global-todo-keys)))) + (when q + (setq org-agenda-query-string q) + (org-agenda-redo)))) + +(defun org-agenda-query-clear-cmd () + "Activate query manipulation, to clear a tag from the string." + (interactive) + (org-agenda-query-generic-cmd "=")) + +(defun org-agenda-query-and-cmd () + "Activate query manipulation, initially using the AND (+) operator." + (interactive) + (org-agenda-query-generic-cmd "+")) + +(defun org-agenda-query-or-cmd () + "Activate query manipulation, initially using the OR (|) operator." + (interactive) + (org-agenda-query-generic-cmd "|")) + +(defun org-agenda-query-not-cmd () + "Activate query manipulation, initially using the NOT (-) operator." + (interactive) + (org-agenda-query-generic-cmd "-")) + +(provide 'org-interactive-query) diff --git a/contrib/lisp/org-invoice.el b/contrib/lisp/org-invoice.el new file mode 100644 index 0000000..4c83d2e --- /dev/null +++ b/contrib/lisp/org-invoice.el @@ -0,0 +1,401 @@ +;;; org-invoice.el --- Help manage client invoices in OrgMode +;; +;; Copyright (C) 2008-2014 pmade inc. (Peter Jones pjones@pmade.com) +;; +;; This file is not part of GNU Emacs. +;; +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation files (the +;; "Software"), to deal in the Software without restriction, including +;; without limitation the rights to use, copy, modify, merge, publish, +;; distribute, sublicense, and/or sell copies of the Software, and to +;; permit persons to whom the Software is furnished to do so, subject to +;; the following conditions: +;; +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +;; +;;; Commentary: +;; +;; Building on top of the terrific OrgMode, org-invoice tries to +;; provide functionality for managing invoices. Currently, it does +;; this by implementing an OrgMode dynamic block where invoice +;; information is aggregated so that it can be exported. +;; +;; It also provides a library of functions that can be used to collect +;; this invoice information and use it in other ways, such as +;; submitting it to on-line invoicing tools. +;; +;; I'm already working on an elisp package to submit this invoice data +;; to the FreshBooks on-line accounting tool. +;; +;; Usage: +;; +;; In your ~/.emacs: +;; (autoload 'org-invoice-report "org-invoice") +;; (autoload 'org-dblock-write:invoice "org-invoice") +;; +;; See the documentation in the following functions: +;; +;; `org-invoice-report' +;; `org-dblock-write:invoice' +;; +;; Latest version: +;; +;; git clone git://pmade.com/elisp +(eval-when-compile + (require 'cl) + (require 'org)) + +(defgroup org-invoice nil + "OrgMode Invoice Helper" + :tag "Org-Invoice" :group 'org) + +(defcustom org-invoice-long-date-format "%A, %B %d, %Y" + "The format string for long dates." + :type 'string :group 'org-invoice) + +(defcustom org-invoice-strip-ts t + "Remove org timestamps that appear in headings." + :type 'boolean :group 'org-invoice) + +(defcustom org-invoice-default-level 2 + "The heading level at which a new invoice starts. This value +is used if you don't specify a scope option to the invoice block, +and when other invoice helpers are trying to find the heading +that starts an invoice. + +The default is 2, assuming that you structure your invoices so +that they fall under a single heading like below: + +* Invoices +** This is invoice number 1... +** This is invoice number 2... + +If you don't structure your invoices using those conventions, +change this setting to the number that corresponds to the heading +at which an invoice begins." + :type 'integer :group 'org-invoice) + +(defcustom org-invoice-start-hook nil + "Hook called when org-invoice is about to collect data from an +invoice heading. When this hook is called, point will be on the +heading where the invoice begins. + +When called, `org-invoice-current-invoice' will be set to the +alist that represents the info for this invoice." + :type 'hook :group 'org-invoice) + + (defcustom org-invoice-heading-hook nil + "Hook called when org-invoice is collecting data from a +heading. You can use this hook to add additional information to +the alist that represents the heading. + +When this hook is called, point will be on the current heading +being processed, and `org-invoice-current-item' will contain the +alist for the current heading. + +This hook is called repeatedly for each invoice item processed." + :type 'hook :group 'org-invoice) + +(defvar org-invoice-current-invoice nil + "Information about the current invoice.") + +(defvar org-invoice-current-item nil + "Information about the current invoice item.") + +(defvar org-invoice-table-params nil + "The table parameters currently being used.") + +(defvar org-invoice-total-time nil + "The total invoice time for the summary line.") + +(defvar org-invoice-total-price nil + "The total invoice price for the summary line.") + +(defconst org-invoice-version "1.0.0" + "The org-invoice version number.") + +(defun org-invoice-goto-tree (&optional tree) + "Move point to the heading that represents the head of the +current invoice. The heading level will be taken from +`org-invoice-default-level' unless tree is set to a string that +looks like tree2, where the level is 2." + (let ((level org-invoice-default-level)) + (save-match-data + (when (and tree (string-match "^tree\\([0-9]+\\)$" tree)) + (setq level (string-to-number (match-string 1 tree))))) + (org-back-to-heading) + (while (and (> (org-reduced-level (org-outline-level)) level) + (org-up-heading-safe))))) + +(defun org-invoice-heading-info () + "Return invoice information from the current heading." + (let ((title (org-no-properties (org-get-heading t))) + (date (org-entry-get nil "TIMESTAMP" 'selective)) + (work (org-entry-get nil "WORK" nil)) + (rate (or (org-entry-get nil "RATE" t) "0")) + (level (org-outline-level)) + raw-date long-date) + (unless date (setq date (org-entry-get nil "TIMESTAMP_IA" 'selective))) + (unless date (setq date (org-entry-get nil "TIMESTAMP" t))) + (unless date (setq date (org-entry-get nil "TIMESTAMP_IA" t))) + (unless work (setq work (org-entry-get nil "CLOCKSUM" nil))) + (unless work (setq work "00:00")) + (when date + (setq raw-date (apply 'encode-time (org-parse-time-string date))) + (setq long-date (format-time-string org-invoice-long-date-format raw-date))) + (when (and org-invoice-strip-ts (string-match org-ts-regexp-both title)) + (setq title (replace-match "" nil nil title))) + (when (string-match "^[ \t]+" title) + (setq title (replace-match "" nil nil title))) + (when (string-match "[ \t]+$" title) + (setq title (replace-match "" nil nil title))) + (setq work (org-hh:mm-string-to-minutes work)) + (setq rate (string-to-number rate)) + (setq org-invoice-current-item (list (cons 'title title) + (cons 'date date) + (cons 'raw-date raw-date) + (cons 'long-date long-date) + (cons 'work work) + (cons 'rate rate) + (cons 'level level) + (cons 'price (* rate (/ work 60.0))))) + (run-hook-with-args 'org-invoice-heading-hook) + org-invoice-current-item)) + +(defun org-invoice-level-min-max (ls) + "Return a list where the car is the min level, and the cdr the max." + (let ((max 0) min level) + (dolist (info ls) + (when (cdr (assq 'date info)) + (setq level (cdr (assq 'level info))) + (when (or (not min) (< level min)) (setq min level)) + (when (> level max) (setq max level)))) + (cons (or min 0) max))) + +(defun org-invoice-collapse-list (ls) + "Reorganize the given list by dates." + (let ((min-max (org-invoice-level-min-max ls)) new) + (dolist (info ls) + (let* ((date (cdr (assq 'date info))) + (work (cdr (assq 'work info))) + (price (cdr (assq 'price info))) + (long-date (cdr (assq 'long-date info))) + (level (cdr (assq 'level info))) + (bucket (cdr (assoc date new)))) + (if (and (/= (car min-max) (cdr min-max)) + (= (car min-max) level) + (= work 0) (not bucket) date) + (progn + (setq info (assq-delete-all 'work info)) + (push (cons 'total-work 0) info) + (push (cons date (list info)) new) + (setq bucket (cdr (assoc date new)))) + (when (and date (not bucket)) + (setq bucket (list (list (cons 'date date) + (cons 'title long-date) + (cons 'total-work 0) + (cons 'price 0)))) + (push (cons date bucket) new) + (setq bucket (cdr (assoc date new)))) + (when (and date bucket) + (setcdr (assq 'total-work (car bucket)) + (+ work (cdr (assq 'total-work (car bucket))))) + (setcdr (assq 'price (car bucket)) + (+ price (cdr (assq 'price (car bucket))))) + (nconc bucket (list info)))))) + (nreverse new))) + +(defun org-invoice-info-to-table (info) + "Create a single org table row from the given info alist." + (let ((title (cdr (assq 'title info))) + (total (cdr (assq 'total-work info))) + (work (cdr (assq 'work info))) + (price (cdr (assq 'price info))) + (with-price (plist-get org-invoice-table-params :price))) + (unless total + (setq + org-invoice-total-time (+ org-invoice-total-time work) + org-invoice-total-price (+ org-invoice-total-price price))) + (setq total (and total (org-minutes-to-clocksum-string total))) + (setq work (and work (org-minutes-to-clocksum-string work))) + (insert-before-markers + (concat "|" title + (cond + (total (concat "|" total)) + (work (concat "|" work))) + (and with-price price (concat "|" (format "%.2f" price))) + "|" "\n")))) + +(defun org-invoice-list-to-table (ls) + "Convert a list of heading info to an org table" + (let ((with-price (plist-get org-invoice-table-params :price)) + (with-summary (plist-get org-invoice-table-params :summary)) + (with-header (plist-get org-invoice-table-params :headers)) + (org-invoice-total-time 0) + (org-invoice-total-price 0)) + (insert-before-markers + (concat "| Task / Date | Time" (and with-price "| Price") "|\n")) + (dolist (info ls) + (insert-before-markers "|-\n") + (mapc 'org-invoice-info-to-table (if with-header (cdr info) (cdr (cdr info))))) + (when with-summary + (insert-before-markers + (concat "|-\n|Total:|" + (org-minutes-to-clocksum-string org-invoice-total-time) + (and with-price (concat "|" (format "%.2f" org-invoice-total-price))) + "|\n"))))) + +(defun org-invoice-collect-invoice-data () + "Collect all the invoice data from the current OrgMode tree and +return it. Before you call this function, move point to the +heading that begins the invoice data, usually using the +`org-invoice-goto-tree' function." + (let ((org-invoice-current-invoice + (list (cons 'point (point)) (cons 'buffer (current-buffer)))) + (org-invoice-current-item nil)) + (save-restriction + (org-narrow-to-subtree) + (org-clock-sum) + (run-hook-with-args 'org-invoice-start-hook) + (cons org-invoice-current-invoice + (org-invoice-collapse-list + (org-map-entries 'org-invoice-heading-info t 'tree 'archive)))))) + +(defun org-dblock-write:invoice (params) + "Function called by OrgMode to write the invoice dblock. To +create an invoice dblock you can use the `org-invoice-report' +function. + +The following parameters can be given to the invoice block (for +information about dblock parameters, please see the Org manual): + +:scope Allows you to override the `org-invoice-default-level' + variable. The only supported values right now are ones + that look like :tree1, :tree2, etc. + +:prices Set to nil to turn off the price column. + +:headers Set to nil to turn off the group headers. + +:summary Set to nil to turn off the final summary line." + (let ((scope (plist-get params :scope)) + (org-invoice-table-params params) + (zone (point-marker)) + table) + (unless scope (setq scope 'default)) + (unless (plist-member params :price) (plist-put params :price t)) + (unless (plist-member params :summary) (plist-put params :summary t)) + (unless (plist-member params :headers) (plist-put params :headers t)) + (save-excursion + (cond + ((eq scope 'tree) (org-invoice-goto-tree "tree1")) + ((eq scope 'default) (org-invoice-goto-tree)) + ((symbolp scope) (org-invoice-goto-tree (symbol-name scope)))) + (setq table (org-invoice-collect-invoice-data)) + (goto-char zone) + (org-invoice-list-to-table (cdr table)) + (goto-char zone) + (org-table-align) + (move-marker zone nil)))) + +(defun org-invoice-in-report-p () + "Check to see if point is inside an invoice report." + (let ((pos (point)) start) + (save-excursion + (end-of-line 1) + (and (re-search-backward "^#\\+BEGIN:[ \t]+invoice" nil t) + (setq start (match-beginning 0)) + (re-search-forward "^#\\+END:.*" nil t) + (>= (match-end 0) pos) + start)))) + +(defun org-invoice-report (&optional jump) + "Create or update an invoice dblock report. If point is inside +an existing invoice report, the report is updated. If point +isn't inside an invoice report, a new report is created. + +When called with a prefix argument, move to the first invoice +report after point and update it. + +For information about various settings for the invoice report, +see the `org-dblock-write:invoice' function documentation. + +An invoice report is created by reading a heading tree and +collecting information from various properties. It is assumed +that all invoices start at a second level heading, but this can +be configured using the `org-invoice-default-level' variable. + +Here is an example, where all invoices fall under the first-level +heading Invoices: + +* Invoices +** Client Foo (Jan 01 - Jan 15) +*** [2008-01-01 Tue] Built New Server for Production +*** [2008-01-02 Wed] Meeting with Team to Design New System +** Client Bar (Jan 01 - Jan 15) +*** [2008-01-01 Tue] Searched for Widgets on Google +*** [2008-01-02 Wed] Billed You for Taking a Nap + +In this layout, invoices begin at level two, and invoice +items (tasks) are at level three. You'll notice that each level +three heading starts with an inactive timestamp. The timestamp +can actually go anywhere you want, either in the heading, or in +the text under the heading. But you must have a timestamp +somewhere so that the invoice report can group your items by +date. + +Properties are used to collect various bits of information for +the invoice. All properties can be set on the invoice item +headings, or anywhere in the tree. The invoice report will scan +up the tree looking for each of the properties. + +Properties used: + +CLOCKSUM: You can use the Org clock-in and clock-out commands to + create a CLOCKSUM property. Also see WORK. + +WORK: An alternative to the CLOCKSUM property. This property + should contain the amount of work that went into this + invoice item formatted as HH:MM (e.g. 01:30). + +RATE: Used to calculate the total price for an invoice item. + Should be the price per hour that you charge (e.g. 45.00). + It might make more sense to place this property higher in + the hierarchy than on the invoice item headings. + +Using this information, a report is generated that details the +items grouped by days. For each day you will be able to see the +total number of hours worked, the total price, and the items +worked on. + +You can place the invoice report anywhere in the tree you want. +I place mine under a third-level heading like so: + +* Invoices +** An Invoice Header +*** [2008-11-25 Tue] An Invoice Item +*** Invoice Report +#+BEGIN: invoice +#+END:" + (interactive "P") + (let ((report (org-invoice-in-report-p))) + (when (and (not report) jump) + (when (re-search-forward "^#\\+BEGIN:[ \t]+invoice" nil t) + (org-show-entry) + (beginning-of-line) + (setq report (point)))) + (if report (goto-char report) + (org-create-dblock (list :name "invoice"))) + (org-update-dblock))) + +(provide 'org-invoice) diff --git a/contrib/lisp/org-learn.el b/contrib/lisp/org-learn.el new file mode 100644 index 0000000..db9580f --- /dev/null +++ b/contrib/lisp/org-learn.el @@ -0,0 +1,177 @@ +;;; org-learn.el --- Implements SuperMemo's incremental learning algorithm + +;; Copyright (C) 2009-2017 Free Software Foundation, Inc. + +;; Author: John Wiegley <johnw at gnu dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 6.32trans +;; +;; This file is not part of GNU Emacs. +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; The file implements the learning algorithm described at +;; http://supermemo.com/english/ol/sm5.htm, which is a system for reading +;; material according to "spaced repetition". See +;; http://en.wikipedia.org/wiki/Spaced_repetition for more details. +;; +;; To use, turn on state logging and schedule some piece of information you +;; want to read. Then in the agenda buffer type + +(require 'org) +(eval-when-compile + (require 'cl)) + +(defgroup org-learn nil + "Options concerning the learning code in Org-mode." + :tag "Org Learn" + :group 'org-progress) + +(defcustom org-learn-always-reschedule nil + "If non-nil, always reschedule items, even if retention was \"perfect\"." + :type 'boolean + :group 'org-learn) + +(defcustom org-learn-fraction 0.5 + "Controls the rate at which EF is increased or decreased. +Must be a number between 0 and 1 (the greater it is the faster +the changes of the OF matrix)." + :type 'float + :group 'org-learn) + +(defun initial-optimal-factor (n ef) + (if (= 1 n) + 4 + ef)) + +(defun get-optimal-factor (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 n ef)))) + +(defun set-optimal-factor (n ef of-matrix of) + (let ((factors (assoc n of-matrix))) + (if factors + (let ((ef-of (assoc ef (cdr factors)))) + (if ef-of + (setcdr ef-of of) + (push (cons ef of) (cdr factors)))) + (push (cons n (list (cons ef of))) of-matrix))) + of-matrix) + +(defun inter-repetition-interval (n ef &optional of-matrix) + (let ((of (get-optimal-factor n ef of-matrix))) + (if (= 1 n) + of + (* of (inter-repetition-interval (1- n) ef of-matrix))))) + +(defun modify-e-factor (ef quality) + (if (< ef 1.3) + 1.3 + (+ ef (- 0.1 (* (- 5 quality) (+ 0.08 (* (- 5 quality) 0.02))))))) + +(defun modify-of (of q fraction) + (let ((temp (* of (+ 0.72 (* q 0.07))))) + (+ (* (- 1 fraction) of) (* fraction temp)))) + +(defun calculate-new-optimal-factor (interval-used quality used-of + old-of fraction) + "This implements the SM-5 learning algorithm in Lisp. +INTERVAL-USED is the last interval used for the item in question. +QUALITY is the quality of the repetition response. +USED-OF is the optimal factor used in calculation of the last +interval used for the item in question. +OLD-OF is the previous value of the OF entry corresponding to the +relevant repetition number and the E-Factor of the item. +FRACTION is a number belonging to the range (0,1) determining the +rate of modifications (the greater it is the faster the changes +of the OF matrix). + +Returns the newly calculated value of the considered entry of the +OF matrix." + (let (;; the value proposed for the modifier in case of q=5 + (mod5 (/ (1+ interval-used) interval-used)) + ;; the value proposed for the modifier in case of q=2 + (mod2 (/ (1- interval-used) interval-used)) + ;; the number determining how many times the OF value will + ;; increase or decrease + modifier) + (if (< mod5 1.05) + (setq mod5 1.05)) + (if (< mod2 0.75) + (setq mod5 0.75)) + (if (> quality 4) + (setq modifier (1+ (* (- mod5 1) (- quality 4)))) + (setq modifier (- 1 (* (/ (- 1 mod2) 2) (- 4 quality))))) + (if (< modifier 0.05) + (setq modifier 0.05)) + (setq new-of (* used-of modifier)) + (if (> quality 4) + (if (< new-of old-of) + (setq new-of old-of))) + (if (< quality 4) + (if (> new-of old-of) + (setq new-of old-of))) + (setq new-of (+ (* new-of fraction) (* old-of (- 1 fraction)))) + (if (< new-of 1.2) + (setq new-of 1.2) + new-of))) + +(defvar initial-repetition-state '(-1 1 2.5 nil)) + +(defun determine-next-interval (n ef quality of-matrix) + (assert (> n 0)) + (assert (and (>= quality 0) (<= quality 5))) + (if (< quality 3) + (list (inter-repetition-interval n ef) (1+ n) ef nil) + (let ((next-ef (modify-e-factor ef quality))) + (setq of-matrix + (set-optimal-factor n next-ef of-matrix + (modify-of (get-optimal-factor n ef of-matrix) + quality org-learn-fraction)) + ef next-ef) + ;; For a zero-based quality of 4 or 5, don't repeat + (if (and (>= quality 4) + (not org-learn-always-reschedule)) + (list 0 (1+ n) ef of-matrix) + (list (inter-repetition-interval n ef of-matrix) (1+ n) + ef of-matrix))))) + +(defun org-smart-reschedule (quality) + (interactive "nHow well did you remember the information (on a scale of 0-5)? ") + (let* ((learn-str (org-entry-get (point) "LEARN_DATA")) + (learn-data (or (and learn-str + (read learn-str)) + (copy-list initial-repetition-state))) + closed-dates) + (setq learn-data + (determine-next-interval (nth 1 learn-data) + (nth 2 learn-data) + quality + (nth 3 learn-data))) + (org-entry-put (point) "LEARN_DATA" (prin1-to-string learn-data)) + (if (= 0 (nth 0 learn-data)) + (org-schedule t) + (org-schedule nil (time-add (current-time) + (days-to-time (nth 0 learn-data))))))) + +(provide 'org-learn) + +;;; org-learn.el ends here diff --git a/contrib/lisp/org-license.el b/contrib/lisp/org-license.el new file mode 100644 index 0000000..2fad68f --- /dev/null +++ b/contrib/lisp/org-license.el @@ -0,0 +1,540 @@ +;;; org-license.el --- Add a license to your org files + +;; Copyright (C) 2013-2017 Free Software Foundation, Inc. + +;; Author: David Arroyo Menéndez <davidam@es.gnu.org> +;; Keywords: licenses, creative commons +;; Homepage: http://orgmode.org +;; +;; This file is not part of GNU Emacs, yet. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file implements functions to add a license fast in org files. +;; Org-mode doesn't load this module by default - if this is not what +;; you want, configure the variable `org-modules'. Thanks to #emacs-es +;; irc channel for your support. + +;;; Code: + +;; +;; +;; You can download the images from http://www.davidam/img/licenses.tar.gz +;; +;;; CHANGELOG: +;; v 0.2 - add public domain functions +;; v 0.1 - Initial release + + +(defvar org-license-images-directory "") + +(defun org-license-cc-by (language) + (interactive "MLanguage ( br | ca | de | en | es | eo | eu | fi | fr | gl | it | jp | nl | pt ): " language) + (cond ((equal language "br") + (setq org-license-cc-url "https://creativecommons.org/licenses/by/3.0/br/deed.pt_BR") + (insert (concat "* Licença +Este texto é disponibilizado nos termos da licença [[" org-license-cc-url "][Atribuição 3.0 Brasil]]\n"))) + ((equal language "ca") + (setq org-license-cc-url "https://creativecommons.org/licenses/by/3.0/es/deed.ca") + (insert (concat "* Licència +El text està disponible sota la [[" org-license-cc-url "][Reconeixement 3.0 Espanya]]\n"))) + ((equal language "de") + (setq org-license-cc-url "https://creativecommons.org/licenses/by/3.0/de/deed.de") + (insert (concat "* Lizenz +Dieses Werk bzw. Inhalt steht unter einer [[" org-license-cc-url "][Lizenz Creative Commons Namensnennung 3.0 Deutschland]]\n"))) + ((equal language "eo") + (setq org-license-cc-url "http://creativecommons.org/licenses/by/3.0/eo/deed.eo") + (insert (concat "* Licenco +Ĉi tiu verko estas disponebla laŭ la permesilo [[" org-license-cc-url "][Krea Komunaĵo Atribuite 3.0 Neadaptita]]\n"))) + ((equal language "es") + (setq org-license-cc-url "http://creativecommons.org/licenses/by/3.0/es/deed.es") + (insert (concat "* Licencia +Este documento está bajo una [[" org-license-cc-url "][Licencia Creative Commons Atribución 3.0 España]]\n"))) + ((equal language "eu") + (setq org-license-cc-url "http://creativecommons.org/licenses/by/3.0/es/deed.eu") + (insert (concat "* Licenzua +Testua [[" org-license-cc-url "][Aitortu 3.0 Espainia]] lizentziari jarraituz erabil daiteke\n"))) + ((equal language "fi") + (setq org-license-cc-url "http://creativecommons.org/licenses/by/1.0/fi/deed.fi") + (insert (concat "* Lisenssi +Teksti on saatavilla [[" org-license-cc-url "][Nimeä 1.0 Suomi]] lisenssillä\n"))) + ((equal language "fr") + (setq org-license-cc-url "http://creativecommons.org/licenses/by/3.0/fr/deed.fr") + (insert (concat "* Licence +Ce(tte) œuvre est mise à disposition selon les termes de la [[" org-license-cc-url "][Licence Creative Commons Attribution 3.0 France]]\n"))) + ((equal language "gl") + (setq org-license-cc-url "http://creativecommons.org/licenses/by/3.0/es/deed.gl") + (insert (concat "* Licenza +Todo o texto está dispoñible baixo a [[" org-license-cc-url "][licenza Creative Commons recoñecemento compartir igual 3.0]].\n"))) + ((equal language "it") + (setq org-license-cc-url "http://creativecommons.org/licenses/by/3.0/it/deed.it") + (insert (concat "* Licenza +Quest'opera e distribuita con Licenza [[" org-license-cc-url "][Licenza Creative Commons Attribuzione 3.0 Italia]]\n"))) + ((equal language "jp") + (setq org-license-cc-url "http://creativecommons.org/licenses/by/2.1/jp/deed.en") + (insert (concat "* ライセンス +この文書は [[" org-license-cc-url "][Creative Commons Attribution 2.1 ]] ライセンスの下である\n"))) + ((equal language "nl") + (setq org-license-cc-url "http://creativecommons.org/licenses/by/3.0/nl/deed.nl") + (insert (concat "* Licentie +Dit werk is valt onder een [[" org-license-cc-url "][Creative Commons Naamsvermelding 3.0 Nederland]]\n"))) + ((equal language "pt") + (setq org-license-cc-url "http://creativecommons.org/licenses/by/3.0/pt/deed.pt") + (insert (concat "* Licença +Este texto é disponibilizado nos termos da licença [[" org-license-cc-url "][Atribuição 3.0 Portugal]]\n"))) + (t + (setq org-license-cc-url "http://creativecommons.org/licenses/by/4.0/deed") + (concat (insert "* License +This document is under a [[" org-license-cc-url "][Creative Commons Attribution 4.0 International]]\n")))) + (if (string= "" org-license-images-directory) + (insert (concat "\n[[" org-license-cc-url "][file:http://i.creativecommons.org/l/by/3.0/80x15.png]]\n")) + (insert (concat "\n[[" org-license-cc-url "][file:" org-license-images-directory "/by/3.0/80x15.png]]\n")))) + +(defun org-license-cc-by-sa (language) + (interactive "MLanguage ( br | ca | de | en | es | eu | fi | fr | it | jp | nl | pt ): " language) + (cond ((equal language "br") + (setq org-license-cc-url "https://creativecommons.org/licenses/by-sa/3.0/br/deed.pt_BR") + (concat (insert "* Licença +Este texto é disponibilizado nos termos da licença [[" org-license-cc-url "][Atribuição Compartil ha Igual 3.0 Brasil]]\n"))) + ((equal language "ca") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-sa/3.0/es/deed.ca") + (insert (concat "* Licència +El text està disponible sota la [[" org-license-cc-url "][Reconeixement-CompartirIgual 3.0 Espanya]]\n"))) + ((equal language "de") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-sa/3.0/de/deed.de") + (insert (concat "* Lizenz +Dieses Werk bzw. Inhalt steht unter einer [[" org-license-cc-url "][Namensnennung - Weitergabe unter gleichen Bedingungen 3.0 Deutschland]]\n"))) + ((equal language "es") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-sa/3.0/es/deed.es") + (concat (insert "* Licencia +Este documento está bajo una [[" org-license-cc-url "][Licencia Creative Commons Atribución Compartir por Igual 3.0 España]]\n"))) + ((equal language "eu") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-sa/3.0/es/deed.eu") + (concat (insert "* Licenzua +Testua [[" org-license-cc-url "][Aitortu-PartekatuBerdin 3.0 Espainia]] lizentziari jarraituz erabil daiteke\n"))) + ((equal language "fi") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-sa/1.0/fi/deed.fi") + (insert (concat "* Lisenssi +Teksti on saatavilla [[" org-license-cc-url "][Nimeä-JaaSamoin 1.0 Suomi]] lisenssillä\n"))) + ((equal language "fr") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-sa/3.0/fr/deed.fr") + (concat (insert "* Licence +Ce(tte) œuvre est mise à disposition selon les termes de la [[" org-license-cc-url "][Licence Creative Commons Attribution - Partage dans les Mêmes Conditions 3.0 France]]\n"))) + ((equal language "gl") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-sa/3.0/es/deed.gl") + (insert (concat "* Licenza +Todo o texto está dispoñible baixo a [[" org-license-cc-url "][licenza Creative Commons recoñecemento compartir igual 3.0]].\n"))) + ((equal language "it") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-sa/3.0/it/deed.it") + (insert (concat "* Licenza +Quest'opera e distribuita con Licenza [[" org-license-cc-url "][Licenza Creative Commons Attribuzione - Condividi allo stesso modo 3.0 Italia]]\n"))) + ((equal language "jp") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-sa/2.1/jp/deed.en") + (insert (concat "* ライセンス +この文書は、[[" org-license-cc-url "][Creative Commons Attribution 2.1 ]] ライセンスの下である\n"))) + ((equal language "nl") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-sa/3.0/nl/deed.nl") + (insert (concat "* Licentie +Dit werk is valt onder een [[" org-license-cc-url "][Creative Commons Naamsvermelding Gelijk Delen 3.0 Nederland]]\n"))) + ((equal language "pt") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-sa/3.0/pt/deed.pt") + (insert (concat "* Licença +Este texto é disponibilizado nos termos da licença [[" org-license-cc-url "][Atribuição-CompartilhaIgual 3.0 Portugal]]\n"))) + (t + (setq org-license-cc-url "http://creativecommons.org/licenses/by-sa/4.0/deed") + (insert (concat "* License +This document is under a [[" org-license-cc-url "][Creative Commons Attribution-ShareAlike 4.0 International]]\n")))) + (if (string= "" org-license-images-directory) + (insert (concat "\n[[" org-license-cc-url "][file:http://i.creativecommons.org/l/by-sa/3.0/80x15.png]]\n")) + (insert (concat "\n[[" org-license-cc-url "][file:" org-license-images-directory "/by-sa/3.0/80x15.png]]\n")))) + +(defun org-license-cc-by-nd (language) + (interactive "MLanguage ( br | ca | de | en | es | eu | fi | fr | it | pt ): " language) + (cond ((equal language "br") + (setq org-license-cc-url "https://creativecommons.org/licenses/by-nd/3.0/br/deed.pt_BR") + (insert (concat "* Licença +Este texto é disponibilizado nos termos da licença [[" org-license-cc-url "][Atribuição Compartil ha Igual 3.0 Brasil]]\n"))) + ((equal language "ca") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nd/3.0/es/deed.ca") + (insert (concat "* Licència +El text està disponible sota la [[" org-license-cc-url "][Reconeixement-SenseObraDerivada 3.0 Espanya]]\n"))) + ((equal language "de") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nd/3.0/de/deed.de") + (insert (concat "* Lizenz +Dieses Werk bzw. Inhalt steht unter einer [[" org-license-cc-url "][Namensnennung-Keine Bearbeitung 3.0 Deutschland]]\n"))) + ((equal language "es") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nd/3.0/es/deed.es") + (insert (concat "* Licencia +Este documento está bajo una [[" org-license-cc-url "][Licencia Creative Commons Atribución-SinDerivadas 3.0]]\n"))) + ((equal language "eu") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nd/3.0/es/deed.eu") + (insert (concat "* Licenzua +Testua [[" org-license-cc-url "][Aitortu-LanEratorririkGabe 3.0 Espainia]] lizentziari jarraituz erabil daiteke\n"))) + ((equal language "fi") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nd/1.0/fi/deed.fi") + (insert (concat "* Lisenssi +Teksti on saatavilla [[" org-license-cc-url "][Nimeä-JaaSamoin 1.0 Suomi]] lisenssillä\n"))) + ((equal language "fr") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nd/3.0/fr/deed.fr") + (insert (concat "* Licence +Ce(tte) œuvre est mise à disposition selon les termes de la [[" org-license-cc-url "][Licence Creative Commons Attribution - Pas de Modification 3.0 France]]\n"))) + ((equal language "gl") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nd/3.0/es/deed.gl") + (insert (concat "* Licenza +Todo o texto está dispoñible baixo a [[" org-license-cc-url "][licenza Creative Commons recoñecemento compartir igual 3.0]].\n"))) + ((equal language "it") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nd/3.0/it/deed.it") + (insert (concat "* Licenza +Quest'opera e distribuita con Licenza [[" org-license-cc-url "][Licenza Creative Commons Attribuzione - Non opere derivate 3.0 Italia]]\n"))) + ((equal language "jp") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nd/2.1/jp/deed.en") + (insert (concat "* ライセンス +この文書は、[[" org-license-cc-url "][Creative Commons No Derivatives 2.1]] ライセンスの下である\n"))) + ((equal language "nl") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nd/3.0/nl/deed.nl") + (insert (concat "* Licentie +Dit werk is valt onder een [[" org-license-cc-url "][Creative Commons Naamsvermelding GeenAfgeleideWerken 3.0 Nederland]]\n"))) + ((equal language "pt") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nd/3.0/pt/deed.pt") + (insert (concat "* Licença +Este texto é disponibilizado nos termos da licença [[" org-license-cc-url "][Atribuição Sem Derivados 3.0 Portugal]]\n"))) + (t + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nd/4.0/deed") + (insert (concat "* License +This document is under a [[" org-license-cc-url "][Creative Commons No Derivatives 4.0 International]]\n")))) + (if (string= "" org-license-images-directory) + (insert (concat "\n[[" org-license-cc-url "][file:http://i.creativecommons.org/l/by-nd/3.0/80x15.png]]\n")) + (insert (concat "\n[[" org-license-cc-url "][file:" org-license-images-directory "/by-nd/3.0/80x15.png]]\n")))) + + +(defun org-license-cc-by-nc (language) + (interactive "MLanguage ( br | ca | de | en | es | eu | fi | fr | it | jp | nl | pt ): " language) + (cond ((equal language "br") + (setq org-license-cc-url "https://creativecommons.org/licenses/by-nc/3.0/br/deed.pt_BR") + (insert (concat "* Licença +Este texto é disponibilizado nos termos da licença [[" org-license-cc-url "][Atribuição Não Comercial 3.0 Brasil]]\n"))) + ((equal language "ca") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/3.0/es/deed.ca") + (insert (concat "* Licència +El text està disponible sota la [[" org-license-cc-url "][Reconeixement-NoComercial 3.0 Espanya]]\n"))) + ((equal language "de") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/3.0/de/deed.de") + (insert (concat "* Lizenz +Dieses Werk bzw. Inhalt steht unter einer [[" org-license-cc-url "][Namensnennung-Nicht-kommerziell 3.0 Deutschland]]\n"))) + ((equal language "es") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/3.0/es/deed.es") + (insert (concat "* Licencia +Este documento está bajo una [[" org-license-cc-url "][Licencia Creative Commons Reconocimiento-NoComercial 3.0]]\n"))) + ((equal language "eu") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/3.0/es/deed.eu") + (insert "* Licenzua +Testua [[" org-license-cc-url "][Aitortu-EzKomertziala 3.0 Espainia]] lizentziari jarraituz erabil daiteke\n")) + ((equal language "fi") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/1.0/fi/deed.fi") + (insert (concat "* Lisenssi +Teksti on saatavilla [[" org-license-cc-url "][Nimeä-Epäkaupallinen 1.0 Suomi]] lisenssillä\n"))) + ((equal language "fr") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/3.0/fr/deed.fr") + (insert (concat "* Licence +Ce(tte) œuvre est mise à disposition selon les termes de la [[" org-license-cc-url "][Licence Creative Commons Attribution - Pas d'Utilisation Commerciale 3.0 France]]\n"))) + ((equal language "gl") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/3.0/es/deed.gl") + (insert (concat "* Licenza +Todo o texto está dispoñible baixo a [[" org-license-cc-url "][licenza Creative Commons recoñecemento compartir igual 3.0]].\n"))) + ((equal language "it") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/3.0/it/deed.it") + (insert (concat "* Licenza +Quest'opera e distribuita con Licenza [[" org-license-cc-url "][Licenza Creative Commons Attribuzione - Non commerciale 3.0 Italia]]\n"))) + ((equal language "jp") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/2.1/jp/deed.en") + (insert (concat "* ライセンス +この文書は、[[" org-license-cc-url "][Creative Commons Attribution-NonCommercial 2.1 ]] ライセンスの下である\n"))) + ((equal language "nl") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/3.0/nl/deed.nl") + (insert (concat "* Licentie +Dit werk is valt onder een [[" org-license-cc-url "][Creative Commons Naamsvermelding NietCommercieel 3.0 Nederland 3.0 Nederland]]\n"))) + ((equal language "pt") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/3.0/pt/deed.pt") + (insert (concat "* Licença +Este texto é disponibilizado nos termos da licença [[" org-license-cc-url "][Atribuição Não Comercial 3.0 Portugal]]\n"))) + (t + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/4.0/deed") + (insert (concat "* License +This document is under a [[" org-license-cc-url "][Creative Commons Attribution-NonCommercial 4.0 International]]\n")))) + (if (string= "" org-license-images-directory) + (insert (concat "\n[[" org-license-cc-url "][file:http://i.creativecommons.org/l/by-nc/3.0/80x15.png]]\n")) + (insert (concat "\n[[" org-license-cc-url "][file:" org-license-images-directory "/by-nc/3.0/80x15.png]]\n")))) + +(defun org-license-cc-by-nc-sa (language) + (interactive "MLanguage ( br | ca | de | en | es | eu | fi | fr | gl | it | jp | nl | pt ): " language) + (cond ((equal language "br") + (setq org-license-cc-url "https://creativecommons.org/licenses/by-nc-sa/3.0/br/deed.pt_BR") + (insert (concat "* Licença +Este texto é disponibilizado nos termos da licença [[" org-license-cc-url "][Atribuição Não Comercial - Compartil ha Igual 3.0 Brasil]]\n"))) + ((equal language "ca") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-sa/3.0/es/deed.ca") + (insert (concat "* Licència +El text està disponible sota la [[" org-license-cc-url "][Reconeixement-NoComercial 3.0 Espanya]]\n"))) + ((equal language "de") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-sa/3.0/de/deed.de") + (insert (concat "* Lizenz +Dieses Werk bzw. Inhalt steht unter einer [[" org-license-cc-url "][Namensnennung - Weitergabe unter gleichen Bedingungen 3.0 Deutschland]]\n"))) + ((equal language "es") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-sa/3.0/es/deed.es") + (insert (concat "* Licencia +Este documento está bajo una [[" org-license-cc-url "][Licencia Creative Commons Reconocimiento-NoComercial 3.0]]\n"))) + ((equal language "eu") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-sa/3.0/es/deed.eu") + (insert "* Licenzua +Testua [[" org-license-cc-url "][Aitortu-EzKomertziala-PartekatuBerdin 3.0 Espainia]] lizentziari jarraituz erabil daiteke\n")) + ((equal language "fi") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-sa/1.0/fi/deed.fi") + (insert (concat "* Lisenssi +Teksti on saatavilla [[" org-license-cc-url "][Nimeä-Epäkaupallinen-JaaSamoin 1.0 Suomi]] lisenssillä\n"))) + ((equal language "fr") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-sa/3.0/fr/deed.fr") + (insert (concat "* Licence +Ce(tte) œuvre est mise à disposition selon les termes de la [[" org-license-cc-url "][Licence Creative Commons Attribution - Pas d’Utilisation Commerciale - Partage dans les Mêmes Conditions 3.0 France]]\n"))) + ((equal language "gl") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-sa/3.0/es/deed.gl") + (insert (concat "* Licenza +Todo o texto está dispoñible baixo a [[" org-license-cc-url "][licenza Creative Commons recoñecemento compartir igual 3.0]].\n"))) + ((equal language "it") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-sa/3.0/it/deed.it") + (insert (concat "* Licenza +Quest'opera e distribuita con Licenza [[" org-license-cc-url "][Licenza Creative Commons Attribuzione - Non opere derivate 3.0 Italia]]\n"))) + ((equal language "jp") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-sa/2.1/jp/deed.en") + (insert (concat "* ライセンス +この文書は、[[" org-license-cc-url "][License Creative Commons Attribution Non Commercial Share Alike 2.1 ]] ライセンスの下である\n"))) + ((equal language "nl") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-sa/3.0/nl/deed.nl") + (insert (concat "* Licentie +Dit werk is valt onder een [[" org-license-cc-url "][Creative Commons Naamsvermelding NietCommercieel GelijkDelen 3.0 Nederland]]\n"))) + ((equal language "pt") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/3.0/pt/deed.pt") + (insert (concat "* Licença +Este texto é disponibilizado nos termos da licença [[" org-license-cc-url "][Atribuição NãoComercial Compartil ha Igual 3.0 Portugal]]\n"))) + (t + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-sa/4.0/deed") + (insert (concat "* License +This document is under a [[" org-license-cc-url "][License Creative Commons Attribution Non Commercial Share Alike 4.0 International]]\n")))) + (if (string= "" org-license-images-directory) + (insert (concat "\n[[" org-license-cc-url "][file:http://i.creativecommons.org/l/by-nc-sa/3.0/80x15.png]]\n")) + (insert (concat "\n[[" org-license-cc-url "][file:" org-license-images-directory "/by-nc-sa/3.0/80x15.png]]\n")))) + +(defun org-license-cc-by-nc-nd (language) + (interactive "MLanguage ( br | ca | de | en | es | eu | fi | fr | gl | it | pt ): " language) + (cond ((equal language "br") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/3.0/pt/deed.pt") + (insert (concat "* Licença +Este texto é disponibilizado nos termos da licença [[" org-license-cc-url "][Atribuição Não Comercial Sem Derivados 3.0 Brasil]]\n"))) + ((equal language "ca") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/3.0/es/deed.ca") + (insert (concat "* Licència +El text està disponible sota la [[" org-license-cc-url "][Reconeixement-NoComercial-SenseObraDerivada 3.0 Espanya]]\n"))) + ((equal language "de") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/3.0/de/deed.de") + (insert (concat "* Lizenz +Dieses Werk bzw. Inhalt steht unter einer [[" org-license-cc-url "][Namensnennung-NichtKommerziell-KeineBearbeitung 3.0 Deutschland]]\n"))) + ((equal language "es") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/3.0/es/deed.es") + (insert (concat "* Licencia +Este documento está bajo una [[" org-license-cc-url "][Licencia Creative Commons Reconocimiento-NoComercial-SinObraDerivada 3.0]]\n"))) + ((equal language "eu") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/3.0/es/deed.eu") + (insert (concat "* Licenzua +Testua [[" org-license-cc-url "][Aitortu-LanEratorririkGabe 3.0 Espainia]] lizentziari jarraituz erabil daiteke\n"))) + ((equal language "fi") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/1.0/fi/deed.fi") + (insert (concat "* Lisenssi +Teksti on saatavilla [[" org-license-cc-url "][Nimeä-Ei muutoksia-Epäkaupallinen 1.0 Suomi]] lisenssillä\n"))) + ((equal language "fr") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/3.0/fr/deed.fr") + (insert (concat "* Licence +Ce(tte) œuvre est mise à disposition selon les termes de la [[" org-license-cc-url "][Licence Creative Commons Attribution - Pas de Modification 3.0 France]]\n"))) + ((equal language "gl") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/3.0/es/deed.gl") + (insert (concat "* Licenza +Todo o texto está dispoñible baixo a [[" org-license-cc-url "][licenza Creative Commons recoñecemento compartir igual 3.0]].\n"))) + ((equal language "it") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/3.0/it/deed.it") + (insert (concat "* Licenza +Quest'opera e distribuita con Licenza [[" org-license-cc-url "][Licenza Creative Commons Attribuzione - Non opere derivate 3.0 Italia]]\n"))) + ((equal language "jp") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/2.1/jp/deed.en") + (insert (concat "* ライセンス +この文書は [[" org-license-cc-url "][License Creative Commons Attribution Non Commercial - No Derivs 2.1]] ライセンスの下である\n"))) + ((equal language "nl") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/3.0/nl/deed.nl") + (insert (concat "* Licentie +Dit werk is valt onder een [[" org-license-cc-url "][Creative Commons Naamsvermelding NietCommercieel GeenAfgeleideWerken 3.0 Nederland]]\n"))) + ((equal language "pt") + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/3.0/pt/deed.pt") + (insert (concat "* Licença +Este texto é disponibilizado nos termos da licença [[" org-license-cc-url "][Atribuição Não Comercial Sem Derivados 3.0 Portugal]]\n"))) + (t + (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/4.0/deed") + (insert (concat "* License +This document is under a [[" org-license-cc-url "][License Creative Commons Attribution-NonCommercial-NoDerivatives 4.0 International]]\n")))) + (if (string= "" org-license-images-directory) + (insert (concat "\n[[" org-license-cc-url "][file:http://i.creativecommons.org/l/by-nc-nd/3.0/80x15.png]]\n")) + (insert (concat "\n[[" org-license-cc-url "][file:" org-license-images-directory "/by-nc-nd/3.0/80x15.png]]\n")))) + +(defun org-license-gfdl (language) + (interactive "MLanguage (es | en): " language) + (cond ((equal language "es") + (insert "* Licencia +Copyright (C) " (format-time-string "%Y") " " user-full-name +"\n Se permite copiar, distribuir y/o modificar este documento + bajo los términos de la GNU Free Documentation License, Version 1.3 + o cualquier versión publicada por la Free Software Foundation; + sin Secciones Invariantes y sin Textos de Portada o Contraportada. + Una copia de la licencia está incluida en [[https://www.gnu.org/copyleft/fdl.html][GNU Free Documentation License]].\n")) + (t (insert (concat "* License +Copyright (C) " (format-time-string "%Y") " " user-full-name +"\n Permission is granted to copy, distribute and/or modify this document + under the terms of the GNU Free Documentation License, Version 1.3 + or any later version published by the Free Software Foundation; + with no Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. + A copy of the license is included in [[https://www.gnu.org/copyleft/fdl.html][GNU Free Documentation License]].\n")))) + (if (string= "" org-license-images-directory) + (insert "\n[[https://www.gnu.org/copyleft/fdl.html][file:https://upload.wikimedia.org/wikipedia/commons/thumb/4/42/GFDL_Logo.svg/200px-GFDL_Logo.svg.png]]\n") + (insert (concat "\n[[https://www.gnu.org/copyleft/fdl.html][file:" org-license-images-directory "/gfdl/gfdl.png]]\n")))) + +(defun org-license-publicdomain-zero (language) + (interactive "MLanguage ( en | es ): " language) + (setq org-license-pd-url "http://creativecommons.org/publicdomain/zero/1.0/") + (setq org-license-pd-file "zero/1.0/80x15.png") + (if (equal language "es") + (insert (concat "* Licencia +Este documento está bajo una licencia [[" org-license-pd-url "][Public Domain Zero]]\n")) + (insert (concat "* License +This documento is under a [[" org-license-pd-url "][Public Domain Zero]] license\n"))) + (if (string= "" org-license-images-directory) + (insert (concat "\n[[" org-license-pd-url "][file:http://i.creativecommons.org/p/zero/1.0/80x15.png]]\n")) + (insert (concat "\n[[" org-license-pd-url "][file:" org-license-images-directory org-license-pd-file "]]\n")))) + +(defun org-license-publicdomain-mark (language) + (interactive "MLanguage ( en | es ): " language) + (setq org-license-pd-url "http://creativecommons.org/publicdomain/mark/1.0/") + (setq org-license-pd-file "mark/1.0/80x15.png") + (if (equal language "es") + (insert (concat "* Licencia +Este documento está bajo una licencia [[" org-license-pd-url "][Etiqueta de Dominio Público 1.0]]\n")) + (insert (concat "* License +This documento is under a [[" org-license-pd-url "][Public Domain Mark]] license\n"))) + (if (string= "" org-license-images-directory) + (insert (concat "\n[[" org-license-pd-url "][file:http://i.creativecommons.org/p/mark/1.0/80x15.png]]\n")) + (insert (concat "\n[[" org-license-pd-url "][file:" org-license-images-directory org-license-pd-file "]]\n")))) + +(defun org-license-print-all () +"Print all combinations of licenses and languages, it's useful to find bugs" + (interactive) + (org-license-gfdl "es") + (org-license-gfdl "en") + (org-license-publicdomain-mark "es") + (org-license-publicdomain-mark "en") + (org-license-publicdomain-zero "es") + (org-license-publicdomain-zero "en") + (org-license-cc-by "br") + (org-license-cc-by "ca") + (org-license-cc-by "de") + (org-license-cc-by "es") + (org-license-cc-by "en") + (org-license-cc-by "eo") + (org-license-cc-by "eu") + (org-license-cc-by "fi") + (org-license-cc-by "fr") + (org-license-cc-by "gl") + (org-license-cc-by "it") + (org-license-cc-by "jp") + (org-license-cc-by "nl") + (org-license-cc-by "pt") + (org-license-cc-by-sa "br") + (org-license-cc-by-sa "ca") + (org-license-cc-by-sa "de") + (org-license-cc-by-sa "es") + (org-license-cc-by-sa "en") +;; (org-license-cc-by-sa "eo") + (org-license-cc-by-sa "eu") + (org-license-cc-by-sa "fi") + (org-license-cc-by-sa "fr") + (org-license-cc-by-sa "gl") + (org-license-cc-by-sa "it") + (org-license-cc-by-sa "jp") + (org-license-cc-by-sa "nl") + (org-license-cc-by-sa "pt") + (org-license-cc-by-nd "br") + (org-license-cc-by-nd "ca") + (org-license-cc-by-nd "de") + (org-license-cc-by-nd "es") + (org-license-cc-by-nd "en") +;; (org-license-cc-by-nd "eo") + (org-license-cc-by-nd "eu") + (org-license-cc-by-nd "fi") + (org-license-cc-by-nd "fr") + (org-license-cc-by-nd "gl") + (org-license-cc-by-nd "it") + (org-license-cc-by-nd "jp") + (org-license-cc-by-nd "nl") + (org-license-cc-by-nd "pt") + (org-license-cc-by-nc "br") + (org-license-cc-by-nc "ca") + (org-license-cc-by-nc "de") + (org-license-cc-by-nc "es") + (org-license-cc-by-nc "en") +;; (org-license-cc-by-nc "eo") + (org-license-cc-by-nc "eu") + (org-license-cc-by-nc "fi") + (org-license-cc-by-nc "fr") + (org-license-cc-by-nc "gl") + (org-license-cc-by-nc "it") + (org-license-cc-by-nc "jp") + (org-license-cc-by-nc "nl") + (org-license-cc-by-nc "pt") + (org-license-cc-by-nc-sa "br") + (org-license-cc-by-nc-sa "ca") + (org-license-cc-by-nc-sa "de") + (org-license-cc-by-nc-sa "es") + (org-license-cc-by-nc-sa "en") +;; (org-license-cc-by-nc-sa "eo") + (org-license-cc-by-nc-sa "eu") + (org-license-cc-by-nc-sa "fi") + (org-license-cc-by-nc-sa "fr") + (org-license-cc-by-nc-sa "gl") + (org-license-cc-by-nc-sa "it") + (org-license-cc-by-nc-sa "jp") + (org-license-cc-by-nc-sa "nl") + (org-license-cc-by-nc-sa "pt") + (org-license-cc-by-nc-nd "br") + (org-license-cc-by-nc-nd "ca") + (org-license-cc-by-nc-nd "de") + (org-license-cc-by-nc-nd "es") + (org-license-cc-by-nc-nd "en") +;; (org-license-cc-by-nc-nd "eo") + (org-license-cc-by-nc-nd "eu") + (org-license-cc-by-nc-nd "fi") + (org-license-cc-by-nc-nd "fr") + (org-license-cc-by-nc-nd "gl") + (org-license-cc-by-nc-nd "it") + (org-license-cc-by-nc-nd "jp") + (org-license-cc-by-nc-nd "nl") + (org-license-cc-by-nc-nd "pt") +) + + diff --git a/contrib/lisp/org-link-edit.el b/contrib/lisp/org-link-edit.el new file mode 100644 index 0000000..000dd1c --- /dev/null +++ b/contrib/lisp/org-link-edit.el @@ -0,0 +1,390 @@ +;;; org-link-edit.el --- Slurp and barf with Org links -*- lexical-binding: t; -*- + +;; Copyright (C) 2015-2017 Kyle Meyer <kyle@kyleam.com> + +;; Author: Kyle Meyer <kyle@kyleam.com> +;; URL: https://gitlab.com/kyleam/org-link-edit +;; Keywords: convenience +;; Version: 1.1.1 +;; Package-Requires: ((cl-lib "0.5") (org "8.2.10")) + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org Link Edit provides Paredit-inspired slurping and barfing +;; commands for Org link descriptions. +;; +;; There are four slurp and barf commands, all which operate when +;; point is on an Org link. +;; +;; - org-link-edit-forward-slurp +;; - org-link-edit-backward-slurp +;; - org-link-edit-forward-barf +;; - org-link-edit-backward-barf +;; +;; Org Link Edit doesn't bind these commands to any keys. Finding +;; good keys for these commands is difficult because, while it's +;; convenient to be able to quickly repeat these commands, they won't +;; be used frequently enough to be worthy of a short, repeat-friendly +;; binding. Using Hydra [1] provides a nice solution to this. After +;; an initial key sequence, any of the commands will be repeatable +;; with a single key. (Plus, you get a nice interface that displays +;; the key for each command.) Below is one example of how you could +;; configure this. +;; +;; (define-key org-mode-map YOUR-KEY +;; (defhydra hydra-org-link-edit () +;; "Org Link Edit" +;; ("j" org-link-edit-forward-slurp "forward slurp") +;; ("k" org-link-edit-forward-barf "forward barf") +;; ("u" org-link-edit-backward-slurp "backward slurp") +;; ("i" org-link-edit-backward-barf "backward barf") +;; ("q" nil "cancel"))) +;; +;; In addition to the slurp and barf commands, the command +;; `org-link-edit-transport-next-link' searches for the next (or +;; previous) link and moves it to point, using the word at point or +;; the selected region as the link's description. +;; +;; [1] https://github.com/abo-abo/hydra + +;;; Code: + +(require 'org) +(require 'org-element) +(require 'cl-lib) + +(defun org-link-edit--on-link-p (&optional element) + (let ((el (or element (org-element-context)))) + ;; Don't use `org-element-lineage' because it isn't available + ;; until Org version 8.3. + (while (and el (not (memq (car el) '(link)))) + (setq el (org-element-property :parent el))) + (eq (car el) 'link))) + +(defun org-link-edit--link-data () + "Return list with information about the link at point. +The list includes +- the position at the start of the link +- the position at the end of the link +- the link text +- the link description (nil when on a plain link)" + (let ((el (org-element-context))) + (unless (org-link-edit--on-link-p el) + (user-error "Point is not on a link")) + (save-excursion + (goto-char (org-element-property :begin el)) + (cond + ;; Use match-{beginning,end} because match-end is consistently + ;; positioned after ]], while the :end property is positioned + ;; at the next word on the line, if one is present. + ((looking-at org-bracket-link-regexp) + (list (match-beginning 0) + (match-end 0) + (save-match-data + (org-link-unescape (match-string-no-properties 1))) + (or (and (match-end 3) + (match-string-no-properties 3)) + ""))) + ((looking-at org-plain-link-re) + (list (match-beginning 0) + (match-end 0) + (org-link-unescape (match-string-no-properties 0)) + nil)) + (t + (error "What am I looking at?")))))) + +(defun org-link-edit--forward-blob (n &optional no-punctuation) + "Move forward N blobs (backward if N is negative). + +A block of non-whitespace characters is a blob. If +NO-PUNCTUATION is non-nil, trailing punctuation characters are +not considered part of the blob when going in the forward +direction. + +If the edge of the buffer is reached before completing the +movement, return nil. Otherwise, return t." + (let* ((forward-p (> n 0)) + (nblobs (abs n)) + (skip-func (if forward-p 'skip-syntax-forward 'skip-syntax-backward)) + skip-func-retval) + (while (/= nblobs 0) + (funcall skip-func " ") + (setq skip-func-retval (funcall skip-func "^ ")) + (setq nblobs (1- nblobs))) + (when (and forward-p no-punctuation) + (let ((punc-tail-offset (save-excursion (skip-syntax-backward ".")))) + ;; Don't consider trailing punctuation as part of the blob + ;; unless the whole blob consists of punctuation. + (unless (= skip-func-retval (- punc-tail-offset)) + (goto-char (+ (point) punc-tail-offset))))) + (/= skip-func-retval 0))) + +;;;###autoload +(defun org-link-edit-forward-slurp (&optional n) + "Slurp N trailing blobs into link's description. + + The \[\[http://orgmode.org/\]\[Org mode\]\] site + + | + v + + The \[\[http://orgmode.org/\]\[Org mode site\]\] + +A blob is a block of non-whitespace characters. When slurping +forward, trailing punctuation characters are not considered part +of a blob. + +After slurping, return the slurped text and move point to the +beginning of the link. + +If N is negative, slurp leading blobs instead of trailing blobs." + (interactive "p") + (setq n (or n 1)) + (cond + ((= n 0)) + ((< n 0) + (org-link-edit-backward-slurp (- n))) + (t + (cl-multiple-value-bind (beg end link desc) (org-link-edit--link-data) + (goto-char (save-excursion + (goto-char end) + (or (org-link-edit--forward-blob n 'no-punctuation) + (user-error "Not enough blobs after the link")) + (point))) + (let ((slurped (buffer-substring-no-properties end (point)))) + (setq slurped (replace-regexp-in-string "\n+" " " slurped)) + (when (and (= (length desc) 0) + (string-match "^\\s-+\\(.*\\)" slurped)) + (setq slurped (match-string 1 slurped))) + (setq desc (concat desc slurped) + end (+ end (length slurped))) + (delete-region beg (point)) + (insert (org-make-link-string link desc)) + (goto-char beg) + slurped))))) + +;;;###autoload +(defun org-link-edit-backward-slurp (&optional n) + "Slurp N leading blobs into link's description. + + The \[\[http://orgmode.org/\]\[Org mode\]\] site + + | + v + + \[\[http://orgmode.org/\]\[The Org mode\]\] site + +A blob is a block of non-whitespace characters. + +After slurping, return the slurped text and move point to the +beginning of the link. + +If N is negative, slurp trailing blobs instead of leading blobs." + (interactive "p") + (setq n (or n 1)) + (cond + ((= n 0)) + ((< n 0) + (org-link-edit-forward-slurp (- n))) + (t + (cl-multiple-value-bind (beg end link desc) (org-link-edit--link-data) + (goto-char (save-excursion + (goto-char beg) + (or (org-link-edit--forward-blob (- n)) + (user-error "Not enough blobs before the link")) + (point))) + (let ((slurped (buffer-substring-no-properties (point) beg))) + (when (and (= (length desc) 0) + (string-match "\\(.*\\)\\s-+$" slurped)) + (setq slurped (match-string 1 slurped))) + (setq slurped (replace-regexp-in-string "\n+" " " slurped)) + (setq desc (concat slurped desc) + beg (- beg (length slurped))) + (delete-region (point) end) + (insert (org-make-link-string link desc)) + (goto-char beg) + slurped))))) + +(defun org-link-edit--split-first-blobs (string n) + "Split STRING into (N first blobs . other) cons cell. +'N first blobs' contains all text from the start of STRING up to +the start of the N+1 blob. 'other' includes the remaining text +of STRING. If the number of blobs in STRING is fewer than N, +'other' is nil." + (when (< n 0) (user-error "N cannot be negative")) + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (with-syntax-table org-mode-syntax-table + (let ((within-bound (org-link-edit--forward-blob n))) + (skip-syntax-forward " ") + (cons (buffer-substring 1 (point)) + (and within-bound + (buffer-substring (point) (point-max)))))))) + +(defun org-link-edit--split-last-blobs (string n) + "Split STRING into (other . N last blobs) cons cell. +'N last blobs' contains all text from the end of STRING back to +the end of the N+1 last blob. 'other' includes the remaining +text of STRING. If the number of blobs in STRING is fewer than +N, 'other' is nil." + (when (< n 0) (user-error "N cannot be negative")) + (with-temp-buffer + (insert string) + (goto-char (point-max)) + (with-syntax-table org-mode-syntax-table + (let ((within-bound (org-link-edit--forward-blob (- n)))) + (skip-syntax-backward " ") + (cons (and within-bound + (buffer-substring 1 (point))) + (buffer-substring (point) (point-max))))))) + +;;;###autoload +(defun org-link-edit-forward-barf (&optional n) + "Barf N trailing blobs from link's description. + + The \[\[http://orgmode.org/\]\[Org mode\]\] site + + | + v + + The \[\[http://orgmode.org/\]\[Org\]\] mode site + +A blob is a block of non-whitespace characters. + +After barfing, return the barfed text and move point to the +beginning of the link. + +If N is negative, barf leading blobs instead of trailing blobs." + (interactive "p") + (setq n (or n 1)) + (cond + ((= n 0)) + ((< n 0) + (org-link-edit-backward-barf (- n))) + (t + (cl-multiple-value-bind (beg end link desc) (org-link-edit--link-data) + (when (= (length desc) 0) + (user-error "Link has no description")) + (pcase-let ((`(,new-desc . ,barfed) (org-link-edit--split-last-blobs + desc n))) + (unless new-desc (user-error "Not enough blobs in description")) + (goto-char beg) + (delete-region beg end) + (insert (org-make-link-string link new-desc)) + (when (string= new-desc "") + (setq barfed (concat " " barfed))) + (insert barfed) + (goto-char beg) + barfed))))) + +;;;###autoload +(defun org-link-edit-backward-barf (&optional n) + "Barf N leading blobs from link's description. + + The \[\[http://orgmode.org/\]\[Org mode\]\] site + + | + v + + The Org \[\[http://orgmode.org/\]\[mode\]\] site + +A blob is a block of non-whitespace characters. + +After barfing, return the barfed text and move point to the +beginning of the link. + +If N is negative, barf trailing blobs instead of leading blobs." + (interactive "p") + (setq n (or n 1)) + (cond + ((= n 0)) + ((< n 0) + (org-link-edit-forward-barf (- n))) + (t + (cl-multiple-value-bind (beg end link desc) (org-link-edit--link-data) + (when (= (length desc) 0) + (user-error "Link has no description")) + (pcase-let ((`(,barfed . ,new-desc) (org-link-edit--split-first-blobs + desc n))) + (unless new-desc (user-error "Not enough blobs in description")) + (goto-char beg) + (delete-region beg end) + (insert (org-make-link-string link new-desc)) + (when (string= new-desc "") + (setq barfed (concat barfed " "))) + (goto-char beg) + (insert barfed) + barfed))))) + +(defun org-link-edit--next-link-data (&optional previous) + (save-excursion + (if (funcall (if previous #'re-search-backward #'re-search-forward) + org-any-link-re nil t) + (org-link-edit--link-data) + (user-error "No %s link found" (if previous "previous" "next"))))) + +;;;###autoload +(defun org-link-edit-transport-next-link (&optional previous beg end) + "Move the next link to point. + +If the region is active, use the selected text as the link's +description. Otherwise, use the word at point. + +With prefix argument PREVIOUS, move the previous link instead of +the next link. + +Non-interactively, use the text between BEG and END as the +description, moving the next (or previous) link relative BEG and +END." + (interactive (cons current-prefix-arg + (and (use-region-p) + (list (region-beginning) (region-end))))) + (let ((pt (point)) + (desc-bounds (cond + ((and beg end) + (cons (progn (goto-char beg) + (point-marker)) + (progn (goto-char end) + (point-marker)))) + ((not (looking-at-p "\\s-")) + (progn (skip-syntax-backward "w") + (let ((beg (point-marker))) + (skip-syntax-forward "w") + (cons beg (point-marker)))))))) + (when (or (and desc-bounds + (or (progn (goto-char (car desc-bounds)) + (org-link-edit--on-link-p)) + (progn (goto-char (cdr desc-bounds)) + (org-link-edit--on-link-p)))) + (progn (goto-char pt) + (org-link-edit--on-link-p))) + (user-error "Cannot transport next link with point on a link")) + (goto-char (or (car desc-bounds) pt)) + (cl-multiple-value-bind (link-beg link-end link orig-desc) + (org-link-edit--next-link-data previous) + (unless (or (not desc-bounds) (= (length orig-desc) 0)) + (user-error "Link already has a description")) + (delete-region link-beg link-end) + (insert (org-make-link-string + link + (if desc-bounds + (delete-and-extract-region (car desc-bounds) + (cdr desc-bounds)) + orig-desc)))))) + +(provide 'org-link-edit) +;;; org-link-edit.el ends here diff --git a/contrib/lisp/org-mac-iCal.el b/contrib/lisp/org-mac-iCal.el new file mode 100644 index 0000000..937b6dd --- /dev/null +++ b/contrib/lisp/org-mac-iCal.el @@ -0,0 +1,250 @@ +;;; org-mac-iCal.el --- Imports events from iCal.app to the Emacs diary + +;; Copyright (C) 2009-2014 Christopher Suckling + +;; Author: Christopher Suckling <suckling at gmail dot com> +;; Version: 0.1057.104 +;; Keywords: outlines, calendar + +;; 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: +;; +;; This file provides the import of events from Mac OS X 10.5 iCal.app +;; into the Emacs diary (it is not compatible with OS X < 10.5). The +;; function org-mac-iCal will import events in all checked iCal.app +;; calendars for the date range org-mac-iCal-range months, centered +;; around the current date. +;; +;; CAVEAT: This function is destructive; it will overwrite the current +;; contents of the Emacs diary. +;; +;; Installation: add (require 'org-mac-iCal) to your .emacs. +;; +;; If you view Emacs diary entries in org-agenda, the following hook +;; will ensure that all-day events are not orphaned below TODO items +;; and that any supplementary fields to events (e.g. Location) are +;; grouped with their parent event +;; +;; (add-hook 'org-agenda-cleanup-fancy-diary-hook +;; (lambda () +;; (goto-char (point-min)) +;; (save-excursion +;; (while (re-search-forward "^[a-z]" nil t) +;; (goto-char (match-beginning 0)) +;; (insert "0:00-24:00 "))) +;; (while (re-search-forward "^ [a-z]" nil t) +;; (goto-char (match-beginning 0)) +;; (save-excursion +;; (re-search-backward "^[0-9]+:[0-9]+-[0-9]+:[0-9]+ " nil t)) +;; (insert (match-string 0))))) + +;;; Code: + +(defcustom org-mac-iCal-range 2 + "The range in months to import iCal.app entries into the Emacs +diary. The import is centered around today's date; thus a value +of 2 imports entries for one month before and one month after +today's date" + :group 'org-time + :type 'integer) + +(defun org-mac-iCal () + "Selects checked calendars in iCal.app and imports them into +the the Emacs diary" + (interactive) + + ;; kill diary buffers then empty diary files to avoid duplicates + (setq currentBuffer (buffer-name)) + (setq openBuffers (mapcar (function buffer-name) (buffer-list))) + (omi-kill-diary-buffer openBuffers) + (with-temp-buffer + (insert-file-contents diary-file) + (delete-region (point-min) (point-max)) + (write-region (point-min) (point-max) diary-file)) + + ;; determine available calendars + (setq caldav-folders (directory-files "~/Library/Calendars" 1 ".*caldav$")) + (setq caldav-calendars nil) + (mapc + (lambda (x) + (setq caldav-calendars (nconc caldav-calendars (directory-files x 1 ".*calendar$")))) + caldav-folders) + + (setq local-calendars nil) + (setq local-calendars (directory-files "~/Library/Calendars" 1 ".*calendar$")) + + (setq all-calendars (append caldav-calendars local-calendars)) + + ;; parse each calendar's Info.plist to see if calendar is checked in iCal + (setq all-calendars (delq 'nil (mapcar + (lambda (x) + (omi-checked x)) + all-calendars))) + + ;; for each calendar, concatenate individual events into a single ics file + (with-temp-buffer + (shell-command "sw_vers" (current-buffer)) + (when (re-search-backward "10\\.[5678]" nil t) + (omi-concat-leopard-ics all-calendars))) + + ;; move all caldav ics files to the same place as local ics files + (mapc + (lambda (x) + (mapc + (lambda (y) + (rename-file (concat x "/" y); + (concat "~/Library/Calendars/" y))) + (directory-files x nil ".*ics$"))) + caldav-folders) + + ;; check calendar has contents and import + (setq import-calendars (directory-files "~/Library/Calendars" 1 ".*ics$")) + (mapc + (lambda (x) + (when (/= (nth 7 (file-attributes x 'string)) 0) + (omi-import-ics x))) + import-calendars) + + ;; tidy up intermediate files and buffers + (setq usedCalendarsBuffers (mapcar (function buffer-name) (buffer-list))) + (omi-kill-ics-buffer usedCalendarsBuffers) + (setq usedCalendarsFiles (directory-files "~/Library/Calendars" 1 ".*ics$")) + (omi-delete-ics-file usedCalendarsFiles) + + (org-pop-to-buffer-same-window currentBuffer)) + +(defun omi-concat-leopard-ics (list) + "Leopard stores each iCal.app event in a separate ics file. +Whilst useful for Spotlight indexing, this is less helpful for +icalendar-import-file. omi-concat-leopard-ics concatenates these +individual event files into a single ics file" + (mapc + (lambda (x) + (setq omi-leopard-events (directory-files (concat x "/Events") 1 ".*ics$")) + (with-temp-buffer + (mapc + (lambda (y) + (insert-file-contents (expand-file-name y))) + omi-leopard-events) + (write-region (point-min) (point-max) (concat (expand-file-name x) ".ics")))) + list)) + +(defun omi-import-ics (string) + "Imports an ics file into the Emacs diary. First tidies up the +ics file so that it is suitable for import and selects a sensible +date range so that Emacs calendar view doesn't grind to a halt" + (with-temp-buffer + (insert-file-contents string) + (goto-char (point-min)) + (while + (re-search-forward "^BEGIN:VCALENDAR$" nil t) + (setq startEntry (match-beginning 0)) + (re-search-forward "^END:VCALENDAR$" nil t) + (setq endEntry (match-end 0)) + (save-restriction + (narrow-to-region startEntry endEntry) + (goto-char (point-min)) + (re-search-forward "\\(^DTSTART;.*:\\)\\([0-9][0-9][0-9][0-9]\\)\\([0-9][0-9]\\)" nil t) + (if (or (eq (match-string 2) nil) (eq (match-string 3) nil)) + (progn + (setq yearEntry 1) + (setq monthEntry 1)) + (setq yearEntry (string-to-number (match-string 2))) + (setq monthEntry (string-to-number (match-string 3)))) + (setq year (string-to-number (format-time-string "%Y"))) + (setq month (string-to-number (format-time-string "%m"))) + (setq now (list month 1 year)) + (setq entryDate (list monthEntry 1 yearEntry)) + ;; Check to see if this is a repeating event + (goto-char (point-min)) + (setq isRepeating (re-search-forward "^RRULE:" nil t)) + ;; Delete if outside range and not repeating + (when (and + (not isRepeating) + (> (abs (- (calendar-absolute-from-gregorian now) + (calendar-absolute-from-gregorian entryDate))) + (* (/ org-mac-iCal-range 2) 30)) + (delete-region startEntry endEntry))) + (goto-char (point-max)))) + (while + (re-search-forward "^END:VEVENT$" nil t) + (delete-blank-lines)) + (goto-line 1) + (insert "BEGIN:VCALENDAR\n\n") + (goto-line 2) + (while + (re-search-forward "^BEGIN:VCALENDAR$" nil t) + (replace-match "\n")) + (goto-line 2) + (while + (re-search-forward "^END:VCALENDAR$" nil t) + (replace-match "\n")) + (insert "END:VCALENDAR") + (goto-line 1) + (delete-blank-lines) + (while + (re-search-forward "^END:VEVENT$" nil t) + (delete-blank-lines)) + (goto-line 1) + (while + (re-search-forward "^ORG.*" nil t) + (replace-match "\n")) + (goto-line 1) + (write-region (point-min) (point-max) string)) + + (icalendar-import-file string diary-file)) + +(defun omi-kill-diary-buffer (list) + (mapc + (lambda (x) + (if (string-match "^diary" x) + (kill-buffer x))) + list)) + +(defun omi-kill-ics-buffer (list) + (mapc + (lambda (x) + (if (string-match "ics$" x) + (kill-buffer x))) + list)) + +(defun omi-delete-ics-file (list) + (mapc + (lambda (x) + (delete-file x)) + list)) + +(defun omi-checked (directory) + "Parse Info.plist in iCal.app calendar folder and determine +whether Checked key is 1. If Checked key is not 1, remove +calendar from list of calendars for import" + (let* ((root (xml-parse-file (car (directory-files directory 1 "Info.plist")))) + (plist (car root)) + (dict (car (xml-get-children plist 'dict))) + (keys (cdr (xml-node-children dict))) + (keys (mapcar + (lambda (x) + (cond ((listp x) + x))) + keys)) + (keys (delq 'nil keys))) + (when (equal "1" (car (cddr (lax-plist-get keys '(key nil "Checked"))))) + directory))) + +(provide 'org-mac-iCal) + +;;; org-mac-iCal.el ends here diff --git a/contrib/lisp/org-mac-link.el b/contrib/lisp/org-mac-link.el new file mode 100644 index 0000000..7f4af30 --- /dev/null +++ b/contrib/lisp/org-mac-link.el @@ -0,0 +1,947 @@ +;;; org-mac-link.el --- Insert org-mode links to items selected in various Mac apps +;; +;; Copyright (c) 2010-2017 Free Software Foundation, Inc. +;; +;; Author: Anthony Lander <anthony.lander@gmail.com> +;; John Wiegley <johnw@gnu.org> +;; Christopher Suckling <suckling at gmail dot com> +;; Daniil Frumin <difrumin@gmail.com> +;; Alan Schmitt <alan.schmitt@polytechnique.org> +;; Mike McLean <mike.mclean@pobox.com> +;; +;; +;; Version: 1.1 +;; Keywords: org, mac, hyperlink +;; +;; Version: 1.2 +;; Keywords: outlook +;; Author: Mike McLean <mike.mclean@pobox.com> +;; Add support for Microsoft Outlook for Mac as Org mode links +;; +;; Version: 1.3 +;; Author: Alan Schmitt <alan.schmitt@polytechnique.org> +;; Consistently use `org-mac-paste-applescript-links' +;; +;; Version 1.4 +;; Author: Mike McLean <mike.mclean@pobox.com> +;; Make the path to Microsoft Outlook a `defcustom' +;; +;; Version 1.5 +;; Author: Mike McLean <mike.mclean@pobox.com> +;; Add Support for Evernote +;; +;; This file is not part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;; +;;; Commentary: +;; +;; This code allows you to grab either the current selected items, or +;; the frontmost url in various mac appliations, and insert them as +;; hyperlinks into the current org-mode document at point. +;; +;; This code is heavily based on, and indeed incorporates, +;; org-mac-message.el written by John Wiegley and Christopher +;; Suckling. +;; +;; Detailed comments for each application interface are inlined with +;; the code. Here is a brief overview of how the code interacts with +;; each application: +;; +;; Finder.app - grab links to the selected files in the frontmost window +;; Mail.app - grab links to the selected messages in the message list +;; AddressBook.app - Grab links to the selected addressbook Cards +;; Firefox.app - Grab the url of the frontmost tab in the frontmost window +;; Vimperator/Firefox.app - Grab the url of the frontmost tab in the frontmost window +;; Safari.app - Grab the url of the frontmost tab in the frontmost window +;; Google Chrome.app - Grab the url of the frontmost tab in the frontmost window +;; Together.app - Grab links to the selected items in the library list +;; Skim.app - Grab a link to the selected page in the topmost pdf document +;; Microsoft Outlook.app - Grab a link to the selected message in the message list +;; DEVONthink Pro Office.app - Grab a link to the selected DEVONthink item(s); open DEVONthink item by reference +;; Evernote.app - Grab a link to the selected Evernote item(s); open Evernote item by ID +;; +;; +;; Installation: +;; +;; add (require 'org-mac-link) to your .emacs, and optionally bind a +;; key to activate the link grabber menu, like this: +;; +;; (add-hook 'org-mode-hook (lambda () +;; (define-key org-mode-map (kbd "C-c g") 'org-mac-grab-link))) +;; +;; Usage: +;; +;; Type C-c g (or whatever key you defined, as above), or type M-x +;; org-mac-grab-link RET to activate the link grabber. This will present +;; you with a menu to choose an application from which to grab a link +;; to insert at point. You may also type C-g to abort. +;; +;; Customizing: +;; +;; You may customize which applications appear in the grab menu by +;; customizing the group `org-mac-link'. Changes take effect +;; immediately. +;; +;; +;;; Code: + +(require 'org) + +(defgroup org-mac-link nil + "Options for grabbing links from Mac applications." + :tag "Org Mac link" + :group 'org-link) + +(defcustom org-mac-grab-Finder-app-p t + "Add menu option [F]inder to grab links from the Finder." + :tag "Grab Finder.app links" + :group 'org-mac-link + :type 'boolean) + +(defcustom org-mac-grab-Mail-app-p t + "Add menu option [m]ail to grab links from Mail.app." + :tag "Grab Mail.app links" + :group 'org-mac-link + :type 'boolean) + +(defcustom org-mac-grab-Outlook-app-p t + "Add menu option [o]utlook to grab links from Microsoft Outlook.app." + :tag "Grab Microsoft Outlook.app links" + :group 'org-mac-link + :type 'boolean) + +(defcustom org-mac-outlook-path "/Applications/Microsoft Outlook.app" + "The path to the installed copy of Microsoft Outlook.app. Do not escape spaces as the AppleScript call will quote this string." + :tag "Path to Microsoft Outlook" + :group 'org-mac-link + :type 'string) + +(defcustom org-mac-grab-devonthink-app-p t + "Add menu option [d]EVONthink to grab links from DEVONthink Pro Office.app." + :tag "Grab DEVONthink Pro Office.app links" + :group 'org-mac-link + :type 'boolean) + +(defcustom org-mac-grab-Addressbook-app-p t + "Add menu option [a]ddressbook to grab links from AddressBook.app." + :tag "Grab AddressBook.app links" + :group 'org-mac-link + :type 'boolean) + +(defcustom org-mac-grab-Safari-app-p t + "Add menu option [s]afari to grab links from Safari.app." + :tag "Grab Safari.app links" + :group 'org-mac-link + :type 'boolean) + +(defcustom org-mac-grab-Firefox-app-p t + "Add menu option [f]irefox to grab links from Firefox.app." + :tag "Grab Firefox.app links" + :group 'org-mac-link + :type 'boolean) + +(defcustom org-mac-grab-Firefox+Vimperator-p nil + "Add menu option [v]imperator to grab links from Firefox.app running the Vimperator plugin." + :tag "Grab Vimperator/Firefox.app links" + :group 'org-mac-link + :type 'boolean) + +(defcustom org-mac-grab-Chrome-app-p t + "Add menu option [c]hrome to grab links from Google Chrome.app." + :tag "Grab Google Chrome.app links" + :group 'org-mac-link + :type 'boolean) + +(defcustom org-mac-grab-Together-app-p nil + "Add menu option [t]ogether to grab links from Together.app." + :tag "Grab Together.app links" + :group 'org-mac-link + :type 'boolean) + +(defcustom org-mac-grab-Skim-app-p + (< 0 (length (shell-command-to-string + "mdfind kMDItemCFBundleIdentifier == 'net.sourceforge.skim-app.skim'"))) + "Add menu option [S]kim to grab page links from Skim.app." + :tag "Grab Skim.app page links" + :group 'org-mac-link + :type 'boolean) + +(defcustom org-mac-Skim-highlight-selection-p nil + "Highlight the active selection when grabbing a link from Skim.app." + :tag "Highlight selection in Skim.app" + :group 'org-mac-link + :type 'boolean) + +(defcustom org-mac-grab-Acrobat-app-p t + "Add menu option [A]crobat to grab page links from Acrobat.app." + :tag "Grab Acrobat.app page links" + :group 'org-mac-link + :type 'boolean) + +(defgroup org-mac-flagged-mail nil + "Options foring linking to flagged Mail.app messages." + :tag "Org Mail.app" + :group 'org-link) + +(defcustom org-mac-mail-account nil + "The Mail.app account in which to search for flagged messages." + :group 'org-mac-flagged-mail + :type 'string) + +(defcustom org-mac-grab-Evernote-app-p + (< 0 (length (shell-command-to-string + "mdfind kMDItemCFBundleIdentifier == 'com.evernote.Evernote'"))) + "Add menu option [e]vernote to grab note links from Evernote.app." + :tag "Grab Evernote.app note links" + :group 'org-mac-link + :type 'boolean) + +(defcustom org-mac-evernote-path (replace-regexp-in-string (rx (* (any " \t\n")) eos) + "" + (shell-command-to-string + "mdfind kMDItemCFBundleIdentifier == 'com.evernote.Evernote'")) + "The path to the installed copy of Evernote.app. Do not escape spaces as the AppleScript call will quote this string." + :tag "Path to Evernote" + :group 'org-mac-link + :type 'string) + + +;; In mac.c, removed in Emacs 23. +(declare-function do-applescript "org-mac-message" (script)) +(unless (fboundp 'do-applescript) + ;; Need to fake this using shell-command-to-string + (defun do-applescript (script) + (let (start cmd return) + (while (string-match "\n" script) + (setq script (replace-match "\r" t t script))) + (while (string-match "'" script start) + (setq start (+ 2 (match-beginning 0)) + script (replace-match "\\'" t t script))) + (setq cmd (concat "osascript -e '" script "'")) + (setq return (shell-command-to-string cmd)) + (concat "\"" (org-trim return) "\"")))) + +(defun org-mac-grab-link () + "Prompt for an application to grab a link from. +When done, go grab the link, and insert it at point." + (interactive) + (let* ((descriptors + `(("F" "inder" org-mac-finder-insert-selected ,org-mac-grab-Finder-app-p) + ("m" "ail" org-mac-message-insert-selected ,org-mac-grab-Mail-app-p) + ("d" "EVONthink Pro Office" org-mac-devonthink-item-insert-selected + ,org-mac-grab-devonthink-app-p) + ("o" "utlook" org-mac-outlook-message-insert-selected ,org-mac-grab-Outlook-app-p) + ("a" "ddressbook" org-mac-addressbook-insert-selected ,org-mac-grab-Addressbook-app-p) + ("s" "afari" org-mac-safari-insert-frontmost-url ,org-mac-grab-Safari-app-p) + ("f" "irefox" org-mac-firefox-insert-frontmost-url ,org-mac-grab-Firefox-app-p) + ("v" "imperator" org-mac-vimperator-insert-frontmost-url ,org-mac-grab-Firefox+Vimperator-p) + ("c" "hrome" org-mac-chrome-insert-frontmost-url ,org-mac-grab-Chrome-app-p) + ("e" "evernote" org-mac-evernote-note-insert-selected ,org-mac-grab-Evernote-app-p) + ("t" "ogether" org-mac-together-insert-selected ,org-mac-grab-Together-app-p) + ("S" "kim" org-mac-skim-insert-page ,org-mac-grab-Skim-app-p) + ("A" "crobat" org-mac-acrobat-insert-page ,org-mac-grab-Acrobat-app-p))) + (menu-string (make-string 0 ?x)) + input) + + ;; Create the menu string for the keymap + (mapc (lambda (descriptor) + (when (elt descriptor 3) + (setf menu-string (concat menu-string + "[" (elt descriptor 0) "]" + (elt descriptor 1) " ")))) + descriptors) + (setf (elt menu-string (- (length menu-string) 1)) ?:) + + ;; Prompt the user, and grab the link + (message menu-string) + (setq input (read-char-exclusive)) + (mapc (lambda (descriptor) + (let ((key (elt (elt descriptor 0) 0)) + (active (elt descriptor 3)) + (grab-function (elt descriptor 2))) + (when (and active (eq input key)) + (call-interactively grab-function)))) + descriptors))) + +(defun org-mac-paste-applescript-links (as-link-list) + "Paste in a list of links from an applescript handler. +The links are of the form <link>::split::<name>." + (let* ((noquote-as-link-list + (if (string-prefix-p "\"" as-link-list) + (substring as-link-list 1 -1) + as-link-list)) + (link-list + (mapcar (lambda (x) (if (string-match "\\`\"\\(.*\\)\"\\'" x) + (setq x (match-string 1 x))) + x) + (split-string noquote-as-link-list "[\r\n]+"))) + split-link URL description orglink orglink-insert rtn orglink-list) + (while link-list + (setq split-link (split-string (pop link-list) "::split::")) + (setq URL (car split-link)) + (setq description (cadr split-link)) + (when (not (string= URL "")) + (setq orglink (org-make-link-string URL description)) + (push orglink orglink-list))) + (setq rtn (mapconcat 'identity orglink-list "\n")) + (kill-new rtn) + rtn)) + + +;; Handle links from Firefox.app +;; +;; This code allows you to grab the current active url from the main +;; Firefox.app window, and insert it as a link into an org-mode +;; document. Unfortunately, firefox does not expose an applescript +;; dictionary, so this is necessarily introduces some limitations. +;; +;; The applescript to grab the url from Firefox.app uses the System +;; Events application to give focus to the firefox application, select +;; the contents of the url bar, and copy it. It then uses the title of +;; the window as the text of the link. There is no way to grab links +;; from other open tabs, and further, if there is more than one window +;; open, it is not clear which one will be used (though emperically it +;; seems that it is always the last active window). + +(defun org-as-mac-firefox-get-frontmost-url () + (let ((result + (do-applescript + (concat + "set oldClipboard to the clipboard\n" + "set frontmostApplication to path to frontmost application\n" + "tell application \"Firefox\"\n" + " activate\n" + " delay 0.15\n" + " tell application \"System Events\"\n" + " keystroke \"l\" using {command down}\n" + " keystroke \"a\" using {command down}\n" + " keystroke \"c\" using {command down}\n" + " end tell\n" + " delay 0.15\n" + " set theUrl to the clipboard\n" + " set the clipboard to oldClipboard\n" + " set theResult to (get theUrl) & \"::split::\" & (get name of window 1)\n" + "end tell\n" + "activate application (frontmostApplication as text)\n" + "set links to {}\n" + "copy theResult to the end of links\n" + "return links as string\n")))) + (car (split-string result "[\r\n]+" t)))) + +(defun org-mac-firefox-get-frontmost-url () + (interactive) + (message "Applescript: Getting Firefox url...") + (org-mac-paste-applescript-links (org-as-mac-firefox-get-frontmost-url))) + +(defun org-mac-firefox-insert-frontmost-url () + (interactive) + (insert (org-mac-firefox-get-frontmost-url))) + + +;; Handle links from Google Firefox.app running the Vimperator extension +;; Grab the frontmost url from Firefox+Vimperator. Same limitations are +;; Firefox + +(defun org-as-mac-vimperator-get-frontmost-url () + (let ((result + (do-applescript + (concat + "set oldClipboard to the clipboard\n" + "set frontmostApplication to path to frontmost application\n" + "tell application \"Firefox\"\n" + " activate\n" + " delay 0.15\n" + " tell application \"System Events\"\n" + " keystroke \"y\"\n" + " end tell\n" + " delay 0.15\n" + " set theUrl to the clipboard\n" + " set the clipboard to oldClipboard\n" + " set theResult to (get theUrl) & \"::split::\" & (get name of window 1)\n" + "end tell\n" + "activate application (frontmostApplication as text)\n" + "set links to {}\n" + "copy theResult to the end of links\n" + "return links as string\n")))) + (replace-regexp-in-string + "\s+-\s+Vimperator" "" (car (split-string result "[\r\n]+" t))))) + +(defun org-mac-vimperator-get-frontmost-url () + (interactive) + (message "Applescript: Getting Vimperator url...") + (org-mac-paste-applescript-links (org-as-mac-vimperator-get-frontmost-url))) + +(defun org-mac-vimperator-insert-frontmost-url () + (interactive) + (insert (org-mac-vimperator-get-frontmost-url))) + + +;; Handle links from Google Chrome.app +;; Grab the frontmost url from Google Chrome. Same limitations as +;; Firefox because Chrome doesn't publish an Applescript dictionary + +(defun org-as-mac-chrome-get-frontmost-url () + (let ((result + (do-applescript + (concat + "set frontmostApplication to path to frontmost application\n" + "tell application \"Google Chrome\"\n" + " set theUrl to get URL of active tab of first window\n" + " set theResult to (get theUrl) & \"::split::\" & (get name of window 1)\n" + "end tell\n" + "activate application (frontmostApplication as text)\n" + "set links to {}\n" + "copy theResult to the end of links\n" + "return links as string\n")))) + (replace-regexp-in-string + "^\"\\|\"$" "" (car (split-string result "[\r\n]+" t))))) + +(defun org-mac-chrome-get-frontmost-url () + (interactive) + (message "Applescript: Getting Chrome url...") + (org-mac-paste-applescript-links (org-as-mac-chrome-get-frontmost-url))) + +(defun org-mac-chrome-insert-frontmost-url () + (interactive) + (insert (org-mac-chrome-get-frontmost-url))) + + +;; Handle links from Safari.app +;; Grab the frontmost url from Safari. + +(defun org-as-mac-safari-get-frontmost-url () + (do-applescript + (concat + "tell application \"Safari\"\n" + " set theUrl to URL of document 1\n" + " set theName to the name of the document 1\n" + " return theUrl & \"::split::\" & theName & \"\n\"\n" + "end tell\n"))) + +(defun org-mac-safari-get-frontmost-url () + (interactive) + (message "Applescript: Getting Safari url...") + (org-mac-paste-applescript-links + (org-as-mac-safari-get-frontmost-url))) + +(defun org-mac-safari-insert-frontmost-url () + (interactive) + (insert (org-mac-safari-get-frontmost-url))) + + +;; Handle links from together.app +(org-link-set-parameters "x-together-item" :follow #'org-mac-together-item-open) + +(defun org-mac-together-item-open (uid) + "Open UID, which is a reference to an item in Together." + (shell-command (concat "open -a Together \"x-together-item:" uid "\""))) + +(defun as-get-selected-together-items () + (do-applescript + (concat + "tell application \"Together\"\n" + " set theLinkList to {}\n" + " set theSelection to selected items\n" + " repeat with theItem in theSelection\n" + " set theLink to (get item link of theItem) & \"::split::\" & (get name of theItem) & \"\n\"\n" + " copy theLink to end of theLinkList\n" + " end repeat\n" + " return theLinkList as string\n" + "end tell"))) + +(defun org-mac-together-get-selected () + (interactive) + (message "Applescript: Getting Togther items...") + (org-mac-paste-applescript-links (as-get-selected-together-items))) + +(defun org-mac-together-insert-selected () + (interactive) + (insert (org-mac-together-get-selected))) + + +;; Handle links from Finder.app + +(defun as-get-selected-finder-items () + (do-applescript + (concat + "tell application \"Finder\"\n" + " set theSelection to the selection\n" + " set links to {}\n" + " repeat with theItem in theSelection\n" + " set theLink to \"file://\" & (POSIX path of (theItem as string)) & \"::split::\" & (get the name of theItem) & \"\n\"\n" + " copy theLink to the end of links\n" + " end repeat\n" + " return links as string\n" + "end tell\n"))) + +(defun org-mac-finder-item-get-selected () + (interactive) + (message "Applescript: Getting Finder items...") + (org-mac-paste-applescript-links (as-get-selected-finder-items))) + +(defun org-mac-finder-insert-selected () + (interactive) + (insert (org-mac-finder-item-get-selected))) + + +;; Handle links from AddressBook.app +(org-link-set-parameters "addressbook" :follow #'org-mac-addressbook-item-open) + +(defun org-mac-addressbook-item-open (uid) + "Open UID, which is a reference to an item in the addressbook." + (shell-command (concat "open \"addressbook:" uid "\""))) + +(defun as-get-selected-addressbook-items () + (do-applescript + (concat + "tell application \"Address Book\"\n" + " set theSelection to the selection\n" + " set links to {}\n" + " repeat with theItem in theSelection\n" + " set theLink to \"addressbook://\" & (the id of theItem) & \"::split::\" & (the name of theItem) & \"\n\"\n" + " copy theLink to the end of links\n" + " end repeat\n" + " return links as string\n" + "end tell\n"))) + +(defun org-mac-addressbook-item-get-selected () + (interactive) + (message "Applescript: Getting Address Book items...") + (org-mac-paste-applescript-links (as-get-selected-addressbook-items))) + +(defun org-mac-addressbook-insert-selected () + (interactive) + (insert (org-mac-addressbook-item-get-selected))) + + +;; Handle links from Skim.app +;; +;; Original code & idea by Christopher Suckling (org-mac-protocol) + +(org-link-set-parameters "skim" :follow #'org-mac-skim-open) + +(defun org-mac-skim-open (uri) + "Visit page of pdf in Skim" + (let* ((page (when (string-match "::\\(.+\\)\\'" uri) + (match-string 1 uri))) + (document (substring uri 0 (match-beginning 0)))) + (do-applescript + (concat + "tell application \"Skim\"\n" + "activate\n" + "set theDoc to \"" document "\"\n" + "set thePage to " page "\n" + "open theDoc\n" + "go document 1 to page thePage of document 1\n" + "end tell")))) + +(defun as-get-skim-page-link () + (do-applescript + (concat + "tell application \"Skim\"\n" + "set theDoc to front document\n" + "set theTitle to (name of theDoc)\n" + "set thePath to (path of theDoc)\n" + "set thePage to (get index for current page of theDoc)\n" + "set theSelection to selection of theDoc\n" + "set theContent to contents of (get text for theSelection)\n" + "if theContent is missing value then\n" + " set theContent to theTitle & \", p. \" & thePage\n" + (when org-mac-Skim-highlight-selection-p + (concat + "else\n" + " tell theDoc\n" + " set theNote to make note with properties {type:highlight note, selection:theSelection}\n" + " set text of theNote to (get text for theSelection)\n" + " end tell\n")) + "end if\n" + "set theLink to \"skim://\" & thePath & \"::\" & thePage & " + "\"::split::\" & theContent\n" + "end tell\n" + "return theLink as string\n"))) + +(defun org-mac-skim-get-page () + (interactive) + (message "Applescript: Getting Skim page link...") + (org-mac-paste-applescript-links (as-get-skim-page-link))) + +(defun org-mac-skim-insert-page () + (interactive) + (insert (org-mac-skim-get-page))) + +;; Handle links from Adobe Acrobat Pro.app +;; +;; Original code & idea by Christopher Suckling (org-mac-protocol) +;; +;; The URI format is path_to_pdf_file::page_number + +(org-link-set-parameters "acrobat" :follow #'org-mac-acrobat-open) + +(defun org-mac-acrobat-open (uri) + "Visit page of pdf in Acrobat" + (let* ((page (when (string-match "::\\(.+\\)\\'" uri) + (match-string 1 uri))) + (document (substring uri 0 (match-beginning 0)))) + (do-applescript + (concat + "tell application \"Adobe Acrobat Pro\"\n" + " activate\n" + " set theDoc to \"" document "\"\n" + " set thePage to " page "\n" + " open theDoc\n" + " tell PDF Window 1\n" + " goto page thePage\n" + " end tell\n" + "end tell")))) + +;; The applescript returns link in the format +;; "adobe:path_to_pdf_file::page_number::split::document_title, p.page_label" + +(defun org-mac-as-get-acrobat-page-link () + (do-applescript + (concat + "tell application \"Adobe Acrobat Pro\"\n" + " set theDoc to active doc\n" + " set theWindow to (PDF Window 1 of theDoc)\n" + " set thePath to (file alias of theDoc)\n" + " set theTitle to (name of theWindow)\n" + " set thePage to (page number of theWindow)\n" + " set theLabel to (label text of (page thePage of theWindow))\n" + "end tell\n" + "set theResult to \"acrobat:\" & thePath & \"::\" & thePage & \"::split::\" & theTitle & \", p.\" & theLabel\n" + "return theResult as string\n"))) + +(defun org-mac-acrobat-get-page () + (interactive) + (message "Applescript: Getting Acrobat page link...") + (org-mac-paste-applescript-links (org-mac-as-get-acrobat-page-link))) + +(defun org-mac-acrobat-insert-page () + (interactive) + (insert (org-mac-acrobat-get-page))) + + +;; Handle links from Microsoft Outlook.app + +(org-link-set-parameters "mac-outlook" :follow #'org-mac-outlook-message-open) + +(defun org-mac-outlook-message-open (msgid) + "Open a message in Outlook" + (do-applescript + (concat + "tell application \"" org-mac-outlook-path "\"\n" + (format "open message id %s\n" (substring-no-properties msgid)) + "activate\n" + "end tell"))) + +(defun org-as-get-selected-outlook-mail () + "AppleScript to create links to selected messages in Microsoft Outlook.app." + (do-applescript + (concat + "tell application \"" org-mac-outlook-path "\"\n" + "set msgCount to count current messages\n" + "if (msgCount < 1) then\n" + "return\n" + "end if\n" + "set theLinkList to {}\n" + "set theSelection to (get current messages)\n" + "repeat with theMessage in theSelection\n" + "set theID to id of theMessage as string\n" + "set theURL to \"mac-outlook:\" & theID\n" + "set theSubject to subject of theMessage\n" + "set theLink to theURL & \"::split::\" & theSubject & \"\n\"\n" + "copy theLink to end of theLinkList\n" + "end repeat\n" + "return theLinkList as string\n" + "end tell"))) + +(defun org-sh-get-flagged-outlook-mail () + "Shell commands to create links to flagged messages in Microsoft Outlook.app." + (mapconcat + (lambda (x) "" + (concat + "mac-outlook:" + (mapconcat + (lambda (y) "" y) + (split-string + (shell-command-to-string + (format "mdls -raw -name com_microsoft_outlook_recordID -name kMDItemDisplayName \"%s\"" x)) + "\000") + "::split::") + "\n")) + (with-temp-buffer + (let ((coding-system-for-read (or file-name-coding-system 'utf-8)) + (coding-system-for-write 'utf-8)) + (shell-command + "mdfind com_microsoft_outlook_flagged==1" + (current-buffer))) + (split-string + (buffer-string) "\n" t)) + "")) + +(defun org-mac-outlook-message-get-links (&optional select-or-flag) + "Create links to the messages currently selected or flagged in Microsoft Outlook.app. +This will use AppleScript to get the message-id and the subject of the +messages in Microsoft Outlook.app and make a link out of it. +When SELECT-OR-FLAG is \"s\", get the selected messages (this is also +the default). When SELECT-OR-FLAG is \"f\", get the flagged messages. +The Org-syntax text will be pushed to the kill ring, and also returned." + (interactive "sLink to (s)elected or (f)lagged messages: ") + (setq select-or-flag (or select-or-flag "s")) + (message "Org Mac Outlook: searching mailboxes...") + (org-mac-paste-applescript-links + (if (string= select-or-flag "s") + (org-as-get-selected-outlook-mail) + (if (string= select-or-flag "f") + (org-sh-get-flagged-outlook-mail) + (error "Please select \"s\" or \"f\""))))) + +(defun org-mac-outlook-message-insert-selected () + "Insert a link to the messages currently selected in Microsoft Outlook.app. +This will use AppleScript to get the message-id and the subject +of the active mail in Microsoft Outlook.app and make a link out +of it." + (interactive) + (insert (org-mac-outlook-message-get-links "s"))) + +(defun org-mac-outlook-message-insert-flagged (org-buffer org-heading) + "Asks for an org buffer and a heading within it, and replace message links. +If heading exists, delete all mac-outlook:// links within +heading's first level. If heading doesn't exist, create it at +point-max. Insert list of mac-outlook:// links to flagged mail +after heading." + (interactive "bBuffer in which to insert links: \nsHeading after which to insert links: ") + (with-current-buffer org-buffer + (goto-char (point-min)) + (let ((isearch-forward t) + (message-re "\\[\\[\\(mac-outlook:\\)\\([^]]+\\)\\]\\(\\[\\([^]]+\\)\\]\\)?\\]")) + (if (org-goto-local-search-headings org-heading nil t) + (if (not (eobp)) + (progn + (save-excursion + (while (re-search-forward + message-re (save-excursion (outline-next-heading)) t) + (delete-region (match-beginning 0) (match-end 0))) + (insert "\n" (org-mac-outlook-message-get-links "f"))) + (flush-lines "^$" (point) (outline-next-heading))) + (insert "\n" (org-mac-outlook-message-get-links "f"))) + (goto-char (point-max)) + (insert "\n") + (org-insert-heading nil t) + (insert org-heading "\n" (org-mac-outlook-message-get-links "f")))))) + +;; Handle links from Evernote.app + +(org-link-set-parameters "mac-evernote" :follow #'org-mac-evernote-note-open) + +(defun org-mac-evernote-note-open (noteid) + "Open a note in Evernote" + (do-applescript + (concat + "tell application \"" org-mac-evernote-path "\"\n" + " set theNotes to get every note of every notebook where its local id is \"" (substring-no-properties noteid) "\"\n" + " repeat with _note in theNotes\n" + " if length of _note is not 0 then\n" + " set _selectedNote to _note\n" + " end if\n" + " end repeat\n" + " open note window with item 1 of _selectedNote\n" + " activate\n" + "end tell"))) + +(defun org-as-get-selected-evernote-notes () + "AppleScript to create links to selected notes in Evernote.app." + (do-applescript + (concat + "tell application \"" org-mac-evernote-path "\"\n" + " set noteCount to count selection\n" + " if (noteCount < 1) then\n" + " return\n" + " end if\n" + " set theLinkList to {}\n" + " set theSelection to selection\n" + " repeat with theNote in theSelection\n" + " set theTitle to title of theNote\n" + " set theID to local id of theNote\n" + " set theURL to \"mac-evernote:\" & theID\n" + " set theLink to theURL & \"::split::\" & theTitle & \"\n\"\n" + " copy theLink to end of theLinkList\n" + " end repeat\n" + " return theLinkList as string\n" + "end tell\n"))) + +(defun org-mac-evernote-note-insert-selected () + "Insert a link to the notes currently selected in Evernote.app. +This will use AppleScript to get the note id and the title of the +note(s) in Evernote.app and make a link out of it/them." + (interactive) + (message "Org Mac Evernote: searching notes...") +(insert (org-mac-paste-applescript-links + (org-as-get-selected-evernote-notes)))) + + +;; Handle links from DEVONthink Pro Office.app + +(org-link-set-parameters "x-devonthink-item" :follow #'org-devonthink-item-open) + +(defun org-devonthink-item-open (uid) + "Open UID, which is a reference to an item in DEVONthink Pro Office." + (shell-command (concat "open \"x-devonthink-item:" uid "\""))) + +(defun org-as-get-selected-devonthink-item () + "AppleScript to create links to selected items in DEVONthink Pro Office.app." + (do-applescript + (concat + "set theLinkList to {}\n" + "tell application \"DEVONthink Pro\"\n" + "set selectedRecords to selection\n" + "set selectionCount to count of selectedRecords\n" + "if (selectionCount < 1) then\n" + "return\n" + "end if\n" + "repeat with theRecord in selectedRecords\n" + "set theID to uuid of theRecord\n" + "set theURL to \"x-devonthink-item:\" & theID\n" + "set theSubject to name of theRecord\n" + "set theLink to theURL & \"::split::\" & theSubject & \"\n\"\n" + "copy theLink to end of theLinkList\n" + "end repeat\n" + "end tell\n" + "return theLinkList as string" + ))) + +(defun org-mac-devonthink-get-links () + "Create links to the item(s) currently selected in DEVONthink Pro Office. +This will use AppleScript to get the `uuid' and the `name' of the +selected items in DEVONthink Pro Office.app and make links out of +it/them. This function will push the Org-syntax text to the kill +ring, and also return it." + (message "Org Mac DEVONthink: looking for selected items...") + (org-mac-paste-applescript-links (org-as-get-selected-devonthink-item))) + +(defun org-mac-devonthink-item-insert-selected () + "Insert a link to the item(s) currently selected in DEVONthink Pro Office. +This will use AppleScript to get the `uuid'(s) and the name(s) of the +selected items in DEVONthink Pro Office and make link(s) out of it/them." + (interactive) + (insert (org-mac-devonthink-get-links))) + + +;; Handle links from Mail.app + +(org-link-set-parameters "message" :follow #'org-mac-message-open) + +(defun org-mac-message-open (message-id) + "Visit the message with MESSAGE-ID. +This will use the command `open' with the message URL." + (start-process (concat "open message:" message-id) nil + "open" (concat "message://<" (substring message-id 2) ">"))) + +(defun org-as-get-selected-mail () + "AppleScript to create links to selected messages in Mail.app." + (do-applescript + (concat + "tell application \"Mail\"\n" + "set theLinkList to {}\n" + "set theSelection to selection\n" + "repeat with theMessage in theSelection\n" + "set theID to message id of theMessage\n" + "set theSubject to subject of theMessage\n" + "set theLink to \"message://\" & theID & \"::split::\" & theSubject\n" + "if (theLinkList is not equal to {}) then\n" + "set theLink to \"\n\" & theLink\n" + "end if\n" + "copy theLink to end of theLinkList\n" + "end repeat\n" + "return theLinkList as string\n" + "end tell"))) + +(defun org-as-get-flagged-mail () + "AppleScript to create links to flagged messages in Mail.app." + (unless org-mac-mail-account + (error "You must set org-mac-mail-account")) + (do-applescript + (concat + ;; Get links + "tell application \"Mail\"\n" + "set theMailboxes to every mailbox of account \"" org-mac-mail-account "\"\n" + "set theLinkList to {}\n" + "repeat with aMailbox in theMailboxes\n" + "set theSelection to (every message in aMailbox whose flagged status = true)\n" + "repeat with theMessage in theSelection\n" + "set theID to message id of theMessage\n" + "set theSubject to subject of theMessage\n" + "set theLink to \"message://\" & theID & \"::split::\" & theSubject & \"\n\"\n" + "copy theLink to end of theLinkList\n" + "end repeat\n" + "end repeat\n" + "return theLinkList as string\n" + "end tell"))) + +(defun org-mac-message-get-links (&optional select-or-flag) + "Create links to the messages currently selected or flagged in Mail.app. +This will use AppleScript to get the message-id and the subject of the +messages in Mail.app and make a link out of it. +When SELECT-OR-FLAG is \"s\", get the selected messages (this is also +the default). When SELECT-OR-FLAG is \"f\", get the flagged messages. +The Org-syntax text will be pushed to the kill ring, and also returned." + (interactive "sLink to (s)elected or (f)lagged messages: ") + (setq select-or-flag (or select-or-flag "s")) + (message "AppleScript: searching mailboxes...") + (org-mac-paste-applescript-links + (cond + ((string= select-or-flag "s") (org-as-get-selected-mail)) + ((string= select-or-flag "f") (org-as-get-flagged-mail)) + (t (error "Please select \"s\" or \"f\""))))) + +(defun org-mac-message-insert-selected () + "Insert a link to the messages currently selected in Mail.app. +This will use AppleScript to get the message-id and the subject of the +active mail in Mail.app and make a link out of it." + (interactive) + (insert (org-mac-message-get-links "s"))) + +;; The following line is for backward compatibility +(defalias 'org-mac-message-insert-link 'org-mac-message-insert-selected) + +(defun org-mac-message-insert-flagged (org-buffer org-heading) + "Asks for an org buffer and a heading within it, and replace message links. +If heading exists, delete all message:// links within heading's first +level. If heading doesn't exist, create it at point-max. Insert +list of message:// links to flagged mail after heading." + (interactive "bBuffer in which to insert links: \nsHeading after which to insert links: ") + (with-current-buffer org-buffer + (goto-char (point-min)) + (let ((isearch-forward t) + (message-re "\\[\\[\\(message:\\)\\([^]]+\\)\\]\\(\\[\\([^]]+\\)\\]\\)?\\]")) + (if (org-goto-local-search-headings org-heading nil t) + (if (not (eobp)) + (progn + (save-excursion + (while (re-search-forward + message-re (save-excursion (outline-next-heading)) t) + (delete-region (match-beginning 0) (match-end 0))) + (insert "\n" (org-mac-message-get-links "f"))) + (flush-lines "^$" (point) (outline-next-heading))) + (insert "\n" (org-mac-message-get-links "f"))) + (goto-char (point-max)) + (insert "\n") + (org-insert-heading nil t) + (insert org-heading "\n" (org-mac-message-get-links "f")))))) + + +(provide 'org-mac-link) + +;;; org-mac-link.el ends here diff --git a/contrib/lisp/org-mairix.el b/contrib/lisp/org-mairix.el new file mode 100644 index 0000000..84c2dfd --- /dev/null +++ b/contrib/lisp/org-mairix.el @@ -0,0 +1,333 @@ +;;; org-mairix.el - Support for hooking mairix search into Org for different MUAs +;; +;; Copyright (C) 2007-2014 Georg C. F. Greve +;; mutt support by Adam Spiers <orgmode at adamspiers dot org> +;; +;; This file is not part of GNU Emacs. +;; +;; Author: Georg C. F. Greve <greve at fsfeurope dot org> +;; Keywords: outlines, hypermedia, calendar, wp, email, mairix +;; Purpose: Integrate mairix email searching into Org mode +;; See http://orgmode.org and http://www.rpcurnow.force9.co.uk/mairix/ +;; Version: 0.5 +;; +;; This file 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. + +;; It 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/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; USAGE NOTE +;; +;; You will need to configure mairix first, which involves setting up your +;; .mairixrc in your home directory. Once it is working, you should set up +;; your way to display results in your favorite way -- usually a MUA. +;; Currently gnus and mutt are supported. +;; +;; After both steps are done, all you should need to hook mairix, org +;; and your MUA together is to do (require 'org-mairix) in your +;; startup file. Everything can then be configured normally through +;; Emacs customisation. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(require 'org) + +;;; The custom variables + +(defgroup org-mairix nil + "Mairix support/integration in org." + :tag "Org Mairix" + :group 'org) + +(defcustom org-mairix-threaded-links t + "Should new links be created as threaded links? +If t, links will be stored as threaded searches. +If nil, links will be stored as non-threaded searches." + :group 'org-mairix + :type 'boolean) + +(defcustom org-mairix-augmented-links nil + "Should new links be created as augmenting searches? +If t, links will be stored as augmenting searches. +If nil, links will be stored as normal searches. + +Attention: When activating this option, you will need +to remove old articles from your mairix results group +in some other way, mairix will not do it for you." + :group 'org-mairix + :type 'boolean) + +(defcustom org-mairix-display-hook 'org-mairix-gnus-display-results + "Hook to call to display the results of a successful mairix search. +Defaults to Gnus, feel free to add your own MUAs or methods." + :group 'org-mairix + :type 'hook) + +(defcustom org-mairix-open-command "mairix %args% '%search%'" + "The mairix command-line to use. If your paths are set up +correctly, you should not need to change this. + +'%search%' will get substituted with the search expression, and +'%args%' with any additional arguments." + :group 'org-mairix + :type 'string) + +;;; The hooks to integrate mairix into org + +(org-link-set-parameters "mairix" + :follow #'org-mairix-open + :store #'org-mairix-store-gnus-link) + +;;; Generic org-mairix functions + +(defun org-mairix-construct-link (message-id) + "Construct a mairix: hyperlink based on message-id." + (concat "mairix:" + (if org-mairix-threaded-links "t:") + (if org-mairix-augmented-links "a:") + "@@" + (org-unbracket-string "<" ">" message-id))) + +(defun org-store-mairix-link-props (&rest plist) + "Take a property list describing a mail, and add mairix link +and description properties so that org can build a mairix link to +it." + ;; We have to call `org-store-link-props' twice: + ;; + ;; - It extracts 'fromname'/'fromaddress' from 'from' property, + ;; and stores the updated plist to `org-store-link-plist'. + ;; + ;; - `org-email-link-description' uses these new properties to + ;; build a description from the previously stored plist. I + ;; wrote a tiny patch to `org-email-link-description' so it + ;; could take a non-stored plist as an optional 2nd argument, + ;; but the plist provided still needs 'fromname'/'fromaddress'. + ;; + ;; - Ideally we would decouple the storing bit of + ;; `org-store-link-props' from the extraction bit, but lots of + ;; stuff in `org-store-link' which calls it would need to be + ;; changed. Maybe just factor out the extraction so it can be + ;; reused separately? + (let ((mid (plist-get plist :message-id))) + (apply 'org-store-link-props + (append plist + (list :type "mairix" + :link (org-mairix-construct-link mid)))) + (apply 'org-store-link-props + (append org-store-link-plist + (list :description (org-email-link-description)))))) + +(defun org-mairix-message-send-and-exit-with-link () + "Function that can be assigned as an alternative sending function, +it sends the message and then stores a mairix link to it before burying +the buffer just like 'message-send-and-exit' does." + (interactive) + (message-send) + (let* ((message-id (message-fetch-field "Message-Id")) + (subject (message-fetch-field "Subject")) + (link (org-mairix-construct-link message-id)) + (desc (concat "Email: '" subject "'"))) + (setq org-stored-links + (cons (list link desc) org-stored-links))) + (message-bury (current-buffer))) + +(defun org-mairix-open (search) + "Function to open mairix link. + +We first need to split it into its individual parts, and then +extract the message-id to be passed on to the display function +before call mairix, evaluate the number of matches returned, and +make sure to only call display of mairix succeeded in matching." + (let* ((args "")) + (if (equal (substring search 0 2) "t:" ) + (progn (setq search (substring search 2 nil)) + (setq args (concat args " --threads")))) + (if (equal (substring search 0 2) "a:") + (progn (setq search (substring search 2 nil)) + (setq args (concat args " --augment")))) + (let ((cmdline (org-mairix-command-substitution + org-mairix-open-command search args))) + (print cmdline) + (setq retval (shell-command-to-string cmdline)) + (string-match "\[0-9\]+" retval) + (setq matches (string-to-number (match-string 0 retval))) + (if (eq matches 0) (message "Link failed: no matches, sorry") + (message "Link returned %d matches" matches) + (run-hook-with-args 'org-mairix-display-hook search args))))) + +(defun org-mairix-command-substitution (cmd search args) + "Substitute '%search%' and '%args% in mairix search command." + (while (string-match "%search%" cmd) + (setq cmd (replace-match search 'fixedcase 'literal cmd))) + (while (string-match "%args%" cmd) + (setq cmd (replace-match args 'fixedcase 'literal cmd))) + cmd) + +;;; Functions necessary for integration of external MUAs. + +;; Of course we cannot call `org-store-link' from within an external +;; MUA, so we need some other way of storing a link for later +;; retrieval by org-mode and/or remember-mode. To do this we use a +;; temporary file as a kind of dedicated clipboard. + +(defcustom org-mairix-link-clipboard "~/.org-mairix-link" + "Pseudo-clipboard file where mairix URLs get copied to by external +applications in order to mimic `org-store-link'. Used by +`org-mairix-insert-link'." + :group 'org-mairix + :type 'string) + +;; When we resolve some of the issues with `org-store-link' detailed +;; at <http://thread.gmane.org/gmane.emacs.orgmode/4217/focus=4635>, +;; we might not need org-mairix-insert-link. + +(defun org-mairix-insert-link () + "Insert link from file defined by `org-mairix-link-clipboard'." + (interactive) + (let ((bytes (cadr (insert-file-contents + (expand-file-name org-mairix-link-clipboard))))) + (forward-char bytes) + (save-excursion + (forward-char -1) + (if (looking-at "\n") + (delete-char 1))))) + +;;; Functions necessary for mutt integration + +(defgroup org-mairix-mutt nil + "Use mutt for mairix support in org." + :tag "Org Mairix Mutt" + :group 'org-mairix) + +(defcustom org-mairix-mutt-display-command + "xterm -title 'mairix search: %search%' -e 'unset COLUMNS; mutt -f +~/mail/mairix -e \"push <display-message>\"' &" + "Command to execute to display mairix search results via mutt within +an xterm. + +'%search%' will get substituted with the search expression, and +'%args%' with any additional arguments used in the search." + :group 'org-mairix-mutt + :type 'string) + +(defun org-mairix-mutt-display-results (search args) + "Display results of mairix search in mutt, using the command line +defined in `org-mairix-mutt-display-command'." + ;; By default, async `shell-command' invocations display the temp + ;; buffer, which is annoying here. We choose a deterministic + ;; buffer name so we can hide it again immediately. + ;; Note: `call-process' is synchronous so not useful here. + (let ((cmd (org-mairix-command-substitution + org-mairix-mutt-display-command search args)) + (tmpbufname (generate-new-buffer-name " *mairix-view*"))) + (shell-command cmd tmpbufname) + (delete-windows-on (get-buffer tmpbufname)))) + +;;; Functions necessary for gnus integration + +(defgroup org-mairix-gnus nil + "Use gnus for mairix support in org." + :tag "Org Mairix Gnus" + :group 'org-mairix) + +(defcustom org-mairix-gnus-results-group "nnmaildir:mairix" + "The group that is configured to hold the mairix search results, +which needs to be setup independently of the org-mairix integration, +along with general mairix configuration." + :group 'org-mairix-gnus + :type 'string) + +(defcustom org-mairix-gnus-select-display-group-function +'org-mairix-gnus-select-display-group-function-gg + "Hook to call to select the group that contains the matching articles. +We should not need this, it is owed to a problem of gnus that people were +not yet able to figure out, see + http://article.gmane.org/gmane.emacs.gnus.general/65248 + http://article.gmane.org/gmane.emacs.gnus.general/65265 + http://article.gmane.org/gmane.emacs.gnus.user/9596 +for reference. + +It seems gnus needs a 'forget/ignore everything you think you +know about that group' function. Volunteers?" + :group 'org-mairix-gnus + :type 'hook) + +(defun org-mairix-store-gnus-link () + "Store a link to the current gnus message as a Mairix search for its +Message ID." + + ;; gnus integration + (when (memq major-mode '(gnus-summary-mode gnus-article-mode)) + (and (eq major-mode 'gnus-article-mode) (gnus-article-show-summary)) + (let* ((article (gnus-summary-article-number)) + (header (gnus-summary-article-header article)) + (from (mail-header-from header)) + (message-id (mail-header-id header)) + (subject (gnus-summary-subject-string))) + (org-store-mairix-link-props :from from + :subject subject + :message-id message-id)))) + +(defun org-mairix-gnus-display-results (search args) + "Display results of mairix search in Gnus. + +Note: This does not work as cleanly as I would like it to. The +problem being that Gnus should simply reread the group cleanly, +without remembering anything. At the moment it seems to be unable +to do that -- so you're likely to see zombies floating around. + +If you can improve this, please do!" + (if (not (equal (substring search 0 2) "m:" )) + (error "org-mairix-gnus-display-results: display of search other than +message-id not implemented yet")) + (setq message-id (substring search 2 nil)) + (require 'gnus) + (require 'gnus-sum) + ;; FIXME: (bzg/gg) We might need to make sure gnus is running here, + ;; and to start it in case it isn't running already. Does + ;; anyone know a function to do that? It seems main org mode + ;; does not do this, either. + (funcall (cdr (assq 'gnus org-link-frame-setup))) + (if gnus-other-frame-object (select-frame gnus-other-frame-object)) + + ;; FIXME: This is horribly broken. Please see + ;; http://article.gmane.org/gmane.emacs.gnus.general/65248 + ;; http://article.gmane.org/gmane.emacs.gnus.general/65265 + ;; http://article.gmane.org/gmane.emacs.gnus.user/9596 + ;; for reference. + ;; + ;; It seems gnus needs a "forget/ignore everything you think you + ;; know about that group" function. Volunteers? + ;; + ;; For now different methods seem to work differently well for + ;; different people. So we're playing hook-selection here to make + ;; it easy to play around until we found a proper solution. + (run-hook-with-args 'org-mairix-gnus-select-display-group-function) + (gnus-summary-select-article + nil t t (car (gnus-find-matching-articles "message-id" message-id)))) + +(defun org-mairix-gnus-select-display-group-function-gg () + "Georg's hack to select a group that gnus (falsely) believes to be +empty to then call rebuilding of the summary. It leaves zombies of +old searches around, though." + (gnus-group-quick-select-group 0 org-mairix-gnus-results-group) + (gnus-group-clear-data) + (gnus-summary-reselect-current-group t t)) + +(defun org-mairix-gnus-select-display-group-function-bzg () + "This is the classic way the org mode is using, and it seems to be +using better for Bastien, so it may work for you." + (gnus-group-clear-data org-mairix-gnus-results-group) + (gnus-group-read-group t nil org-mairix-gnus-results-group)) + +(provide 'org-mairix) + +;;; org-mairix.el ends here diff --git a/contrib/lisp/org-man.el b/contrib/lisp/org-man.el new file mode 100644 index 0000000..1ccd942 --- /dev/null +++ b/contrib/lisp/org-man.el @@ -0,0 +1,75 @@ +;;; org-man.el - Support for links to manpages in Org-mode +;; +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 1.0 +;; +;; This file is not yet part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +(require 'org) + +(org-link-set-parameters "man" + :follow #'org-man-open + :export #'org-man-export + :store #'org-man-store-link) + +(defcustom org-man-command 'man + "The Emacs command to be used to display a man page." + :group 'org-link + :type '(choice (const man) (const woman))) + +(defun org-man-open (path) + "Visit the manpage on PATH. +PATH should be a topic that can be thrown at the man command." + (funcall org-man-command path)) + +(defun org-man-store-link () + "Store a link to a README file." + (when (memq major-mode '(Man-mode woman-mode)) + ;; This is a man page, we do make this link + (let* ((page (org-man-get-page-name)) + (link (concat "man:" page)) + (description (format "Manpage for %s" page))) + (org-store-link-props + :type "man" + :link link + :description description)))) + +(defun org-man-get-page-name () + "Extract the page name from the buffer name." + ;; This works for both `Man-mode' and `woman-mode'. + (if (string-match " \\(\\S-+\\)\\*" (buffer-name)) + (match-string 1 (buffer-name)) + (error "Cannot create link to this man page"))) + +(defun org-man-export (link description format) + "Export a man page link from Org files." + (let ((path (format "http://man.he.net/?topic=%s§ion=all" link)) + (desc (or description link))) + (cond + ((eq format 'html) (format "<a target=\"_blank\" href=\"%s\">%s</a>" path desc)) + ((eq format 'latex) (format "\\href{%s}{%s}" path desc)) + ((eq format 'texinfo) (format "@uref{%s,%s}" path desc)) + ((eq format 'ascii) (format "%s (%s)" desc path)) + (t path)))) + +(provide 'org-man) + +;;; org-man.el ends here diff --git a/contrib/lisp/org-mew.el b/contrib/lisp/org-mew.el new file mode 100644 index 0000000..6dbc67c --- /dev/null +++ b/contrib/lisp/org-mew.el @@ -0,0 +1,354 @@ +;;; org-mew.el --- Support for links to Mew messages from within Org-mode + +;; Copyright (C) 2008-2017 Free Software Foundation, Inc. + +;; Author: Tokuya Kameshima <kames at fa2 dot so-net dot ne dot jp> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org + +;; This file is not part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file implements links to Mew messages from within Org-mode. +;; Org-mode loads this module by default - if this is not what you want, +;; configure the variable `org-modules'. +;; +;; Here is an example of workflow: + +;; In your ~/.mew.el configuration file: +;; +;; (define-key mew-summary-mode-map "'" 'org-mew-search) +;; (eval-after-load "mew-summary" +;; '(define-key mew-summary-mode-map "\C-o" 'org-mew-capture)) + +;; 1. In the Mew's inbox folder, take a glance at new messages to find +;; a message that requires any action. + +;; 2. If the message is a reply from somebody and associated with the +;; existing orgmode entry, type M-x `org-mew-search' RET (or press +;; the ' key simply) to find the entry. If you can find the entry +;; successfully and think you should start the task right now, +;; start the task by M-x `org-agenda-clock-in' RET. + +;; 3. If the message is a new message, type M-x `org-mew-capture' RET, +;; enter the refile folder, and the buffer to capture the message +;; is shown up (without selecting the template by hand). Then you +;; can fill the template and type C-c C-c to complete the capture. +;; Note that you can configure `org-capture-templates' so that the +;; captured entry has a link to the message. + +;;; Code: + +(require 'org) + +(defgroup org-mew nil + "Options concerning the Mew link." + :tag "Org Startup" + :group 'org-link) + +(defcustom org-mew-link-to-refile-destination t + "Create a link to the refile destination if the message is marked as refile." + :group 'org-mew + :type 'boolean) + +(defcustom org-mew-inbox-folder nil + "The folder where new messages are incorporated. +If `org-mew-inbox-folder' is non-nil, `org-mew-open' locates the message +in this inbox folder as well as the folder specified by the link." + :group 'org-mew + :type 'string) + +(defcustom org-mew-use-id-db t + "Use ID database to locate the message if id.db is created." + :group 'org-mew + :type 'boolean) + +(defcustom org-mew-subject-alist + (list (cons (concat "^\\(?:\\(?:re\\|fwd?\\): *\\)*" + "\\(?:[[(][a-z0-9._-]+[:,]? [0-9]+[])]\\)? *" + "\\(?:\\(?:re\\|fwd?\\): *\\)*" + "\\(.*\\)[ \t]*") + 1)) + "Alist of subject regular expression and matched group number for search." + :group 'org-mew + :type '(repeat (cons (regexp) (integer)))) + +(defcustom org-mew-capture-inbox-folders nil + "List of inbox folders whose messages need refile marked before capture. +`org-mew-capture' will ask you to put the refile mark on the +message if the message's folder is any of these folders and the +message is not marked. Nil means `org-mew-capture' never ask you +destination folders before capture." + :group 'org-mew + :type '(repeat string)) + +(defcustom org-mew-capture-guess-alist nil + "Alist of the regular expression of the folder name and the capture +template selection keys. + +For example, + '((\"^%emacs-orgmode$\" . \"o\") + (\"\" . \"t\")) +the messages in \"%emacs-orgmode\" folder will be captured with +the capture template associated with \"o\" key, and any other +messages will be captured with the capture template associated +with \"t\" key." + :group 'org-mew + :type '(repeat (cons regexp string))) + +;; Declare external functions and variables +(declare-function mew-cache-hit "ext:mew-cache" (fld msg &optional must-hit)) +(declare-function mew-case-folder "ext:mew-func" (case folder)) +(declare-function mew-folder-path-to-folder + "ext:mew-func" (path &optional has-proto)) +(declare-function mew-idstr-to-id-list "ext:mew-header" (idstr &optional rev)) +(declare-function mew-folder-remotep "ext:mew-func" (folder)) +(declare-function mew-folder-virtualp "ext:mew-func" (folder)) +(declare-function mew-header-get-value "ext:mew-header" + (field &optional as-list)) +(declare-function mew-init "ext:mew" ()) +(declare-function mew-refile-get "ext:mew-refile" (msg)) +(declare-function mew-sinfo-get-case "ext:mew-summary" ()) +(declare-function mew-summary-diag-global "ext:mew-thread" (id opt who)) +(declare-function mew-summary-display "ext:mew-summary2" (&optional redisplay)) +(declare-function mew-summary-folder-name "ext:mew-syntax" (&optional ext)) +(declare-function mew-summary-get-mark "ext:mew-mark" ()) +(declare-function mew-summary-message-number2 "ext:mew-syntax" ()) +(declare-function mew-summary-pick-with-mewl "ext:mew-pick" + (pattern folder src-msgs)) +(declare-function mew-summary-refile "ext:mew-refile" (&optional report)) +(declare-function mew-summary-search-msg "ext:mew-const" (msg)) +(declare-function mew-summary-set-message-buffer "ext:mew-summary3" (fld msg)) +(declare-function mew-summary-visit-folder "ext:mew-summary4" + (folder &optional goend no-ls)) +(declare-function mew-window-push "ext:mew" ()) +(declare-function mew-expand-folder "ext:mew-func" (folder)) +(declare-function mew-case:folder-folder "ext:mew-func" (case:folder)) +(declare-function mew "ext:mew" (&optional arg)) +(declare-function mew-message-goto-summary "ext:mew-message" ()) +(declare-function mew-summary-mode "ext:mew-summary" ()) + +(defvar mew-init-p) +(defvar mew-mark-afterstep-spec) +(defvar mew-summary-goto-line-then-display) + +;; Install the link type +(org-link-set-parameters "mew" :follow #'org-mew-open :store #'org-mew-store-link) + +;; Implementation +(defun org-mew-store-link () + "Store a link to a Mew folder or message." + (save-window-excursion + (if (eq major-mode 'mew-message-mode) + (mew-message-goto-summary)) + (when (memq major-mode '(mew-summary-mode mew-virtual-mode)) + (let ((msgnum (mew-summary-message-number2)) + (folder-name (org-mew-folder-name))) + (if (fboundp 'mew-summary-set-message-buffer) + (mew-summary-set-message-buffer folder-name msgnum) + (set-buffer (mew-cache-hit folder-name msgnum t))) + (let* ((message-id (mew-header-get-value "Message-Id:")) + (from (mew-header-get-value "From:")) + (to (mew-header-get-value "To:")) + (date (mew-header-get-value "Date:")) + (subject (mew-header-get-value "Subject:")) + desc link) + (org-store-link-props :type "mew" :from from :to to :date date + :subject subject :message-id message-id) + (setq message-id (org-unbracket-string "<" ">" message-id)) + (setq desc (org-email-link-description)) + (setq link (concat "mew:" folder-name "#" message-id)) + (org-add-link-props :link link :description desc) + link))))) + +(defun org-mew-folder-name () + "Return the folder name of the current message." + (save-window-excursion + (if (eq major-mode 'mew-message-mode) + (mew-message-goto-summary)) + (let* ((msgnum (mew-summary-message-number2)) + (mark-info (mew-summary-get-mark))) + (if (and org-mew-link-to-refile-destination + (eq mark-info ?o)) ; marked as refile + (mew-case-folder (mew-sinfo-get-case) + (nth 1 (mew-refile-get msgnum))) + (let ((folder-or-path (mew-summary-folder-name))) + (mew-folder-path-to-folder folder-or-path t)))))) + +(defun org-mew-open (path) + "Follow the Mew message link specified by PATH." + (let (folder message-id) + (cond ((string-match "\\`\\(+.*\\)+\\+\\([0-9]+\\)\\'" path) ; for Bastien's + (setq folder (match-string 1 path)) + (setq message-id (match-string 2 path))) + ((string-match "\\`\\(\\(%#\\)?[^#]+\\)\\(#\\(.*\\)\\)?" path) + (setq folder (match-string 1 path)) + (setq message-id (match-string 4 path))) + ((and org-mew-use-id-db (string-match "\\`#\\(.+\\)" path)) + (setq folder nil) + (setq message-id (match-string 1 path))) + (t (error "Error in Mew link"))) + (require 'mew) + (mew-window-push) + (unless mew-init-p (mew-init)) + (if (null folder) + (progn + (mew t) + (org-mew-open-by-message-id message-id)) + (or (org-mew-follow-link folder message-id) + (and org-mew-inbox-folder (not (string= org-mew-inbox-folder folder)) + (org-mew-follow-link org-mew-inbox-folder message-id)) + (and org-mew-use-id-db + (org-mew-open-by-message-id message-id)) + (error "Message not found"))))) + +(defun org-mew-follow-link (folder message-id) + (unless (org-mew-folder-exists-p folder) + (error "No such folder or wrong folder %s" folder)) + (mew-summary-visit-folder folder) + (when message-id + (let ((msgnum (org-mew-get-msgnum folder message-id))) + (when (mew-summary-search-msg msgnum) + (if mew-summary-goto-line-then-display + (mew-summary-display)) + t)))) + +(defun org-mew-folder-exists-p (folder) + (let ((dir (mew-expand-folder folder))) + (cond + ((mew-folder-virtualp folder) (get-buffer folder)) + ((null dir) nil) + ((mew-folder-remotep (mew-case:folder-folder folder)) t) + (t (file-directory-p dir))))) + +(defun org-mew-get-msgnum (folder message-id) + (if (string-match "\\`[0-9]+\\'" message-id) + message-id + (let* ((pattern (concat "message-id=" message-id)) + (msgs (mew-summary-pick-with-mewl pattern folder nil))) + (car msgs)))) + +(defun org-mew-open-by-message-id (message-id) + "Open message using ID database." + (let ((result (mew-summary-diag-global (format "<%s>" message-id) + "-p" "Message"))) + (unless (eq result t) + (error "Message not found")))) + +;; In ~/.mew.el, add the following line: +;; (define-key mew-summary-mode-map "'" 'org-mew-search) +(defun org-mew-search (&optional arg) + "Show all entries related to the message using `org-search-view'. + +It shows entries which contains the message ID, the reference +IDs, or the subject of the message. + +With C-u prefix, search for the entries that contains the message +ID or any of the reference IDs. With C-u C-u prefix, search for +the message ID or the last reference ID. + +The search phase for the subject is extracted with +`org-mew-subject-alist', which defines the regular expression of +the subject and the group number to extract. You can get rid of +\"Re:\" and some other prefix from the subject text." + (interactive "P") + (when (memq major-mode '(mew-summary-mode mew-virtual-mode)) + (let ((last-reference-only (equal arg '(16))) + (by-subject (null arg)) + (msgnum (mew-summary-message-number2)) + (folder-name (mew-summary-folder-name)) + subject message-id references id-list) + (save-window-excursion + (if (fboundp 'mew-summary-set-message-buffer) + (mew-summary-set-message-buffer folder-name msgnum) + (set-buffer (mew-cache-hit folder-name msgnum t))) + (setq subject (mew-header-get-value "Subject:")) + (setq message-id (mew-header-get-value "Message-Id:")) + (setq references (mew-header-get-value "References:"))) + (setq id-list (mapcar (lambda (id) (org-unbracket-string "<" ">" id)) + (mew-idstr-to-id-list references))) + (if last-reference-only + (setq id-list (last id-list)) + (if message-id + (setq id-list (cons (org-unbracket-string "<" ">" message-id) + id-list)))) + (when (and by-subject (stringp subject)) + (catch 'matched + (mapc (lambda (elem) + (let ((regexp (car elem)) + (num (cdr elem))) + (when (string-match regexp subject) + (setq subject (match-string num subject)) + (throw 'matched t)))) + org-mew-subject-alist)) + (setq id-list (cons subject id-list))) + (cond ((null id-list) + (error "No message ID to search")) + ((equal (length id-list) 1) + (org-search-view nil (car id-list))) + (t + (org-search-view nil (format "{\\(%s\\)}" + (mapconcat 'regexp-quote + id-list "\\|")))))) + (delete-other-windows))) + +(defun org-mew-capture (arg) + "Guess the capture template from the folder name and invoke `org-capture'. + +This selects a capture template in `org-capture-templates' by +searching for capture template selection keys defined in +`org-mew-capture-guess-alist' which are associated with the +regular expression that matches the message's folder name, and +then invokes `org-capture'. + +If the message's folder is a inbox folder, you are prompted to +put the refile mark on the message and the capture template is +guessed from the refile destination folder. You can customize +the inbox folders by `org-mew-capture-inbox-folders'. + +If ARG is non-nil, this does not guess the capture template but +asks you to select the capture template." + (interactive "P") + (or (not (member (org-mew-folder-name) + org-mew-capture-inbox-folders)) + (eq (mew-summary-get-mark) ?o) + (save-window-excursion + (if (eq major-mode 'mew-message-mode) + (mew-message-goto-summary)) + (let ((mew-mark-afterstep-spec '((?o 0 0 0 0 0 0 0)))) + (mew-summary-refile))) + (error "No refile folder selected")) + (let* ((org-mew-link-to-refile-destination t) + (folder-name (org-mew-folder-name)) + (keys (if arg + nil + (org-mew-capture-guess-selection-keys folder-name)))) + (org-capture nil keys))) + +(defun org-mew-capture-guess-selection-keys (folder-name) + (catch 'found + (let ((alist org-mew-capture-guess-alist)) + (while alist + (let ((elem (car alist))) + (if (string-match (car elem) folder-name) + (throw 'found (cdr elem)))) + (setq alist (cdr alist)))))) + +(provide 'org-mew) + +;;; org-mew.el ends here diff --git a/contrib/lisp/org-mime.el b/contrib/lisp/org-mime.el new file mode 100644 index 0000000..2ced42e --- /dev/null +++ b/contrib/lisp/org-mime.el @@ -0,0 +1,345 @@ +;;; org-mime.el --- org html export for text/html MIME emails + +;; Copyright (C) 2010-2015 Eric Schulte + +;; Author: Eric Schulte +;; Keywords: mime, mail, email, html +;; Homepage: http://orgmode.org/worg/org-contrib/org-mime.php +;; Version: 0.01 + +;; 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: + +;; WYSWYG, html mime composition using org-mode +;; +;; For mail composed using the orgstruct-mode minor mode, this +;; provides a function for converting all or part of your mail buffer +;; to embedded html as exported by org-mode. Call `org-mime-htmlize' +;; in a message buffer to convert either the active region or the +;; entire buffer to html. +;; +;; Similarly the `org-mime-org-buffer-htmlize' function can be called +;; from within an org-mode buffer to convert the buffer to html, and +;; package the results into an email handling with appropriate MIME +;; encoding. +;; +;; you might want to bind this to a key with something like the +;; following message-mode binding +;; +;; (add-hook 'message-mode-hook +;; (lambda () +;; (local-set-key "\C-c\M-o" 'org-mime-htmlize))) +;; +;; and the following org-mode binding +;; +;; (add-hook 'org-mode-hook +;; (lambda () +;; (local-set-key "\C-c\M-o" 'org-mime-org-buffer-htmlize))) + +;;; Code: +(require 'cl) + +(declare-function org-export-string-as "ox" + (string backend &optional body-only ext-plist)) +(declare-function org-trim "org" (s &optional keep-lead)) + +(defcustom org-mime-use-property-inheritance nil + "Non-nil means al MAIL_ properties apply also for sublevels." + :group 'org-mime + :type 'boolean) + +(defcustom org-mime-default-header + "#+OPTIONS: latex:t\n" + "Default header to control html export options, and ensure + first line isn't assumed to be a title line." + :group 'org-mime + :type 'string) + +(defcustom org-mime-library 'mml + "Library to use for marking up MIME elements." + :group 'org-mime + :type '(choice 'mml 'semi 'vm)) + +(defcustom org-mime-preserve-breaks t + "Used as temporary value of `org-export-preserve-breaks' during + mime encoding." + :group 'org-mime + :type 'boolean) + +(defcustom org-mime-fixedwith-wrap + "<pre style=\"font-family: courier, monospace;\">\n%s</pre>\n" + "Format string used to wrap a fixedwidth HTML email." + :group 'org-mime + :type 'string) + +(defcustom org-mime-html-hook nil + "Hook to run over the html buffer before attachment to email. + This could be used for example to post-process html elements." + :group 'org-mime + :type 'hook) + +(mapc (lambda (fmt) + (eval `(defcustom + ,(intern (concat "org-mime-pre-" fmt "-hook")) + nil + (concat "Hook to run before " fmt " export.\nFunctions " + "should take no arguments and will be run in a " + "buffer holding\nthe text to be exported.")))) + '("ascii" "org" "html")) + +(defcustom org-mime-send-subtree-hook nil + "Hook to run in the subtree in the Org-mode file before export.") + +(defcustom org-mime-send-buffer-hook nil + "Hook to run in the Org-mode file before export.") + +;; example hook, for setting a dark background in <pre style="background-color: #EEE;"> elements +(defun org-mime-change-element-style (element style) + "Set new default htlm style for <ELEMENT> elements in exported html." + (while (re-search-forward (format "<%s\\>" element) nil t) + (replace-match (format "<%s style=\"%s\"" element style)))) + +(defun org-mime-change-class-style (class style) + "Set new default htlm style for objects with classs=CLASS in +exported html." + (while (re-search-forward (format "class=\"%s\"" class) nil t) + (replace-match (format "class=\"%s\" style=\"%s\"" class style)))) + +;; ;; example addition to `org-mime-html-hook' adding a dark background +;; ;; color to <pre> elements +;; (add-hook 'org-mime-html-hook +;; (lambda () +;; (org-mime-change-element-style +;; "pre" (format "color: %s; background-color: %s;" +;; "#E6E1DC" "#232323")) +;; (org-mime-change-class-style +;; "verse" "border-left: 2px solid gray; padding-left: 4px;"))) + +(defun org-mime-file (ext path id) + "Markup a file for attachment." + (case org-mime-library + ('mml (format (concat "<#part type=\"%s\" filename=\"%s\" " + "disposition=inline id=\"<%s>\">\n<#/part>\n") + ext path id)) + ('semi (concat + (format (concat "--[[%s\nContent-Disposition: " + "inline;\nContent-ID: <%s>][base64]]\n") + ext id) + (base64-encode-string + (with-temp-buffer + (set-buffer-multibyte nil) + (binary-insert-encoded-file path) + (buffer-string))))) + ('vm "?"))) + +(defun org-mime-multipart (plain html &optional images) + "Markup a multipart/alternative with text/plain and text/html alternatives. +If the html portion of the message includes images wrap the html +and images in a multipart/related part." + (case org-mime-library + ('mml (concat "<#multipart type=alternative><#part type=text/plain>" + plain + (when images "<#multipart type=related>") + "<#part type=text/html>" + html + images + (when images "<#/multipart>\n") + "<#/multipart>\n")) + ('semi (concat + "--" "<<alternative>>-{\n" + "--" "[[text/plain]]\n" plain + (if (and images (> (length images) 0)) + (concat "--" "<<related>>-{\n" + "--" "[[text/html]]\n" html + images + "--" "}-<<related>>\n") + (concat "--" "[[text/html]]\n" html + images)) + "--" "}-<<alternative>>\n")) + ('vm "?"))) + +(defun org-mime-replace-images (str) + "Replace images in html files with cid links." + (let (html-images) + (cons + (replace-regexp-in-string ;; replace images in html + "src=\"\\([^\"]+\\)\"" + (lambda (text) + (format + "src=\"cid:%s\"" + (let* ((url (and (string-match "src=\"\\([^\"]+\\)\"" text) + (match-string 1 text))) + (path (expand-file-name + url temporary-file-directory)) + (ext (file-name-extension path)) + (id (replace-regexp-in-string "[\/\\\\]" "_" path))) + (add-to-list 'html-images + (org-mime-file (concat "image/" ext) path id)) + id))) + str) + html-images))) + +(defun org-mime-htmlize (&optional arg) + "Export to HTML an email body composed using `mml-mode'. +If called with an active region only export that region, +otherwise export the entire body." + (interactive "P") + (require 'ox-org) + (require 'ox-html) + (let* ((region-p (org-region-active-p)) + (html-start (or (and region-p (region-beginning)) + (save-excursion + (goto-char (point-min)) + (search-forward mail-header-separator) + (+ (point) 1)))) + (html-end (or (and region-p (region-end)) + ;; TODO: should catch signature... + (point-max))) + (raw-body (concat org-mime-default-header + (buffer-substring html-start html-end))) + (body (org-export-string-as raw-body 'org t)) + ;; because we probably don't want to export a huge style file + (org-export-htmlize-output-type 'inline-css) + ;; makes the replies with ">"s look nicer + (org-export-preserve-breaks org-mime-preserve-breaks) + ;; dvipng for inline latex because MathJax doesn't work in mail + (org-html-with-latex 'dvipng) + ;; to hold attachments for inline html images + (html-and-images + (org-mime-replace-images + (org-export-string-as raw-body 'html t))) + (html-images (unless arg (cdr html-and-images))) + (html (org-mime-apply-html-hook + (if arg + (format org-mime-fixedwith-wrap body) + (car html-and-images))))) + (delete-region html-start html-end) + (save-excursion + (goto-char html-start) + (insert (org-mime-multipart + body html (mapconcat 'identity html-images "\n")))))) + +(defun org-mime-apply-html-hook (html) + (if org-mime-html-hook + (with-temp-buffer + (insert html) + (goto-char (point-min)) + (run-hooks 'org-mime-html-hook) + (buffer-string)) + html)) + +(defmacro org-mime-try (&rest body) + `(condition-case nil ,@body (error nil))) + +(defun org-mime-send-subtree (&optional fmt) + (save-restriction + (org-narrow-to-subtree) + (run-hooks 'org-mime-send-subtree-hook) + (let* ((mp (lambda (p) (org-entry-get nil p org-mime-use-property-inheritance))) + (file (buffer-file-name (current-buffer))) + (subject (or (funcall mp "MAIL_SUBJECT") (nth 4 (org-heading-components)))) + (to (funcall mp "MAIL_TO")) + (cc (funcall mp "MAIL_CC")) + (bcc (funcall mp "MAIL_BCC")) + (body (buffer-substring + (save-excursion (goto-char (point-min)) + (forward-line 1) + (when (looking-at "[ \t]*:PROPERTIES:") + (re-search-forward ":END:" nil) + (forward-char)) + (point)) + (point-max)))) + (org-mime-compose body (or fmt 'org) file to subject + `((cc . ,cc) (bcc . ,bcc)))))) + +(defun org-mime-send-buffer (&optional fmt) + (run-hooks 'org-mime-send-buffer-hook) + (let* ((region-p (org-region-active-p)) + (file (buffer-file-name (current-buffer))) + (subject (if (not file) (buffer-name (buffer-base-buffer)) + (file-name-sans-extension + (file-name-nondirectory file)))) + (body-start (or (and region-p (region-beginning)) + (save-excursion (goto-char (point-min))))) + (body-end (or (and region-p (region-end)) (point-max))) + (temp-body-file (make-temp-file "org-mime-export")) + (body (buffer-substring body-start body-end))) + (org-mime-compose body (or fmt 'org) file nil subject))) + +(defun org-mime-compose (body fmt file &optional to subject headers) + (require 'message) + (compose-mail to subject headers nil) + (message-goto-body) + (let ((bhook + (lambda (body fmt) + (let ((hook (intern (concat "org-mime-pre-" + (symbol-name fmt) + "-hook")))) + (if (> (eval `(length ,hook)) 0) + (with-temp-buffer + (insert body) + (goto-char (point-min)) + (eval `(run-hooks ',hook)) + (buffer-string)) + body)))) + (fmt (if (symbolp fmt) fmt (intern fmt)))) + (cond + ((eq fmt 'org) + (require 'ox-org) + (insert (org-export-string-as + (org-trim (funcall bhook body 'org)) 'org t))) + ((eq fmt 'ascii) + (require 'ox-ascii) + (insert (org-export-string-as + (concat "#+Title:\n" (funcall bhook body 'ascii)) 'ascii t))) + ((or (eq fmt 'html) (eq fmt 'html-ascii)) + (require 'ox-ascii) + (require 'ox-org) + (let* ((org-link-file-path-type 'absolute) + ;; we probably don't want to export a huge style file + (org-export-htmlize-output-type 'inline-css) + (html-and-images + (org-mime-replace-images + (org-export-string-as (funcall bhook body 'html) 'html t))) + (images (cdr html-and-images)) + (html (org-mime-apply-html-hook (car html-and-images)))) + (insert (org-mime-multipart + (org-export-string-as + (org-trim + (funcall bhook body (if (eq fmt 'html) 'org 'ascii))) + (if (eq fmt 'html) 'org 'ascii) t) + html) + (mapconcat 'identity images "\n"))))))) + +(defun org-mime-org-buffer-htmlize () + "Create an email buffer containing the current org-mode file + exported to html and encoded in both html and in org formats as + mime alternatives." + (interactive) + (org-mime-send-buffer 'html)) + +(defun org-mime-subtree () + "Create an email buffer containing the current org-mode subtree + exported to a org format or to the format specified by the + MAIL_FMT property of the subtree." + (interactive) + (org-mime-send-subtree + (or (org-entry-get nil "MAIL_FMT" org-mime-use-property-inheritance) 'org))) + +(provide 'org-mime) diff --git a/contrib/lisp/org-notify.el b/contrib/lisp/org-notify.el new file mode 100644 index 0000000..1a1d557 --- /dev/null +++ b/contrib/lisp/org-notify.el @@ -0,0 +1,394 @@ +;;; org-notify.el --- Notifications for Org-mode + +;; Copyright (C) 2012-2017 Free Software Foundation, Inc. + +;; Author: Peter Münster <pmrb@free.fr> +;; Keywords: notification, todo-list, alarm, reminder, pop-up + +;; This file is not part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Get notifications, when there is something to do. +;; Sometimes, you need a reminder a few days before a deadline, e.g. to buy a +;; present for a birthday, and then another notification one hour before to +;; have enough time to choose the right clothes. +;; For other events, e.g. rolling the dustbin to the roadside once per week, +;; you probably need another kind of notification strategy. +;; This package tries to satisfy the various needs. + +;; In order to activate this package, you must add the following code +;; into your .emacs: +;; +;; (require 'org-notify) +;; (org-notify-start) + +;; Example setup: +;; +;; (org-notify-add 'appt +;; '(:time "-1s" :period "20s" :duration 10 +;; :actions (-message -ding)) +;; '(:time "15m" :period "2m" :duration 100 +;; :actions -notify) +;; '(:time "2h" :period "5m" :actions -message) +;; '(:time "3d" :actions -email)) +;; +;; This means for todo-items with `notify' property set to `appt': 3 days +;; before deadline, send a reminder-email, 2 hours before deadline, start to +;; send messages every 5 minutes, then 15 minutes before deadline, start to +;; pop up notification windows every 2 minutes. The timeout of the window is +;; set to 100 seconds. Finally, when deadline is overdue, send messages and +;; make noise." + +;; Take also a look at the function `org-notify-add'. + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'org-element) + +(declare-function appt-delete-window "appt" ()) +(declare-function notifications-notify "notifications" (&rest prms)) +(declare-function article-lapsed-string "gnus-art" (t &optional ms)) + +(defgroup org-notify nil + "Options for Org-mode notifications." + :tag "Org Notify" + :group 'org) + +(defcustom org-notify-audible t + "Non-nil means beep to indicate notification." + :type 'boolean + :group 'org-notify) + +(defconst org-notify-actions + '("show" "show" "done" "done" "hour" "one hour later" "day" "one day later" + "week" "one week later") + "Possible actions for call-back functions.") + +(defconst org-notify-window-buffer-name "*org-notify-%s*" + "Buffer-name for the `org-notify-action-window' function.") + +(defvar org-notify-map nil + "Mapping between names and parameter lists.") + +(defvar org-notify-timer nil + "Timer of the notification daemon.") + +(defvar org-notify-parse-file nil + "Index of current file, that `org-element-parse-buffer' is parsing.") + +(defvar org-notify-on-action-map nil + "Mapping between on-action identifiers and parameter lists.") + +(defun org-notify-string->seconds (str) + "Convert time string STR to number of seconds." + (when str + (let* ((conv `(("s" . 1) ("m" . 60) ("h" . ,(* 60 60)) + ("d" . ,(* 24 60 60)) ("w" . ,(* 7 24 60 60)) + ("M" . ,(* 30 24 60 60)))) + (letters (concat + (mapcar (lambda (x) (string-to-char (car x))) conv))) + (case-fold-search nil)) + (string-match (concat "\\(-?\\)\\([0-9]+\\)\\([" letters "]\\)") str) + (* (string-to-number (match-string 2 str)) + (cdr (assoc (match-string 3 str) conv)) + (if (= (length (match-string 1 str)) 1) -1 1))))) + +(defun org-notify-convert-deadline (orig) + "Convert original deadline from `org-element-parse-buffer' to +simple timestamp string." + (if orig + (replace-regexp-in-string "^<\\|>$" "" + (plist-get (plist-get orig 'timestamp) + :raw-value)))) + +(defun org-notify-make-todo (heading &rest ignored) + "Create one todo item." + (macrolet ((get (k) `(plist-get list ,k)) + (pr (k v) `(setq result (plist-put result ,k ,v)))) + (let* ((list (nth 1 heading)) (notify (or (get :NOTIFY) "default")) + (deadline (org-notify-convert-deadline (get :deadline))) + (heading (get :raw-value)) + result) + (when (and (eq (get :todo-type) 'todo) heading deadline) + (pr :heading heading) (pr :notify (intern notify)) + (pr :begin (get :begin)) + (pr :file (nth org-notify-parse-file (org-agenda-files 'unrestricted))) + (pr :timestamp deadline) (pr :uid (md5 (concat heading deadline))) + (pr :deadline (- (org-time-string-to-seconds deadline) + (float-time)))) + result))) + +(defun org-notify-todo-list () + "Create the todo-list for one org-agenda file." + (let* ((files (org-agenda-files 'unrestricted)) + (max (1- (length files)))) + (setq org-notify-parse-file + (if (or (not org-notify-parse-file) (>= org-notify-parse-file max)) + 0 + (1+ org-notify-parse-file))) + (save-excursion + (with-current-buffer (find-file-noselect + (nth org-notify-parse-file files)) + (org-element-map (org-element-parse-buffer 'headline) + 'headline 'org-notify-make-todo))))) + +(defun org-notify-maybe-too-late (diff period heading) + "Print warning message, when notified significantly later than defined by +PERIOD." + (if (> (/ diff period) 1.5) + (message "Warning: notification for \"%s\" behind schedule!" heading)) + t) + +(defun org-notify-process () + "Process the todo-list, and possibly notify user about upcoming or +forgotten tasks." + (macrolet ((prm (k) `(plist-get prms ,k)) (td (k) `(plist-get todo ,k))) + (dolist (todo (org-notify-todo-list)) + (let* ((deadline (td :deadline)) (heading (td :heading)) + (uid (td :uid)) (last-run-sym + (intern (concat ":last-run-" uid)))) + (dolist (prms (plist-get org-notify-map (td :notify))) + (when (< deadline (org-notify-string->seconds (prm :time))) + (let ((period (org-notify-string->seconds (prm :period))) + (last-run (prm last-run-sym)) (now (float-time)) + (actions (prm :actions)) diff plist) + (when (or (not last-run) + (and period (< period (setq diff (- now last-run))) + (org-notify-maybe-too-late diff period heading))) + (setq prms (plist-put prms last-run-sym now) + plist (append todo prms)) + (if (if (plist-member prms :audible) + (prm :audible) + org-notify-audible) + (ding)) + (unless (listp actions) + (setq actions (list actions))) + (dolist (action actions) + (funcall (if (fboundp action) action + (intern (concat "org-notify-action" + (symbol-name action)))) + plist)))) + (return))))))) + +(defun org-notify-add (name &rest params) + "Add a new notification type. +The NAME can be used in Org-mode property `notify'. If NAME is +`default', the notification type applies for todo items without +the `notify' property. This file predefines such a default +notification type. + +Each element of PARAMS is a list with parameters for a given time +distance to the deadline. This distance must increase from one +element to the next. + +List of possible parameters: + + :time Time distance to deadline, when this type of notification shall + start. It's a string: an integral value (positive or negative) + followed by a unit (s, m, h, d, w, M). + :actions A function or a list of functions to be called to notify the + user. Instead of a function name, you can also supply a suffix + of one of the various predefined `org-notify-action-xxx' + functions. + :period Optional: can be used to repeat the actions periodically. + Same format as :time. + :duration Some actions use this parameter to specify the duration of the + notification. It's an integral number in seconds. + :audible Overwrite the value of `org-notify-audible' for this action. + +For the actions, you can use your own functions or some of the predefined +ones, whose names are prefixed with `org-notify-action-'." + (setq org-notify-map (plist-put org-notify-map name params))) + +(defun org-notify-start (&optional secs) + "Start the notification daemon. +If SECS is positive, it's the period in seconds for processing +the notifications of one org-agenda file, and if negative, +notifications will be checked only when emacs is idle for -SECS +seconds. The default value for SECS is 20." + (interactive) + (if org-notify-timer + (org-notify-stop)) + (setq secs (or secs 20) + org-notify-timer (if (< secs 0) + (run-with-idle-timer (* -1 secs) t + 'org-notify-process) + (run-with-timer secs secs 'org-notify-process)))) + +(defun org-notify-stop () + "Stop the notification daemon." + (when org-notify-timer + (cancel-timer org-notify-timer) + (setq org-notify-timer nil))) + +(defun org-notify-on-action (plist key) + "User wants to see action." + (let ((file (plist-get plist :file)) + (begin (plist-get plist :begin))) + (if (string-equal key "show") + (progn + (switch-to-buffer (find-file-noselect file)) + (org-with-wide-buffer + (goto-char begin) + (show-entry)) + (goto-char begin) + (search-forward "DEADLINE: <") + (if (display-graphic-p) + (x-focus-frame nil))) + (save-excursion + (with-current-buffer (find-file-noselect file) + (org-with-wide-buffer + (goto-char begin) + (search-forward "DEADLINE: <") + (cond + ((string-equal key "done") (org-todo)) + ((string-equal key "hour") (org-timestamp-change 60 'minute)) + ((string-equal key "day") (org-timestamp-up-day)) + ((string-equal key "week") (org-timestamp-change 7 'day))))))))) + +(defun org-notify-on-action-notify (id key) + "User wants to see action after mouse-click in notify window." + (org-notify-on-action (plist-get org-notify-on-action-map id) key) + (org-notify-on-close id nil)) + +(defun org-notify-on-action-button (button) + "User wants to see action after button activation." + (macrolet ((get (k) `(button-get button ,k))) + (org-notify-on-action (get 'plist) (get 'key)) + (org-notify-delete-window (get 'buffer)) + (cancel-timer (get 'timer)))) + +(defun org-notify-delete-window (buffer) + "Delete the notification window." + (require 'appt) + (let ((appt-buffer-name buffer) + (appt-audible nil)) + (appt-delete-window))) + +(defun org-notify-on-close (id reason) + "Notification window has been closed." + (setq org-notify-on-action-map (plist-put org-notify-on-action-map id nil))) + +(defun org-notify-action-message (plist) + "Print a message." + (message "TODO: \"%s\" at %s!" (plist-get plist :heading) + (plist-get plist :timestamp))) + +(defun org-notify-action-ding (plist) + "Make noise." + (let ((timer (run-with-timer 0 1 'ding))) + (run-with-timer (or (plist-get plist :duration) 3) nil + 'cancel-timer timer))) + +(defun org-notify-body-text (plist) + "Make human readable string for remaining time to deadline." + (require 'gnus-art) + (format "%s\n(%s)" + (replace-regexp-in-string + " in the future" "" + (article-lapsed-string + (time-add (current-time) + (seconds-to-time (plist-get plist :deadline))) 2)) + (plist-get plist :timestamp))) + +(defun org-notify-action-email (plist) + "Send email to user." + (compose-mail user-mail-address (concat "TODO: " (plist-get plist :heading))) + (insert (org-notify-body-text plist)) + (funcall send-mail-function) + (flet ((yes-or-no-p (prompt) t)) + (kill-buffer))) + +(defun org-notify-select-highest-window () + "Select the highest window on the frame, that is not is not an +org-notify window. Mostly copied from `appt-select-lowest-window'." + (let ((highest-window (selected-window)) + (bottom-edge (nth 3 (window-edges))) + next-bottom-edge) + (walk-windows (lambda (w) + (when (and + (not (string-match "^\\*org-notify-.*\\*$" + (buffer-name + (window-buffer w)))) + (> bottom-edge (setq next-bottom-edge + (nth 3 (window-edges w))))) + (setq bottom-edge next-bottom-edge + highest-window w))) 'nomini) + (select-window highest-window))) + +(defun org-notify-action-window (plist) + "Pop up a window, mostly copied from `appt-disp-window'." + (save-excursion + (macrolet ((get (k) `(plist-get plist ,k))) + (let ((this-window (selected-window)) + (buf (get-buffer-create + (format org-notify-window-buffer-name (get :uid))))) + (when (minibufferp) + (other-window 1) + (and (minibufferp) (display-multi-frame-p) (other-frame 1))) + (if (cdr (assq 'unsplittable (frame-parameters))) + (progn (set-buffer buf) (display-buffer buf)) + (unless (or (special-display-p (buffer-name buf)) + (same-window-p (buffer-name buf))) + (org-notify-select-highest-window) + (when (>= (window-height) (* 2 window-min-height)) + (select-window (split-window nil nil 'above)))) + (switch-to-buffer buf)) + (setq buffer-read-only nil buffer-undo-list t) + (erase-buffer) + (insert (format "TODO: %s, %s.\n" (get :heading) + (org-notify-body-text plist))) + (let ((timer (run-with-timer (or (get :duration) 10) nil + 'org-notify-delete-window buf))) + (dotimes (i (/ (length org-notify-actions) 2)) + (let ((key (nth (* i 2) org-notify-actions)) + (text (nth (1+ (* i 2)) org-notify-actions))) + (insert-button text 'action 'org-notify-on-action-button + 'key key 'buffer buf 'plist plist 'timer timer) + (insert " ")))) + (shrink-window-if-larger-than-buffer (get-buffer-window buf t)) + (set-buffer-modified-p nil) (setq buffer-read-only t) + (raise-frame (selected-frame)) (select-window this-window))))) + +(defun org-notify-action-notify (plist) + "Pop up a notification window." + (require 'notifications) + (let* ((duration (plist-get plist :duration)) + (id (notifications-notify + :title (plist-get plist :heading) + :body (org-notify-body-text plist) + :timeout (if duration (* duration 1000)) + :actions org-notify-actions + :on-action 'org-notify-on-action-notify))) + (setq org-notify-on-action-map + (plist-put org-notify-on-action-map id plist)))) + +(defun org-notify-action-notify/window (plist) + "For a graphics display, pop up a notification window, for a text +terminal an emacs window." + (if (display-graphic-p) + (org-notify-action-notify plist) + (org-notify-action-window plist))) + +;;; Provide a minimal default setup. +(org-notify-add 'default '(:time "1h" :actions -notify/window + :period "2m" :duration 60)) + +(provide 'org-notify) + +;;; org-notify.el ends here diff --git a/contrib/lisp/org-notmuch.el b/contrib/lisp/org-notmuch.el new file mode 100644 index 0000000..65d7550 --- /dev/null +++ b/contrib/lisp/org-notmuch.el @@ -0,0 +1,135 @@ +;;; org-notmuch.el --- Support for links to notmuch messages from within Org-mode + +;; Copyright (C) 2010-2014 Matthieu Lemerre + +;; Author: Matthieu Lemerre <racin@free.fr> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org + +;; This file is not part of GNU Emacs. + +;; This file 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 file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file implements links to notmuch messages and "searchs". A +;; search is a query to be performed by notmuch; it is the equivalent +;; to folders in other mail clients. Similarly, mails are refered to +;; by a query, so both a link can refer to several mails. + +;; Links have one the following form +;; notmuch:<search terms> +;; notmuch-search:<search terms>. + +;; The first form open the queries in notmuch-show mode, whereas the +;; second link open it in notmuch-search mode. Note that queries are +;; performed at the time the link is opened, and the result may be +;; different from whet the link was stored. + +;;; Code: + +(require 'org) + +;; customisable notmuch open functions +(defcustom org-notmuch-open-function + 'org-notmuch-follow-link + "Function used to follow notmuch links. + +Should accept a notmuch search string as the sole argument." + :group 'org-notmuch + :version "24.4" + :package-version '(Org . "8.0") + :type 'function) + +(defcustom org-notmuch-search-open-function + 'org-notmuch-search-follow-link + "Function used to follow notmuch-search links. + +Should accept a notmuch search string as the sole argument." + :group 'org-notmuch + :version "24.4" + :package-version '(Org . "8.0") + :type 'function) + + + +;; Install the link type +(org-link-set-parameters "notmuch" + :follow #'org-notmuch-open + :store #'org-notmuch-store-link) + +(defun org-notmuch-store-link () + "Store a link to a notmuch search or message." + (when (eq major-mode 'notmuch-show-mode) + (let* ((message-id (notmuch-show-get-message-id t)) + (subject (notmuch-show-get-subject)) + (to (notmuch-show-get-to)) + (from (notmuch-show-get-from)) + (date (org-trim (notmuch-show-get-date))) + desc link) + (org-store-link-props :type "notmuch" :from from :to to :date date + :subject subject :message-id message-id) + (setq desc (org-email-link-description)) + (setq link (concat "notmuch:id:" message-id)) + (org-add-link-props :link link :description desc) + link))) + +(defun org-notmuch-open (path) + "Follow a notmuch message link specified by PATH." + (funcall org-notmuch-open-function path)) + +(defun org-notmuch-follow-link (search) + "Follow a notmuch link to SEARCH. + +Can link to more than one message, if so all matching messages are shown." + (require 'notmuch) + (notmuch-show search)) + + + +(org-link-set-parameters "notmuch-search" + :follow #'org-notmuch-search-open + :store #'org-notmuch-search-store-link) + +(defun org-notmuch-search-store-link () + "Store a link to a notmuch search or message." + (when (eq major-mode 'notmuch-search-mode) + (let ((link (concat "notmuch-search:" + (org-link-escape notmuch-search-query-string))) + (desc (concat "Notmuch search: " notmuch-search-query-string))) + (org-store-link-props :type "notmuch-search" + :link link + :description desc) + link))) + +(defun org-notmuch-search-open (path) + "Follow a notmuch message link specified by PATH." + (message "%s" path) + (funcall org-notmuch-search-open-function path)) + +(defun org-notmuch-search-follow-link (search) + "Follow a notmuch link by displaying SEARCH in notmuch-search mode." + (require 'notmuch) + (notmuch-search (org-link-unescape search))) + + + +(defun org-notmuch-tree-follow-link (search) + "Follow a notmuch link by displaying SEARCH in notmuch-tree mode." + (require 'notmuch) + (notmuch-tree (org-link-unescape search))) + +(provide 'org-notmuch) + +;;; org-notmuch.el ends here diff --git a/contrib/lisp/org-panel.el b/contrib/lisp/org-panel.el new file mode 100644 index 0000000..dec7241 --- /dev/null +++ b/contrib/lisp/org-panel.el @@ -0,0 +1,638 @@ +;;; org-panel.el --- Simple routines for us with bad memory +;; +;; Author: Lennart Borgman (lennart O borgman A gmail O com) +;; Created: Thu Nov 15 15:35:03 2007 +;; Version: 0.21 +;; Lxast-Updated: Wed Nov 21 03:06:03 2007 (3600 +0100) +;; URL: +;; Keywords: +;; Compatibility: +;; +;; Features that might be required by this library: +;; +;; `easymenu', `font-lock', `noutline', `org', `outline', `syntax', +;; `time-date'. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; This defines a kind of control panel for `org-mode'. This control +;; panel should make it fast to move around and edit structure etc. +;; +;; To bring up the control panel type +;; +;; M-x orgpan-panel +;; +;; Type ? there for help. +;; +;; I suggest you add the following to your .emacs for quick access of +;; the panel: +;; +;; (eval-after-load 'org-mode +;; (define-key org-mode-map [(control ?c) ?p] 'orgpan-panel)) +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Change log: +;; +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Code: + +(require 'org) +(require 'outline) + +;; Fix-me: this is for testing. A minor mode version interferes badly +;; with emulation minor modes. On the other hand, the other version +;; interferes badly with (interactive ...). +(defvar orgpan-minor-mode-version t) + +(defface orgpan-field + '((t (:inherit 'widget-field))) + "Face for fields." + :group 'winsize) +(defvar orgpan-field-face 'orgpan-field) + +(defface orgpan-active-field + '((t (:inherit 'highlight))) + "Face for fields." + :group 'winsize) +(defvar orgpan-active-field-face 'orgpan-active-field) + +(defface orgpan-spaceline + '((t (:height 0.2))) + "Face for spacing lines." + :group 'winsize) + +(defcustom orgpan-panel-buttons nil + "Panel style, if non-nil use buttons. +If there are buttons in the panel they are used to change the way +the arrow keys work. The panel looks something like this, with +the first button chosen: + + [Navigate] [Restructure] [TODO/Priority] + ---------- + up/down, left: Go to, right: Visibility + +The line below the buttons try to give a short hint about what +the arrow keys does. \(Personally I prefer the version without +buttons since I then do not have to remember which button is +active.)" + :type 'boolean + :group 'winsize) + +;; Fix-me: add org-mode-map +(defconst orgpan-org-mode-commands nil) +(defconst orgpan-org-commands + '( + orgpan-copy-subtree + orgpan-cut-subtree + orgpan-paste-subtree + undo + ;; + ;orgpan-occur + ;; + org-cycle + org-global-cycle + outline-up-heading + outline-next-visible-heading + outline-previous-visible-heading + outline-forward-same-level + outline-backward-same-level + org-todo + org-show-todo-tree + org-priority-up + org-priority-down + org-move-subtree-up + org-move-subtree-down + org-do-promote + org-do-demote + org-promote-subtree + org-demote-subtree)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Hook functions etc + +(defun orgpan-delete-panel () + "Remove the panel." + (interactive) + (when (buffer-live-p orgpan-panel-buffer) + (delete-windows-on orgpan-panel-buffer) + (kill-buffer orgpan-panel-buffer)) + (setq orgpan-panel-buffer nil) + (setq orgpan-panel-window nil) + (orgpan-panel-minor-mode 0) + (remove-hook 'post-command-hook 'orgpan-minor-post-command) + (remove-hook 'post-command-hook 'orgpan-mode-post-command) + ;;(remove-hook 'window-configuration-change-hook 'orgpan-window-config-change) + ) + +(defvar orgpan-last-command-was-from-panel nil) +(defun orgpan-mode-pre-command () + (setq orgpan-last-command-was-from-panel nil) + (condition-case err + (if (not (and (windowp orgpan-org-window) + (window-live-p orgpan-org-window))) + (progn + (setq this-command 'ignore) + (orgpan-delete-panel) + (message "The window belonging to the panel had disappeared, removed panel.")) + (let ((buf (window-buffer orgpan-org-window))) + (when (with-current-buffer buf + (derived-mode-p 'org-mode)) + (setq orgpan-last-org-buffer buf)) + ;; Fix me: add a list of those commands that are not + ;; meaningful from the panel (for example org-time-stamp) + (when (or (memq this-command orgpan-org-commands) + (memq this-command orgpan-org-mode-commands) + ;; For some reason not all org commands are found above: + (string= "org-" (substring (format "%s" this-command) 0 4))) + (if (not (with-current-buffer buf + (derived-mode-p 'org-mode))) + (progn + (if (buffer-live-p orgpan-org-buffer) + (set-window-buffer orgpan-org-window orgpan-org-buffer) + (message "Please use `l' or `b' to choose an org-mode buffer")) + (setq this-command 'ignore)) + (setq orgpan-org-buffer (window-buffer orgpan-org-window)) + (setq orgpan-last-command-was-from-panel t) + (select-window orgpan-org-window) + ;;(when (active-minibuffer-window + ;;(set-buffer orgpan-org-buffer) + )))) + (error (lwarn 't :warning "orgpan-pre: %S" err)))) + +(defun orgpan-mode-post-command () + (condition-case err + (progn + (unless (and (windowp orgpan-panel-window) + (window-live-p orgpan-panel-window) + (bufferp orgpan-panel-buffer) + (buffer-live-p orgpan-panel-buffer)) + ;;(orgpan-delete-panel) + ) + (when (and orgpan-last-command-was-from-panel + (windowp orgpan-panel-window) + (window-live-p orgpan-panel-window)) + (select-window orgpan-panel-window) + (when (derived-mode-p 'orgpan-mode) + (setq deactivate-mark t) + (when orgpan-panel-buttons + (unless (and orgpan-point + (= (point) orgpan-point)) + ;; Go backward so it is possible to click on a "button": + (orgpan-backward-field)))))) + (error (lwarn 't :warning "orgpan-post: %S" err)))) + +;; (defun orgpan-window-config-change () +;; "Check if any frame is displaying an orgpan panel. +;; If not remove `orgpan-mode-post-command' and this function from +;; the hooks." +;; (condition-case err +;; (unless (and ( +;; (let ((found-pan nil)) +;; (dolist (f (frame-list)) +;; (dolist (w (window-list f 'nomini)) +;; (with-current-buffer (window-buffer w) +;; (when (derived-mode-p 'orgpan-mode) +;; (setq found-pan t))))) +;; (unless found-pan +;; (remove-hook 'post-command-hook 'orgpan-mode-post-command) +;; (remove-hook 'window-configuration-change-hook 'orgpan-window-config-change))) +;; (error (lwarn 't :warning "Error in orgpan-config-change: %S" err)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Commands + +(defun orgpan-last-buffer () + "Open last org-mode buffer in panels org window." + (interactive) + (let ((buf (window-buffer orgpan-org-window)) + (last-buf orgpan-last-org-buffer)) + (when (with-current-buffer buf + (derived-mode-p 'org-mode)) + (setq orgpan-last-org-buffer buf)) + (when (eq last-buf buf) + (setq last-buf nil)) + (if (not last-buf) + (orgpan-switch-buffer) + (set-window-buffer orgpan-org-window last-buf)))) + +(defun orgpan-switch-buffer () + "Switch to next org-mode buffer in panels org window." + (interactive) + (let ((buf (window-buffer orgpan-org-window)) + (org-buffers nil)) + (with-current-buffer buf + (when (derived-mode-p 'org-mode) + (bury-buffer buf) + (setq orgpan-last-org-buffer buf))) + (setq org-buffers (delq nil (mapcar (lambda (buf) + (when (with-current-buffer buf + (derived-mode-p 'org-mode)) + buf)) + (buffer-list)))) + (setq org-buffers (delq buf org-buffers)) + (set-window-buffer orgpan-org-window (car org-buffers)) + (setq orgpan-org-buffer (car org-buffers)))) + +(defun orgpan-paste-subtree () + (interactive) + (if (y-or-n-p "Paste subtree here? ") + (org-paste-subtree) + (message "Nothing was pasted"))) + +(defun orgpan-cut-subtree () + (interactive) + (let ((heading (progn + (org-back-to-heading) + (buffer-substring (point) (line-end-position)) + ))) + (if (y-or-n-p (format "Do you want to cut the subtree\n%s\n? " heading)) + (org-cut-subtree) + (message "Nothing was cut")))) + +(defun orgpan-copy-subtree () + (interactive) + (let ((heading (progn + (org-back-to-heading) + (buffer-substring (point) (line-end-position)) + ))) + (if (y-or-n-p (format "Do you want to copy the subtree\n%s\n? " heading)) + (org-copy-subtree) + (message "Nothing was copied")))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Buttons + +(defvar orgpan-ovl-help nil) + +(defun orgpan-check-panel-mode () + (unless (derived-mode-p 'orgpan-mode) + (error "Not orgpan-mode in buffer: %s" major-mode))) + +(defun orgpan-display-bindings-help () + (orgpan-check-panel-mode) + (setq orgpan-point (point)) + (let* ((ovls (overlays-at (point))) + (ovl (car ovls)) + (help (when ovl (overlay-get ovl 'orgpan-explain)))) + (dolist (o (overlays-in (point-min) (point-max))) + (overlay-put o 'face orgpan-field-face)) + (overlay-put ovl 'face orgpan-active-field-face) + (overlay-put orgpan-ovl-help 'before-string help))) + +(defun orgpan-forward-field () + (interactive) + (orgpan-check-panel-mode) + (let ((pos (next-overlay-change (point)))) + (unless (overlays-at pos) + (setq pos (next-overlay-change pos))) + (when (= pos (point-max)) + (setq pos (point-min)) + (unless (overlays-at pos) + (setq pos (next-overlay-change pos)))) + (goto-char pos)) + (orgpan-display-bindings-help)) + +(defun orgpan-backward-field () + (interactive) + (orgpan-check-panel-mode) + (when (= (point) (point-min)) + (goto-char (point-max))) + (let ((pos (previous-overlay-change (point)))) + (unless (overlays-at pos) + (setq pos (previous-overlay-change pos))) + (goto-char pos)) + (orgpan-display-bindings-help)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Mode + +(defconst orgpan-mode-map + ;; Fix-me: clean up here! + ;; Fix-me: viper support + (let ((map (make-sparse-keymap))) + (define-key map [?q] 'orgpan-delete-panel) + (define-key map [??] 'orgpan-help) + ;; Copying etc + (define-key map [?c] 'orgpan-copy-subtree) + (define-key map [?x] 'orgpan-cut-subtree) + (define-key map [?p] 'orgpan-paste-subtree) + (define-key map [?z] 'undo) + ;; Buffers: + (define-key map [?b] 'orgpan-switch-buffer) + (define-key map [?l] 'orgpan-last-buffer) + ;; Some keys for moving between headings. Emacs keys for next/prev + ;; line seems ok: + (define-key map [(control ?p)] 'outline-previous-visible-heading) + (define-key map [(control ?n)] 'outline-next-visible-heading) + (define-key map [(shift control ?p)] 'outline-backward-same-level) + (define-key map [(shift control ?n)] 'outline-forward-same-level) + ;; A mnemunic for up: + (define-key map [(control ?u)] 'outline-up-heading) + ;; Search sparse tree: + ;; + ;; Fix-me: Search does not work, some problem with + ;; interactive. Probably have to turn the whole thing around and + ;; always be in the org buffer, but with a minor mode running + ;; there. + ;; + ;;(define-key map [?s] 'org-sparse-tree) + (define-key map [?s] 'orgpan-occur) + ;; Same as in org-mode: + ;;(define-key map [(control ?c)(control ?v)] 'org-show-todo-tree) + ;; Fix-me: This leads to strange problems: + ;;(define-key map [t] 'ignore) + map)) + +(defun orgpan-occur () + "Replacement for `org-occur'. +Technical reasons." + (interactive) + (let ((rgx (read-from-minibuffer "my mini Regexp: "))) + (setq orgpan-last-command-was-from-panel t) + (select-window orgpan-org-window) + (org-occur rgx))) + +(defvar orgpan-panel-window nil + "The window showing `orgpan-panel-buffer'.") + +(defvar orgpan-panel-buffer nil + "The panel buffer. +There can be only one such buffer at any time.") + +(defvar orgpan-org-window nil) +;;(make-variable-buffer-local 'orgpan-org-window) + +;; Fix-me: used? +(defvar orgpan-org-buffer nil) +;;(make-variable-buffer-local 'orgpan-org-buffer) + +(defvar orgpan-last-org-buffer nil) +;;(make-variable-buffer-local 'orgpan-last-org-buffer) + +(defvar orgpan-point nil) +;;(make-variable-buffer-local 'orgpan-point) + +(defvar viper-emacs-state-mode-list) +(defvar viper-new-major-mode-buffer-list) + +(defun orgpan-avoid-viper-in-buffer () + ;; Fix-me: This is ugly. However see `this-major-mode-requires-vi-state': + (set (make-local-variable 'viper-emacs-state-mode-list) '(orgpan-mode)) + (set (make-local-variable 'viper-new-major-mode-buffer-list) nil) + (local-set-key [?\ ] 'ignore)) + +(define-derived-mode orgpan-mode nil "Org-Panel" + "Mode for org-simple.el control panel." + (setq buffer-read-only t) + (unless orgpan-minor-mode-version + (add-hook 'pre-command-hook 'orgpan-mode-pre-command nil t) + (add-hook 'post-command-hook 'orgpan-mode-post-command t)) + (orgpan-avoid-viper-in-buffer) + (setq cursor-type nil)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Panel layout + +(defun orgpan-insert-field (text keymap explain) + (insert text) + (let* ((end (point)) + (len (length text)) + (beg (- end len)) + (ovl (make-overlay beg end))) + (overlay-put ovl 'face orgpan-field-face) + (overlay-put ovl 'keymap keymap) + (overlay-put ovl 'orgpan-explain explain))) + +(defconst orgpan-with-keymap + (let ((map (make-sparse-keymap))) + (set-keymap-parent map org-mode-map) + ;; Users are used to tabbing between fields: + (define-key map [(tab)] 'orgpan-forward-field) + (define-key map [(shift tab)] 'orgpan-backward-field) + ;; Now we must use something else for visibility (first does not work if Viper): + (define-key map [(meta tab)] 'org-cycle) + (define-key map [(control meta tab)] 'org-global-cycle) + map)) + +(defconst orgpan-without-keymap + (let ((map (make-sparse-keymap))) + (set-keymap-parent map org-mode-map) + ;; Visibility (those are in org-mode-map): + ;;(define-key map [tab] 'org-cycle) + ;;(define-key map [(shift tab)] 'org-global-cycle) + ;; Navigate: + (define-key map [left] 'outline-up-heading) + (define-key map [right] 'org-cycle) + (define-key map [up] 'outline-previous-visible-heading) + (define-key map [down] 'outline-next-visible-heading) + (define-key map [(shift down)] 'outline-forward-same-level) + (define-key map [(shift up)] 'outline-backward-same-level) + ;; Restructure: + (define-key map [(control up)] 'org-move-subtree-up) + (define-key map [(control down)] 'org-move-subtree-down) + (define-key map [(control left)] 'org-do-promote) + (define-key map [(control right)] 'org-do-demote) + (define-key map [(control shift left)] 'org-promote-subtree) + (define-key map [(control shift right)] 'org-demote-subtree) + ;; Todo etc + (define-key map [?+] 'org-priority-up) + (define-key map [?-] 'org-priority-down) + (define-key map [?t] 'org-todo) + map)) + +(defun orgpan-make-panel-without-buttons (buf) + (with-current-buffer buf + (insert (propertize "Org Panel" 'face 'orgpan-active-field)) + (insert " ? for help, q quit\n") + (insert (propertize "arrows" 'face 'font-lock-keyword-face) + ": Go to, " + (propertize "C-arrows" 'face 'font-lock-keyword-face) + ": Edit tree\n" + (propertize "cxpz" 'face 'font-lock-keyword-face) + ": copy cut paste undo, " + (propertize "tT+-" 'face 'font-lock-keyword-face) + ": todo priority, " + (propertize "s" 'face 'font-lock-keyword-face) + " search" + ) + (set-keymap-parent orgpan-mode-map orgpan-without-keymap) + )) + +(defun orgpan-make-panel-with-buttons (buf) + (with-current-buffer buf + (let* ((base-map (make-sparse-keymap)) + (space-line (propertize "\n\n" 'face 'orgpan-spaceline)) + (arrow-face 'font-lock-keyword-face) + (L (propertize "left" 'face arrow-face)) + (R (propertize "right" 'face arrow-face)) + (U (propertize "up" 'face arrow-face)) + (D (propertize "down" 'face arrow-face))) + ;;(message D)(sit-for 2) + (define-key base-map [left] 'ignore) + (define-key base-map [right] 'ignore) + (define-key base-map [up] 'ignore) + (define-key base-map [down] 'ignore) + (define-key base-map [?q] 'delete-window) + (define-key base-map [??] 'orgpan-help) + ;; Navigating + (let ((map (copy-keymap base-map))) + (define-key map [left] 'outline-up-heading) + (define-key map [right] 'org-cycle) + (define-key map [up] 'outline-previous-visible-heading) + (define-key map [down] 'outline-next-visible-heading) + (define-key map [(shift down)] 'outline-forward-same-level) + (define-key map [(shift up)] 'outline-backward-same-level) + (orgpan-insert-field "Navigate" map (concat U "/" D ", " L ": Go to, " R ": Visibility"))) + (insert " ") + (let ((map (copy-keymap base-map))) + (define-key map [up] 'org-move-subtree-up) + (define-key map [down] 'org-move-subtree-down) + (define-key map [left] 'org-do-promote) + (define-key map [right] 'org-do-demote) + (define-key map [(shift left)] 'org-promote-subtree) + (define-key map [(shift right)] 'org-demote-subtree) + (orgpan-insert-field + "Restructure" map + (concat U "/" D ": " + (propertize "Move" 'face 'font-lock-warning-face) + ", " L "/" R ": " + (propertize "Level (w S: Subtree Level)" 'face 'font-lock-warning-face)))) + (insert " ") + (let ((map (copy-keymap base-map))) + (define-key map [up] 'org-priority-up) + (define-key map [down] 'org-priority-down) + (define-key map [right] 'org-todo) + (orgpan-insert-field "TODO/priority" map + (concat R ": TODO, " U "/" D ": Priority"))) + ) + (insert " ? for help, q quit\n") + (orgpan-display-bindings-help) + (setq orgpan-ovl-help (make-overlay (point) (point))) + )) + +(defun orgpan-make-panel-buffer () + "Make the panel buffer." + (let* ((buf-name "*Org Panel*")) + (when orgpan-panel-buffer (kill-buffer orgpan-panel-buffer)) + (setq orgpan-panel-buffer (get-buffer-create buf-name)) + (if orgpan-panel-buttons + (orgpan-make-panel-with-buttons orgpan-panel-buffer) + (orgpan-make-panel-without-buttons orgpan-panel-buffer)) + (with-current-buffer orgpan-panel-buffer + (orgpan-mode) + (goto-char (point-min))) + orgpan-panel-buffer)) + +(defun orgpan-help () + (interactive) + (set-keymap-parent orgpan-with-keymap nil) + (set-keymap-parent orgpan-without-keymap nil) + (describe-function 'orgpan-panel) + (set-keymap-parent orgpan-with-keymap org-mode-map) + (set-keymap-parent orgpan-without-keymap org-mode-map) + (message "Use 'l' to remove help window") + ) + +(defun orgpan-panel () + "Create a control panel for current `org-mode' buffer. +The control panel may be used to quickly move around and change +the headings. The idea is that when you want to to a lot of this +kind of editing you should be able to do that with few +keystrokes (and without having to remember the complicated +keystrokes). A typical situation when this perhaps can be useful +is when you are looking at your notes file \(usually ~/.notes, +see `remember-data-file') where you have saved quick notes with +`remember'. + +The keys below are defined in the panel. Note that the commands +are carried out in the `org-mode' buffer that belongs to the +panel. + +\\{orgpan-mode-map} + +In addition to the keys above most of the keys in `org-mode' can +also be used from the panel. + +Note: There are two forms of the control panel, one with buttons +and one without. The default is without, see +`orgpan-panel-buttons'. If buttons are used choosing a different +button changes the binding of the arrow keys." + (interactive) + (unless (derived-mode-p 'org-mode) + (error "Buffer is not in org-mode")) + (orgpan-delete-panel) + (unless orgpan-org-mode-commands + (map-keymap (lambda (ev def) + (when (and def + (symbolp def) + (fboundp def)) + (setq orgpan-org-mode-commands + (cons def orgpan-org-mode-commands)))) + org-mode-map)) + ;;(org-back-to-heading) + ;;(remove-hook 'window-configuration-change-hook 'orgpan-window-config-change) + (setq orgpan-org-window (selected-window)) + (setq orgpan-panel-window (split-window nil -4 'below)) + (select-window orgpan-panel-window) + (set-window-buffer (selected-window) (orgpan-make-panel-buffer)) + ;;(set-window-dedicated-p (selected-window) t) + ;; The minor mode version starts here: + (when orgpan-minor-mode-version + (select-window orgpan-org-window) + (orgpan-panel-minor-mode 1) + (add-hook 'post-command-hook 'orgpan-minor-post-command t))) + +(defun orgpan-minor-post-command () + (unless (and + ;; Check org window and buffer + (windowp orgpan-org-window) + (window-live-p orgpan-org-window) + (eq orgpan-org-window (selected-window)) + (derived-mode-p 'org-mode) + ;; Check panel window and buffer + (windowp orgpan-panel-window) + (window-live-p orgpan-panel-window) + (bufferp orgpan-panel-buffer) + (buffer-live-p orgpan-panel-buffer) + (eq (window-buffer orgpan-panel-window) orgpan-panel-buffer) + ;; Check minor mode + orgpan-panel-minor-mode) + (orgpan-delete-panel))) + +(define-minor-mode orgpan-panel-minor-mode + "Minor mode used in `org-mode' buffer when showing panel." + :keymap orgpan-mode-map + :lighter " PANEL" + :group 'orgpan + ) + + +(provide 'org-panel) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; org-panel.el ends here diff --git a/contrib/lisp/org-passwords.el b/contrib/lisp/org-passwords.el new file mode 100644 index 0000000..4ebd5a6 --- /dev/null +++ b/contrib/lisp/org-passwords.el @@ -0,0 +1,384 @@ +;;; org-passwords.el --- org derived mode for managing passwords + +;; Author: Jorge A. Alfaro-Murillo <jorge.alfaro-murillo@yale.edu> +;; Created: December 26, 2012 +;; Keywords: passwords, password + +;; This file is NOT part of GNU Emacs. +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file contains the code for managing your passwords with +;; Org-mode. It is part of org/contrib (see http://orgmode.org/). If +;; you want to contribute with development, or have a problem, do it +;; here: https://bitbucket.org/alfaromurillo/org-passwords.el + +;; A basic setup needs to indicate a passwords file, and a dictionary +;; for the random words: + +;; (require 'org-passwords) +;; (setq org-passwords-file "~/documents/passwords.gpg") +;; (setq org-passwords-random-words-dictionary "/etc/dictionaries-common/words") + +;; Basic usage: + +;; `M-x org-passwords' opens the passwords file in +;; `org-passwords-mode'. + +;; `M-x org-passwords-generate-password' generates a random string +;; of numbers, lowercase letters and uppercase letters. + +;; `C-u M-x org-passwords-generate-password' generates a random +;; string of numbers, lowercase letters, uppercase letters and +;; symbols. + +;; `M-x org-passwords-random-words' concatenates random words from +;; the dictionary defined by `org-passwords-random-words-dictionary' +;; into a string, each word separated by the string defined in +;; `org-passwords-random-words-separator'. + +;; `C-u M-x org-passwords-random-words' does the same as above, and +;; also makes substitutions according to +;; `org-passwords-random-words-substitutions'. + +;; It is also useful to set up keybindings for the functions +;; `org-passwords-copy-username', `org-passwords-copy-password' and +;; `org-passwords-open-url' in the `org-passwords-mode', to easily +;; make the passwords and usernames available to the facility for +;; pasting text of the window system (clipboard on X and MS-Windows, +;; pasteboard on Nextstep/Mac OS, etc.), without inserting them in the +;; kill-ring. You can set for example: + +;; (eval-after-load "org-passwords" +;; '(progn +;; (define-key org-passwords-mode-map +;; (kbd "C-c u") +;; 'org-passwords-copy-username) +;; (define-key org-passwords-mode-map +;; (kbd "C-c p") +;; 'org-passwords-copy-password) +;; (kbd "C-c o") +;; 'org-passwords-open-url))) + +;; Finally, to enter new passwords, you can use `org-capture' and a +;; minimal template like: + +;; ("p" "password" entry (file "~/documents/passwords.gpg") +;; "* %^{Title}\n %^{URL}p %^{USERNAME}p %^{PASSWORD}p") + +;; When asked for the password you can then call either +;; `org-passwords-generate-password' or `org-passwords-random-words'. +;; Be sure to enable recursive minibuffers to call those functions +;; from the minibuffer: + +;; (setq enable-recursive-minibuffers t) + +;;; Code: + +(require 'org) + +;;;###autoload +(define-derived-mode org-passwords-mode org-mode + "org-passwords-mode" + "Mode for storing passwords" + nil) + +(defgroup org-passwords nil + "Options for password management." + :group 'org) + +(defcustom org-passwords-password-property "PASSWORD" + "Name of the property for password entry." + :type 'string + :group 'org-passwords) + +(defcustom org-passwords-username-property "USERNAME" + "Name of the property for user name entry." + :type 'string + :group 'org-passwords) + +(defcustom org-passwords-url-property "URL" + "Name of the property for URL entry." + :type 'string + :group 'org-passwords) + +(defcustom org-passwords-file nil + "Default file name for the file that contains the passwords." + :type 'file + :group 'org-passwords) + +(defcustom org-passwords-time-opened "1 min" + "Time that the password file will remain open. It has to be a +string, a number followed by units." + :type 'str + :group 'org-passwords) + +(defcustom org-passwords-default-password-size "20" + "Default number of characters to use in +org-passwords-generate-password. It has to be a string." + :type 'str + :group 'org-passwords) + +(defcustom org-passwords-random-words-dictionary nil + "Default file name for the file that contains a dictionary of +words for `org-passwords-random-words'. Each non-empty line in +the file is considered a word." + :type 'file + :group 'org-passwords) + +(defcustom org-passwords-default-random-words-number "5" + "Default number of words to use in org-passwords-random-words. +It has to be a string." + :type 'str + :group 'org-passwords) + +(defvar org-passwords-random-words-separator "-" + "A string to separate words in `org-passwords-random-words'.") + +(defvar org-passwords-random-words-substitutions + '(("a" . "@") + ("e" . "3") + ("o" . "0")) +"A list of substitutions to be made with +`org-passwords-random-words' if it is called with +`universal-argument'. Each element is pair of +strings (SUBSTITUTE-THIS . BY-THIS).") + +(defun org-passwords-copy-password () + "Makes the password available to other programs. Puts the +password of the entry at the location of the cursor in the +facility for pasting text of the window system (clipboard on X +and MS-Windows, pasteboard on Nextstep/Mac OS, etc.), without +putting it in the kill ring." + (interactive) + (funcall interprogram-cut-function + (org-entry-get (point) + org-passwords-password-property))) + +(defun org-passwords-copy-username () + "Makes the password available to other programs. Puts the +username of the entry at the location of the cursor in the +facility for pasting text of the window system (clipboard on X +and MS-Windows, pasteboard on Nextstep/Mac OS, etc.), without +putting it in the kill ring." + (interactive) + (funcall interprogram-cut-function + (org-entry-get (point) + org-passwords-username-property + t))) + +(defun org-passwords-open-url () + "Browse the URL associated with the entry at the location of +the cursor." + (interactive) + (browse-url (org-entry-get (point) + org-passwords-url-property + t))) + +;;;###autoload +(defun org-passwords (&optional arg) + "Open the password file. Open the password file defined by the +variable `org-password-file' in read-only mode and kill that +buffer later according to the value of the variable +`org-passwords-time-opened'. It also adds the `org-password-file' +to the auto-mode-alist so that it is opened with its mode being +`org-passwords-mode'. + +With prefix arg ARG, the command does not set up a timer to kill the buffer. + +With a double prefix arg \\[universal-argument] \\[universal-argument], open the file for editing. +" + (interactive "P") + (if org-passwords-file + (progn + (add-to-list 'auto-mode-alist + (cons + (regexp-quote + (expand-file-name org-passwords-file)) + 'org-passwords-mode)) + (if (equal arg '(4)) + (find-file-read-only org-passwords-file) + (if (equal arg '(16)) + (find-file org-passwords-file) + (progn + (find-file-read-only org-passwords-file) + (org-passwords-set-up-kill-password-buffer))))) + (minibuffer-message "No default password file defined. Set the variable `org-password-file'."))) + +(defun org-passwords-set-up-kill-password-buffer () + (run-at-time org-passwords-time-opened + nil + '(lambda () + (if (get-file-buffer org-passwords-file) + (kill-buffer + (get-file-buffer org-passwords-file)))))) + +;;; Password generator + +;; Set random number seed from current time and pid. Otherwise +;; `random' gives the same results every time emacs restarts. +(random t) + +(defun org-passwords-generate-password (arg) + "Ask a number of characters and insert a password of that size. +Password has a random string of numbers, lowercase letters, and +uppercase letters. Argument ARG include symbols." + (interactive "P") + (let ((number-of-chars + (read-from-minibuffer + (concat "Number of characters (default " + org-passwords-default-password-size + "): ") + nil + nil + t + nil + org-passwords-default-password-size))) + (if arg + (insert (org-passwords-generate-password-with-symbols "" number-of-chars)) + (insert (org-passwords-generate-password-without-symbols "" number-of-chars))))) + +(defun org-passwords-generate-password-with-symbols (previous-string nums-of-chars) + "Return a string consisting of PREVIOUS-STRING and +NUMS-OF-CHARS random characters." + (if (eq nums-of-chars 0) previous-string + (org-passwords-generate-password-with-symbols + (concat previous-string + (char-to-string + ;; symbols, letters, numbers are from 33 to 126 + (+ (random (- 127 33)) 33))) + (1- nums-of-chars)))) + +(defun org-passwords-generate-password-without-symbols (previous-string nums-of-chars) + "Return string consisting of PREVIOUS-STRING and NUMS-OF-CHARS +random numbers, lowercase letters, and numbers." + (if (eq nums-of-chars 0) + previous-string + ; There are 10 numbers, 26 lowercase letters and 26 uppercase + ; letters. 10 + 26 + 26 = 62. The number characters go from 48 + ; to 57, the uppercase letters from 65 to 90, and the lowercase + ; from 97 to 122. The following makes each equally likely. + (let ((temp-value (random 62))) + (cond ((< temp-value 10) + ; If temp-value<10, then add a number + (org-passwords-generate-password-without-symbols + (concat previous-string + (char-to-string (+ 48 temp-value))) + (1- nums-of-chars))) + ((and (> temp-value 9) (< temp-value 36)) + ; If 9<temp-value<36, then add an uppercase letter + (org-passwords-generate-password-without-symbols + (concat previous-string + (char-to-string (+ 65 (- temp-value 10)))) + (1- nums-of-chars))) + ((> temp-value 35) + ; If temp-value>35, then add a lowecase letter + (org-passwords-generate-password-without-symbols + (concat previous-string + (char-to-string (+ 97 (- temp-value 36)))) + (1- nums-of-chars))))))) + +;;; Random words + +(defun org-passwords-random-words (arg) + "Ask for a number of words and inserts a sequence of that many +random words from the list in the file +`org-passwords-random-words-dictionary' separated by +`org-passwords-random-words-separator'. ARG make substitutions in +the words as defined by +`org-passwords-random-words-substitutions'." + (interactive "P") + (if org-passwords-random-words-dictionary + (let ((number-of-words + (read-from-minibuffer + (concat "Number of words (default " + org-passwords-default-random-words-number + "): ") + nil + nil + t + nil + org-passwords-default-random-words-number)) + (list-of-words + (with-temp-buffer + (insert-file-contents + org-passwords-random-words-dictionary) + (split-string (buffer-string) "\n" t)))) + (insert + (org-passwords-substitute + (org-passwords-random-words-attach-number-of-words + (nth (random (length list-of-words)) + list-of-words) + (1- number-of-words) + list-of-words + org-passwords-random-words-separator) + (if arg + org-passwords-random-words-substitutions + nil)))) + (minibuffer-message + "No default dictionary file defined. Set the variable `org-passwords-random-words-dictionary'."))) + +(defun org-passwords-random-words-attach-number-of-words + (previous-string number-of-words list-of-words separator) + "Returns a string consisting of PREVIOUS-STRING followed by a +succession of NUMBER-OF-WORDS random words from the list LIST-OF-WORDS +separated SEPARATOR." + (if (eq number-of-words 0) + previous-string + (org-passwords-random-words-attach-number-of-words + (concat previous-string + separator + (nth (random (length list-of-words)) list-of-words)) + (1- number-of-words) + list-of-words + separator))) + +(defun org-passwords-substitute (string-to-change list-of-substitutions) + "Substitutes each appearence in STRING-TO-CHANGE of the `car' of +each element of LIST-OF-SUBSTITUTIONS by the `cdr' of that +element. For example: + (org-passwords-substitute \"ab\" \'((\"a\" . \"b\") (\"b\" . \"c\"))) + => \"bc\" +Substitutions are made in order of the list, so for example: + (org-passwords-substitute \"ab\" \'((\"ab\" . \"c\") (\"b\" . \"d\"))) + => \"c\"" + (if list-of-substitutions + (concat (org-passwords-concat-this-with-string + (cdar list-of-substitutions) + (mapcar (lambda (x) + (org-passwords-substitute + x + (cdr list-of-substitutions))) + (split-string string-to-change + (caar list-of-substitutions))))) + string-to-change)) + +(defun org-passwords-concat-this-with-string (this list-of-strings) + "Put the string THIS in between every string in LIST-OF-STRINGS. For example: + (org-passwords-concat-this-with-string \"Here\" \'(\"First\" \"Second\" \"Third\")) + => \"FirstHereSencondHereThird\"" + (if (cdr list-of-strings) + (concat (car list-of-strings) + this + (org-passwords-concat-this-with-string + this + (cdr list-of-strings))) + (car list-of-strings))) + +(provide 'org-passwords) + +;;; org-passwords.el ends here diff --git a/contrib/lisp/org-registry.el b/contrib/lisp/org-registry.el new file mode 100644 index 0000000..402ce30 --- /dev/null +++ b/contrib/lisp/org-registry.el @@ -0,0 +1,272 @@ +;;; org-registry.el --- a registry for Org links +;; +;; Copyright 2007-2014 Bastien Guerry +;; +;; Emacs Lisp Archive Entry +;; Filename: org-registry.el +;; Version: 0.1a +;; Author: Bastien Guerry <bzg@gnu.org> +;; Maintainer: Bastien Guerry <bzg@gnu.org> +;; Keywords: org, wp, registry +;; Description: Shows Org files where the current buffer is linked +;; URL: http://www.cognition.ens.fr/~guerry/u/org-registry.el +;; +;; 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: +;; +;; This library add a registry to your Org setup. +;; +;; Org files are full of links inserted with `org-store-link'. This links +;; point to e-mail, webpages, files, dirs, info pages, man pages, etc. +;; Actually, they come from potentially *everywhere* since Org lets you +;; define your own storing/following functions. +;; +;; So, what if you are on a e-mail, webpage or whatever and want to know if +;; this buffer has already been linked to somewhere in your agenda files? +;; +;; This is were org-registry comes in handy. +;; +;; M-x org-registry-show will tell you the name of the file +;; C-u M-x org-registry-show will directly jump to the file +;; +;; In case there are several files where the link lives in: +;; +;; M-x org-registry-show will display them in a new window +;; C-u M-x org-registry-show will prompt for a file to visit +;; +;; Add this to your Org configuration: +;; +;; (require 'org-registry) +;; (org-registry-initialize) +;; +;; If you want to update the registry with newly inserted links in the +;; current buffer: M-x org-registry-update +;; +;; If you want this job to be done each time you save an Org buffer, +;; hook 'org-registry-update to the local 'after-save-hook in org-mode: +;; +;; (org-registry-insinuate) + +;;; Code: + +(eval-when-compile + (require 'cl)) + +(defgroup org-registry nil + "A registry for Org." + :group 'org) + +(defcustom org-registry-file + (concat (getenv "HOME") "/.org-registry.el") + "The Org registry file." + :group 'org-registry + :type 'file) + +(defcustom org-registry-find-file 'find-file-other-window + "How to find visit files." + :type 'function + :group 'org-registry) + +(defvar org-registry-alist nil + "An alist containing the Org registry.") + +;;;###autoload +(defun org-registry-show (&optional visit) + "Show Org files where there are links pointing to the current +buffer." + (interactive "P") + (org-registry-initialize) + (let* ((blink (or (org-remember-annotation) "")) + (link (when (string-match org-bracket-link-regexp blink) + (match-string-no-properties 1 blink))) + (desc (or (and (string-match org-bracket-link-regexp blink) + (match-string-no-properties 3 blink)) "No description")) + (files (org-registry-assoc-all link)) + file point selection tmphist) + (cond ((and files visit) + ;; result(s) to visit + (cond ((< 1 (length files)) + ;; more than one result + (setq tmphist (mapcar (lambda(entry) + (format "%s (%d) [%s]" + (nth 3 entry) ; file + (nth 2 entry) ; point + (nth 1 entry))) files)) + (setq selection (completing-read "File: " tmphist + nil t nil 'tmphist)) + (string-match "\\(.+\\) (\\([0-9]+\\))" selection) + (setq file (match-string 1 selection)) + (setq point (string-to-number (match-string 2 selection)))) + ((eq 1 (length files)) + ;; just one result + (setq file (nth 3 (car files))) + (setq point (nth 2 (car files))))) + ;; visit the (selected) file + (funcall org-registry-find-file file) + (goto-char point) + (unless (org-before-first-heading-p) + (org-show-context))) + ((and files (not visit)) + ;; result(s) to display + (cond ((eq 1 (length files)) + ;; show one file + (message "Link in file %s (%d) [%s]" + (nth 3 (car files)) + (nth 2 (car files)) + (nth 1 (car files)))) + (t (org-registry-display-files files link)))) + (t (message "No link to this in org-agenda-files"))))) + +(defun org-registry-display-files (files link) + "Display files in a separate window." + (switch-to-buffer-other-window + (get-buffer-create " *Org registry info*")) + (erase-buffer) + (insert (format "Files pointing to %s:\n\n" link)) + (let (file) + (while (setq file (pop files)) + (insert (format "%s (%d) [%s]\n" (nth 3 file) + (nth 2 file) (nth 1 file))))) + (shrink-window-if-larger-than-buffer) + (other-window 1)) + +(defun org-registry-assoc-all (link &optional registry) + "Return all associated entries of LINK in the registry." + (org-registry-find-all + (lambda (entry) (string= link (car entry))) + registry)) + +(defun org-registry-find-all (test &optional registry) + "Return all entries satisfying `test' in the registry." + (delq nil + (mapcar + (lambda (x) (and (funcall test x) x)) + (or registry org-registry-alist)))) + +;;;###autoload +(defun org-registry-visit () + "If an Org file contains a link to the current location, visit +this file." + (interactive) + (org-registry-show t)) + +;;;###autoload +(defun org-registry-initialize (&optional from-scratch) + "Initialize `org-registry-alist'. +If FROM-SCRATCH is non-nil or the registry does not exist yet, +create a new registry from scratch and eval it. If the registry +exists, eval `org-registry-file' and make it the new value for +`org-registry-alist'." + (interactive "P") + (if (or from-scratch (not (file-exists-p org-registry-file))) + ;; create a new registry + (let ((files org-agenda-files) file) + (while (setq file (pop files)) + (setq file (expand-file-name file)) + (mapc (lambda (entry) + (add-to-list 'org-registry-alist entry)) + (org-registry-get-entries file))) + (when from-scratch + (org-registry-create org-registry-alist))) + ;; eval the registry file + (with-temp-buffer + (insert-file-contents org-registry-file) + (eval-buffer)))) + +;;;###autoload +(defun org-registry-insinuate () + "Call `org-registry-update' after saving in Org-mode. +Use with caution. This could slow down things a bit." + (interactive) + (add-hook 'org-mode-hook + (lambda() (add-hook 'after-save-hook + 'org-registry-update t t)))) + +(defun org-registry-get-entries (file) + "List Org links in FILE that will be put in the registry." + (let (bufstr result) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (while (re-search-forward org-angle-link-re nil t) + (let* ((point (match-beginning 0)) + (link (match-string-no-properties 0)) + (desc (match-string-no-properties 0))) + (add-to-list 'result (list link desc point file)))) + (goto-char (point-min)) + (while (re-search-forward org-bracket-link-regexp nil t) + (let* ((point (match-beginning 0)) + (link (match-string-no-properties 1)) + (desc (or (match-string-no-properties 3) "No description"))) + (add-to-list 'result (list link desc point file))))) + ;; return the list of new entries + result)) + +;;;###autoload +(defun org-registry-update () + "Update the registry for the current Org file." + (interactive) + (unless (eq major-mode 'org-mode) (error "Not in org-mode")) + (let* ((from-file (expand-file-name (buffer-file-name))) + (new-entries (org-registry-get-entries from-file))) + (with-temp-buffer + (unless (file-exists-p org-registry-file) + (org-registry-initialize t)) + (find-file org-registry-file) + (goto-char (point-min)) + (while (re-search-forward (concat from-file "\")$") nil t) + (let ((end (1+ (match-end 0))) + (beg (progn (re-search-backward "^(\"" nil t) + (match-beginning 0)))) + (delete-region beg end))) + (goto-char (point-min)) + (re-search-forward "^(\"" nil t) + (goto-char (match-beginning 0)) + (mapc (lambda (elem) + (insert (with-output-to-string (prin1 elem)) "\n")) + new-entries) + (save-buffer) + (kill-buffer (current-buffer))) + (message (format "Org registry updated for %s" + (file-name-nondirectory from-file))))) + +(defun org-registry-create (entries) + "Create `org-registry-file' with ENTRIES." + (let (entry) + (with-temp-buffer + (find-file org-registry-file) + (erase-buffer) + (insert + (with-output-to-string + (princ ";; -*- emacs-lisp -*-\n") + (princ ";; Org registry\n") + (princ ";; You shouldn't try to modify this buffer manually\n\n") + (princ "(setq org-registry-alist\n'(\n") + (while entries + (when (setq entry (pop entries)) + (prin1 entry) + (princ "\n"))) + (princ "))\n"))) + (save-buffer) + (kill-buffer (current-buffer)))) + (message "Org registry created")) + +(provide 'org-registry) + +;;; User Options, Variables + +;;; org-registry.el ends here diff --git a/contrib/lisp/org-screen.el b/contrib/lisp/org-screen.el new file mode 100644 index 0000000..6b870f2 --- /dev/null +++ b/contrib/lisp/org-screen.el @@ -0,0 +1,106 @@ +;;; org-screen.el --- Integreate Org-mode with screen. + +;; Copyright (c) 2008-2014 Andrew Hyatt +;; +;; Author: Andrew Hyatt <ahyatt at gmail dot com> +;; Maintainer: Carsten Dominik <carsten at orgmode dot org> +;; +;; This file is not yet part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; This file contains functionality to integrate screen and org-mode. +;; When using org-mode, it is often useful to take tasks that have +;; some command-line work associated with them, and associate them +;; with a screen session. Screen is used rather than a direct +;; terminal to facilitate portability of the resulting session. +;; +;; To use screen in org, in your .emacs file, simply put this file in +;; a directory in your load-path and write: +;; +;; (require 'org-screen) +;; +;; When have a task and want to start some command-line activity +;; associated with that task, go to the end of your item and type: +;; +;; M-x org-screen +;; +;; This will prompt you for a name of a screen session. Type in a +;; name and it will insert a link into your org file at your current +;; location. +;; +;; When you want to visit the link, go to the link and type C-c C-o to +;; open the link. +;; +;; You may want to get rid of the constant queries about whether you +;; really want to execute lisp code. Do so by adding to your .emacs: +;; +;; (setq org-confirm-elisp-link-function nil) + +(require 'term) +(require 'org) + +(defcustom org-screen-program-name "/usr/bin/screen" + "Full location of the screen executable." + :group 'org-screen + :type 'string) + +(defun org-screen (name) + "Start a screen session with name" + (interactive "MScreen name: ") + (save-excursion + (org-screen-helper name "-S")) + (insert-string (concat "[[screen:" name "]]"))) + +(defun org-screen-buffer-name (name) + "Returns the buffer name corresponding to the screen name given." + (concat "*screen " name "*")) + +(defun org-screen-helper (name arg) + "This method will create a screen session with a specified name +and taking the specified screen arguments. Much of this function +is copied from ansi-term method." + + ;; Pick the name of the new buffer. + (let ((term-ansi-buffer-name + (generate-new-buffer-name + (org-screen-buffer-name name)))) + (setq term-ansi-buffer-name + (term-ansi-make-term + term-ansi-buffer-name org-screen-program-name nil arg name)) + (set-buffer term-ansi-buffer-name) + (term-mode) + (term-char-mode) + (term-set-escape-char ?\C-x) + term-ansi-buffer-name)) + +(defun org-screen-goto (name) + "Open the screen with the specified name in the window" + (interactive "MScreen name: ") + (let ((screen-buffer-name (org-screen-buffer-name name))) + (if (member screen-buffer-name + (mapcar 'buffer-name (buffer-list))) + (org-pop-to-buffer-same-window screen-buffer-name) + (org-pop-to-buffer-same-window (org-screen-helper name "-dr"))))) + +(if org-link-abbrev-alist + (add-to-list 'org-link-abbrev-alist + '("screen" . "elisp:(org-screen-goto \"%s\")")) + (setq org-link-abbrev-alist + '(("screen" . "elisp:(org-screen-goto \"%s\")")))) + +(provide 'org-screen) diff --git a/contrib/lisp/org-screenshot.el b/contrib/lisp/org-screenshot.el new file mode 100644 index 0000000..1cf6911 --- /dev/null +++ b/contrib/lisp/org-screenshot.el @@ -0,0 +1,529 @@ +;;; org-screenshot.el --- Take and manage screenshots in Org-mode files +;; +;; Copyright (C) 2009-2017 Free Software Foundation, Inc. +;; +;; Author: Max Mikhanosha <max@openchat.com> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 8.0 +;; +;; Released under the GNU General Public License version 3 +;; see: http://www.gnu.org/licenses/gpl-3.0.html +;; +;; This file is not part of GNU Emacs. +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; NOTE: This library requires external screenshot taking executable "scrot", +;; which is available as a package from all major Linux distribution. If your +;; distribution does not have it, source can be found at: +;; +;; http://freecode.com/projects/scrot +;; +;; org-screenshot.el have been tested with scrot version 0.8. +;; +;; Usage: +;; +;; (require 'org-screenshot) +;; +;; Available commands with default bindings +;; +;; `org-screenshot-take' C-c M-s M-t and C-c M-s M-s +;; +;; Take the screenshot, C-u argument delays 1 second, double C-u 2 seconds +;; triple C-u 3 seconds, and subsequent C-u add 2 seconds to the delay. +;; +;; Screenshot area is selected with the mouse, or left-click on the window +;; for an entire window. +;; +;; `org-screenshot-rotate-prev' C-c M-s M-p and C-c M-s C-p +;; +;; Rotate screenshot before the point to one before it (sorted by date) +;; +;; `org-screenshot-rotate-next' C-c M-s M-n and C-c M-s C-n +;; +;; Rotate screenshot before the point to one after it +;; +;; `org-screenshot-show-unused' C-c M-s M-u and C-c M-s u +;; +;; Open dired buffer with screenshots that are not used in current +;; Org buffer marked +;; +;; The screenshot take and rotate commands will update the inline images +;; if they are already shown, if you are inserting first screenshot in the Org +;; Buffer (and there are no other images shown), you need to manually display +;; inline images with C-c C-x C-v +;; +;; Screenshot take and rotate commands offer user to continue by by using single +;; keys, in a manner similar to to "repeat-char" of keyboard macros, user can +;; continue rotating screenshots by pressing just the last key of the binding +;; +;; For example: C-c M-s M-t creates the screenshot and then user can +;; repeatedly press M-p or M-n to rotate it back and forth with +;; previously taken ones. +;; + +(require 'org) +(require 'dired) + +(defgroup org-screenshot nil + "Options for taking and managing screen-shots" + :group 'org-link) + +(defcustom org-screenshot-image-directory "./images/" + "Directory in which screenshot image files will be stored, it +be automatically created if it does't already exist." + :type 'string + :group 'org-screenshot) + +(defcustom org-screenshot-file-name-format "screenshot-%2.2d.png" + "The string used to generate screenshot file name. + +Any %d format string recipe will be expanded with `format' +function with the argument of a screenshot sequence number. + +A sequence like %XXXX will be replaced with string of the same +length as there are X's, consisting of random characters in the +range of [A-Za-z]." + :type 'string + :group 'org-screenshot) + +(defcustom org-screenshot-max-tries 200 + "Number of times we will try to generate generate filename that +does not exist. With default `org-screenshot-name-format' its the +limit for number of screenshots, before `org-screenshot-take' is +unable to come up with a unique name." + :type 'integer + :group 'org-screenshot) + +(defvar org-screenshot-map (make-sparse-keymap) + "Map for OrgMode screenshot related commands") + +;; prefix +(org-defkey org-mode-map (kbd "C-c M-s") org-screenshot-map) + +;; Mnemonic is Control-C Meta "Screenshot" "Take" +(org-defkey org-screenshot-map (kbd "M-t") 'org-screenshot-take) +(org-defkey org-screenshot-map (kbd "M-s") 'org-screenshot-take) + +;; No reason to require meta key, since its our own keymap +(org-defkey org-screenshot-map "s" 'org-screenshot-take) +(org-defkey org-screenshot-map "t" 'org-screenshot-take) + +;; Rotations, the fast rotation user hint, would prefer the modifier +;; used by the original command that started the rotation +(org-defkey org-screenshot-map (kbd "M-n") 'org-screenshot-rotate-next) +(org-defkey org-screenshot-map (kbd "M-p") 'org-screenshot-rotate-prev) +(org-defkey org-screenshot-map (kbd "C-n") 'org-screenshot-rotate-next) +(org-defkey org-screenshot-map (kbd "C-p") 'org-screenshot-rotate-prev) + +;; Show unused image files in Dired +(org-defkey org-screenshot-map (kbd "M-u") 'org-screenshot-show-unused) +(org-defkey org-screenshot-map (kbd "u") 'org-screenshot-show-unused) + + +(random t) + +(defun org-screenshot-random-string (length) + "Generate a random string of LENGTH consisting of random upper +case and lower case letters." + (let ((name (make-string length ?x))) + (dotimes (i length) + (let ((n (random 52))) + (aset name i (if (< n 26) + (+ ?a n) + (+ ?A n -26))))) + name)) + +(defvar org-screenshot-process nil + "Currently running screenshot process") + +(defvar org-screenshot-directory-seq-numbers (make-hash-table :test 'equal)) + +(defun org-screenshot-update-seq-number (directory &optional reset) + "Set `org-screenshot-file-name-format' sequence number for the directory. +When RESET is NIL, increments the number stored, otherwise sets +RESET as a new number. Intended to be called if screenshot was +successful. Updating of sequence number is done in two steps, so +aborted/canceled screenshot attempts don't increase the number" + + (setq directory (file-name-as-directory directory)) + (puthash directory (if reset + (if (numberp reset) reset 1) + (1+ (gethash directory + org-screenshot-directory-seq-numbers + 0))) + org-screenshot-directory-seq-numbers)) + +(defun org-screenshot-generate-file-name (directory) + "Use `org-screenshot-name-format' to generate new screenshot +file name for a specific directory. Keeps re-generating name if +it already exists, up to `org-screenshot-max-tries' +times. Returns just the file, without directory part" + (setq directory (file-name-as-directory directory)) + (when (file-exists-p directory) + (let ((tries 0) + name + had-seq + (case-fold-search nil)) + (while (and (< tries org-screenshot-max-tries) + (not name)) + (incf tries) + (let ((tmp org-screenshot-file-name-format) + (seq-re "%[-0-9.]*d") + (rand-re "%X+")) + (when (string-match seq-re tmp) + (let ((seq (gethash + directory + org-screenshot-directory-seq-numbers 1))) + (setq tmp + (replace-regexp-in-string + seq-re (format (match-string 0 tmp) seq) + tmp) + had-seq t))) + (when (string-match rand-re tmp) + (setq tmp + (replace-regexp-in-string + rand-re (org-screenshot-random-string + (1- (length (match-string 0 tmp)))) + tmp t))) + (let ((fullname (concat directory tmp))) + (if (file-exists-p fullname) + (when had-seq (org-screenshot-update-seq-number directory)) + (setq name tmp))))) + name))) + +(defun org-screenshot-image-directory () + "Return the `org-screenshot-image-directory', ensuring there is +trailing slash, and that it exists" + (let ((dir (file-name-as-directory org-screenshot-image-directory))) + (if (file-exists-p dir) + dir + (make-directory dir t) + dir))) + +(defvar org-screenshot-last-file nil + "File name of the last taken or rotated screenshot file, +without directory") + +(defun org-screenshot-process-done (process event file + orig-buffer + orig-delay + orig-event) + "Called when \"scrot\" process exits. PROCESS and EVENT are +same arguments as in `set-process-sentinel'. ORIG-BUFFER, +ORIG-DELAY and ORIG-EVENT are Org Buffer, the screenshot delay +used, and LAST-INPUT-EVENT values from when screenshot was +initiated. +" + (setq org-screenshot-process nil) + (with-current-buffer (process-buffer process) + (if (not (equal event "finished\n")) + (progn + (insert event) + (cond ((save-excursion + (goto-char (point-min)) + (re-search-forward "Key was pressed" nil t)) + (ding) + (message "Key was pressed, screenshot aborted")) + (t + (display-buffer (process-buffer process)) + (message "Error running \"scrot\" program") + (ding)))) + (with-current-buffer orig-buffer + (let ((link (format "[[file:%s]]" file))) + (setq org-screenshot-last-file (file-name-nondirectory file)) + (let ((beg (point))) + (insert link) + (when org-inline-image-overlays + (org-display-inline-images nil t beg (point)))) + (unless (< orig-delay 3) + (ding)) + (org-screenshot-rotate-continue t orig-event)))))) + + +;;;###autoload +(defun org-screenshot-take (&optional delay) + "Take a screenshot and insert link to it at point, if image +display is already on (see \\[org-toggle-inline-images]) +screenshot will be displayed as an image + +Screen area for the screenshot is selected with the mouse, left +click on a window screenshots that window, while left click and +drag selects a region. Pressing any key cancels the screen shot + +With `C-u' universal argument waits one second after target is +selected before taking the screenshot. With double `C-u' wait two +seconds. + +With triple `C-u' wait 3 seconds, and also rings the bell when +screenshot is done, any more `C-u' after that increases delay by +2 seconds +" + (interactive "P") + + ;; probably easier way to count number of C-u C-u out there + (setq delay + (cond ((null delay) 0) + ((integerp delay) delay) + ((and (consp delay) + (integerp (car delay)) + (plusp (car delay))) + (let ((num 1) + (limit (car delay)) + (cnt 0)) + (while (< num limit) + (setq num (* num 4) + cnt (+ cnt (if (< cnt 3) 1 2)))) + cnt)) + (t (error "Invald delay")))) + (when (and org-screenshot-process + (member (process-status org-screenshot-process) + '(run stop))) + (error "scrot process is still running")) + (let* ((name (org-screenshot-generate-file-name (org-screenshot-image-directory))) + (file (format "%s%s" (org-screenshot-image-directory) + name)) + (path (expand-file-name file))) + (when (get-buffer "*scrot*") + (with-current-buffer (get-buffer "*scrot*") + (erase-buffer))) + (setq org-screenshot-process + (or + (apply 'start-process + (append + (list "scrot" "*scrot*" "scrot" "-s" path) + (when (plusp delay) + (list "-d" (format "%d" delay))))) + (error "Unable to start scrot process"))) + (when org-screenshot-process + (if (plusp delay) + (message "Click on a window, or select a rectangle (delay is %d sec)..." + delay) + (message "Click on a window, or select a rectangle...")) + (set-process-sentinel + org-screenshot-process + `(lambda (process event) + (org-screenshot-process-done + process event ,file ,(current-buffer) ,delay ',last-input-event)))))) + +(defvar org-screenshot-file-list nil + "List of files in `org-screenshot-image-directory' used by +`org-screenshot-rotate-prev' and `org-screenshot-rotate-next'") + +(defvar org-screenshot-rotation-index -1) + +(make-variable-buffer-local 'org-screenshot-file-list) +(make-variable-buffer-local 'org-screenshot-rotation-index) + +(defun org-screenshot-rotation-init (lastfile) + "Initialize variable `org-screenshot-file-list' variabel with +the list of PNG files in `org-screenshot-image-directory' sorted +by most recent first" + (setq + org-screenshot-rotation-index -1 + org-screenshot-file-list + (let ((files (directory-files org-screenshot-image-directory + t (image-file-name-regexp) t))) + (mapcar 'file-name-nondirectory + (sort files + (lambda (file1 file2) + (let ((mtime1 (nth 5 (file-attributes file1))) + (mtime2 (nth 5 (file-attributes file2)))) + (setq mtime1 (+ (ash (first mtime1) 16) + (second mtime1))) + (setq mtime2 (+ (ash (first mtime2) 16) + (second mtime2))) + (> mtime1 mtime2))))))) + (let ((n -1) (list org-screenshot-file-list)) + (while (and list (not (equal (pop list) lastfile))) + (incf n)) + (setq org-screenshot-rotation-index n))) + +(defun org-screenshot-do-rotate (dir from-continue-rotating) + "Rotate last screenshot with one of the previously taken +screenshots from the same directory. If DIR is negative, in the +other direction" + (setq org-screenshot-last-file nil) + (let* ((ourdir (file-name-as-directory (org-screenshot-image-directory))) + done + (link-re + ;; taken from `org-display-inline-images' + (concat "\\[\\[\\(\\(file:\\)\\|\\([./~]\\)\\)\\([^]\n]+?" + (substring (image-file-name-regexp) 0 -2) + "\\)\\]")) + newfile oldfile) + (save-excursion + ;; Search for link to image file in the same directory before the point + (while (not done) + (if (not (re-search-backward link-re (point-min) t)) + (error "Unable to find link to image from %S directory before point" ourdir) + (let ((file (concat (or (match-string 3) "") (match-string 4)))) + (when (equal (file-name-directory file) + ourdir) + (setq done t + oldfile (file-name-nondirectory file)))))) + (when (or (null org-screenshot-file-list) + (and (not from-continue-rotating) + (not (member last-command + '(org-screenshot-rotate-prev + org-screenshot-rotate-next))))) + (org-screenshot-rotation-init oldfile)) + (unless (> (length org-screenshot-file-list) 1) + (error "Can't rotate a single image file")) + (replace-match "" nil nil nil 1) + + (setq org-screenshot-rotation-index + (mod (+ org-screenshot-rotation-index dir) + (length org-screenshot-file-list)) + newfile (nth org-screenshot-rotation-index + org-screenshot-file-list)) + ;; in case we started rotating from the file we just inserted, + ;; advance one more time + (when (equal oldfile newfile) + (setq org-screenshot-rotation-index + (mod (+ org-screenshot-rotation-index (if (plusp dir) 1 -1)) + (length org-screenshot-file-list)) + newfile (nth org-screenshot-rotation-index + org-screenshot-file-list))) + (replace-match (concat "file:" ourdir + newfile) + t t nil 4)) + ;; out of save-excursion + (setq org-screenshot-last-file newfile) + (when org-inline-image-overlays + (org-display-inline-images nil t (match-beginning 0) (point))))) + +;;;###autoload +(defun org-screenshot-rotate-prev (dir) + "Rotate last screenshot with one of the previously taken +screenshots from the same directory. If DIR is negative, rotate +in the other direction" + (interactive "p") + (org-screenshot-do-rotate dir nil) + (when org-screenshot-last-file + (org-screenshot-rotate-continue nil nil))) + +;;;###autoload +(defun org-screenshot-rotate-next (dir) + "Rotate last screenshot with one of the previously taken +screenshots from the same directory. If DIR is negative, rotate +in the other direction" + (interactive "p") + (org-screenshot-do-rotate (- dir) nil) + (when org-screenshot-last-file + (org-screenshot-rotate-continue nil nil))) + +(defun org-screenshot-prefer-same-modifiers (list event) + (if (not (eventp nil)) (car list) + (let (ret (keys list)) + (while (and (null ret) keys) + (let ((key (car keys))) + (if (and (= 1 (length key)) + (equal (event-modifiers event) + (event-modifiers (elt key 0)))) + (setq ret (car keys)) + (setq keys (cdr keys))))) + (or ret (car list))))) + +(defun org-screenshot-rotate-continue (from-take-screenshot orig-event) + "Display the message with the name of the last changed +image-file and inform user that they can rotate by pressing keys +bound to `org-screenshot-rotate-next' and +`org-screenshot-rotate-prev' in `org-screenshot-map' + +This works similarly to `kmacro-end-or-call-macro' so that user +can press a long key sequence to invoke the first command, and +then uses single keys to rotate, until unregognized key is +entered, at which point event will be unread" + + (let* ((event (if from-take-screenshot orig-event + last-input-event)) + done + (prev-key + (org-screenshot-prefer-same-modifiers + (where-is-internal 'org-screenshot-rotate-prev + org-screenshot-map nil) + event)) + (next-key + (org-screenshot-prefer-same-modifiers + (where-is-internal 'org-screenshot-rotate-next + org-screenshot-map nil) + event)) + prev-key-str next-key-str) + (when (and (= (length prev-key) 1) + (= (length next-key) 1)) + (setq + prev-key-str (format-kbd-macro prev-key nil) + next-key-str (format-kbd-macro next-key nil) + prev-key (elt prev-key 0) + next-key (elt next-key 0)) + (while (not done) + (message "%S - '%s' and '%s' to rotate" + org-screenshot-last-file prev-key-str next-key-str) + (setq event (read-event)) + (cond ((equal event prev-key) + (clear-this-command-keys t) + (org-screenshot-do-rotate 1 t) + (setq last-input-event nil)) + ((equal event next-key) + (clear-this-command-keys t) + (org-screenshot-do-rotate -1 t) + (setq last-input-event nil)) + (t (setq done t)))) + (when last-input-event + (clear-this-command-keys t) + (setq unread-command-events (list last-input-event)))))) + +;;;###autoload +(defun org-screenshot-show-unused () + "Open A Dired buffer with unused screenshots marked" + (interactive) + (let ((files-in-buffer) + dired-buffer + had-any + (image-re (image-file-name-regexp)) + beg end) + (save-excursion + (save-restriction + (widen) + (setq beg (or beg (point-min)) end (or end (point-max))) + (goto-char beg) + (let ((re (concat "\\[\\[\\(\\(file:\\)\\|\\([./~]\\)\\)\\([^]\n]+?" + (substring (image-file-name-regexp) 0 -2) + "\\)\\]")) + (case-fold-search t) + old file ov img type attrwidth width) + (while (re-search-forward re end t) + (setq file (concat (or (match-string 3) "") (match-string 4))) + (when (and (file-exists-p file) + (equal (file-name-directory file) + (org-screenshot-image-directory))) + (push (file-name-nondirectory file) + files-in-buffer)))))) + (setq dired-buffer (dired-noselect (org-screenshot-image-directory))) + (with-current-buffer dired-buffer + (dired-unmark-all-files ?\r) + (dired-mark-if + (let ((file (dired-get-filename 'no-dir t))) + (and file (string-match image-re file) + (not (member file files-in-buffer)) + (setq had-any t))) + "Unused screenshot")) + (when had-any (pop-to-buffer dired-buffer)))) + +(provide 'org-screenshot) diff --git a/contrib/lisp/org-secretary.el b/contrib/lisp/org-secretary.el new file mode 100644 index 0000000..babfb75 --- /dev/null +++ b/contrib/lisp/org-secretary.el @@ -0,0 +1,230 @@ +;;; org-secretary.el --- Team management with org-mode +;; Copyright (C) 2010-2014 Juan Reyero +;; +;; Author: Juan Reyero <juan _at_ juanreyero _dot_ com> +;; Keywords: outlines, tasks, team, management +;; Homepage: http://juanreyero.com/article/emacs/org-teams.html +;; Version: 0.02 +;; +;; This file is not part of GNU Emacs. +;; +;; This file 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 file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; This module implements helper functions for team management. It +;; makes it easy to keep track of the work of several people. It +;; keeps context (with whom and where you are) and allows you to use +;; it to metadata to your notes, and to query the tasks associated +;; with the people you are with and the place. +;; +;; See http://juanreyero.com/article/emacs/org-teams.html for a full +;; explanation and configuration instructions. +;; +;;; Configuration +;;;;;;;;;;;;;;;;; +;; +;; In short; your todos use the TODO keyword, your team's use TASK. +;; Your org-todo-keywords should look something like this: +;; +;; (setq org-todo-keywords +;; '((sequence "TODO(t)" "|" "DONE(d)" "CANCELLED(c)") +;; (sequence "TASK(f)" "|" "DONE(d)") +;; (sequence "MAYBE(m)" "|" "CANCELLED(c)"))) +;; +;; It helps to distinguish them by color, like this: +;; +;; (setq org-todo-keyword-faces +;; '(("TODO" . (:foreground "DarkOrange1" :weight bold)) +;; ("MAYBE" . (:foreground "sea green")) +;; ("DONE" . (:foreground "light sea green")) +;; ("CANCELLED" . (:foreground "forest green")) +;; ("TASK" . (:foreground "blue")))) +;; +;; If you want to keep track of stuck projects you should tag your +;; projects with :prj:, and define: +;; +;; (setq org-tags-exclude-from-inheritance '("prj") +;; org-stuck-projects '("+prj/-MAYBE-DONE" +;; ("TODO" "TASK") ())) +;; +;; Define a tag that marks TASK entries as yours: +;; +;; (setq org-sec-me "juanre") +;; +;; Finally, you add the special views to your org-agenda-custom-commands: +;; +;; (setq org-agenda-custom-commands +;; '(("h" "Work todos" tags-todo +;; "-personal-doat={.+}-dowith={.+}/!-TASK" +;; ((org-agenda-todo-ignore-scheduled t))) +;; ("H" "All work todos" tags-todo "-personal/!-TASK-MAYBE" +;; ((org-agenda-todo-ignore-scheduled nil))) +;; ("A" "Work todos with doat or dowith" tags-todo +;; "-personal+doat={.+}|dowith={.+}/!-TASK" +;; ((org-agenda-todo-ignore-scheduled nil))) +;; ("j" "TODO dowith and TASK with" +;; ((org-sec-with-view "TODO dowith") +;; (org-sec-where-view "TODO doat") +;; (org-sec-assigned-with-view "TASK with") +;; (org-sec-stuck-with-view "STUCK with"))) +;; ("J" "Interactive TODO dowith and TASK with" +;; ((org-sec-who-view "TODO dowith"))))) +;; +;;; Usage +;;;;;;;;; +;; +;; Do C-c w to say with whom you are meeting (a space-separated list +;; of names). Maybe do also C-c W to say where you are. Then do C-c a +;; j to see: +;; - Todo items defined with TODO (ie, mine) in which the +;; =dowith= property matches any of the people with me. +;; - Todo items defined with TODO in which the =doat= property +;; matches my current location. +;; - Todo items defined with TASK that are tagged with the name +;; of any of the people with me (this is, assigned to them). +;; - Stuck projects tagged with the name of the people with me. +;; +;; Use C-c j to add meta-data with the people with me, the +;; location and the time to entries. + +(require 'org) + +(defvar org-sec-me nil + "Tag that defines TASK todo entries associated to me") + +(defvar org-sec-with nil + "Value of the :with: property when doing an + org-sec-tag-entry. Change it with org-sec-set-with, + set to C-c w. Defaults to org-sec-me") + +(defvar org-sec-where "" + "Value of the :at: property when doing an + org-sec-tag-entry. Change it with org-sec-set-with, + set to C-c W") + +(defvar org-sec-with-history '() + "History list of :with: properties") + +(defvar org-sec-where-history '() + "History list of :where: properties") + +(defun org-sec-set-with () + "Changes the value of the org-sec-with variable for use in the + next call of org-sec-tag-entry. Leave it empty to default to + org-sec-me (you)." + (interactive) + (setq org-sec-with (let ((w (read-string "With: " nil + 'org-sec-with-history ""))) + (if (string= w "") + nil + w)))) +(global-set-key "\C-cw" 'org-sec-set-with) + +(defun org-sec-set-where () + "Changes the value of the org-sec-where variable for use + in the next call of org-sec-tag-entry." + (interactive) + (setq org-sec-where + (read-string "Where: " nil + 'org-sec-where-history ""))) +(global-set-key "\C-cW" 'org-sec-set-where) + +(defun org-sec-set-dowith () + "Sets the value of the dowith property." + (interactive) + (let ((do-with + (read-string "Do with: " + nil 'org-sec-dowith-history ""))) + (unless (string= do-with "") + (org-entry-put nil "dowith" do-with)))) +(global-set-key "\C-cd" 'org-sec-set-dowith) + +(defun org-sec-set-doat () + "Sets the value of the doat property." + (interactive) + (let ((do-at (read-string "Do at: " + nil 'org-sec-doat-history ""))) + (unless (string= do-at "") + (org-entry-put nil "doat" do-at)))) +(global-set-key "\C-cD" 'org-sec-set-doat) + +(defun org-sec-tag-entry () + "Adds a :with: property with the value of org-sec-with if + defined, an :at: property with the value of org-sec-where + if defined, and an :on: property with the current time." + (interactive) + (save-excursion + (org-entry-put nil "on" (format-time-string + (org-time-stamp-format 'long) + (current-time))) + (unless (string= org-sec-where "") + (org-entry-put nil "at" org-sec-where)) + (if org-sec-with + (org-entry-put nil "with" org-sec-with)))) +(global-set-key "\C-cj" 'org-sec-tag-entry) + +(defun join (lst sep &optional pre post) + (mapconcat (function (lambda (x) (concat pre x post))) lst sep)) + +(defun org-sec-get-with () + (if org-sec-with + org-sec-with + org-sec-me)) + +(defun org-sec-with-view (par &optional who) + "Select tasks marked as dowith=who, where who + defaults to the value of org-sec-with." + (org-tags-view '(4) (join (split-string (if who + who + (org-sec-get-with))) + "|" "dowith=\"" "\""))) + +(defun org-sec-where-view (par) + "Select tasks marked as doat=org-sec-where." + (org-tags-view '(4) (concat "doat={" org-sec-where "}"))) + +(defun org-sec-assigned-with-view (par &optional who) + "Select tasks assigned to who, by default org-sec-with." + (org-tags-view '(4) + (concat (join (split-string (if who + who + (org-sec-get-with))) + "|") + "/TASK"))) + +(defun org-sec-stuck-with-view (par &optional who) + "Select stuck projects assigned to who, by default + org-sec-with." + (let ((org-stuck-projects + `(,(concat "+prj+" + (join (split-string (if who + who + (org-sec-get-with))) "|") + "/-MAYBE-DONE") + ("TODO" "TASK") ()))) + (org-agenda-list-stuck-projects))) + +(defun org-sec-who-view (par) + "Builds agenda for a given user. Queried. " + (let ((who (read-string "Build todo for user/tag: " + "" "" ""))) + (org-sec-with-view "TODO dowith" who) + (org-sec-assigned-with-view "TASK with" who) + (org-sec-stuck-with-view "STUCK with" who))) + +(provide 'org-secretary) + +;;; org-secretary.el ends here diff --git a/contrib/lisp/org-static-mathjax.el b/contrib/lisp/org-static-mathjax.el new file mode 100644 index 0000000..ac13ee2 --- /dev/null +++ b/contrib/lisp/org-static-mathjax.el @@ -0,0 +1,187 @@ +;;; org-static-mathjax.el --- Muse-like tags in Org-mode +;; +;; Author: Jan Böker <jan dot boecker at jboecker dot de> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; This elisp code integrates Static MathJax into the +;; HTML export process of Org-mode. +;; +;; The supporting files for this package are in contrib/scripts/staticmathjax +;; Please read the README.org file in that directory for more information. + +;; To use it, evaluate it on startup, add the following to your .emacs: + +;; (require 'org-static-mathjax) +;; +;; You will then have to customize the following two variables: +;; - org-static-mathjax-app-ini-path +;; - org-static-mathjax-local-mathjax-path +;; +;; If xulrunner is not in your $PATH, you will also need to customize +;; org-static-mathjax-xulrunner-path. +;; +;; If everything is setup correctly, you can trigger Static MathJax on +;; export to HTML by adding the following line to your Org file: +;; #+StaticMathJax: embed-fonts:nil output-file-name:"embedded-math.html" +;; +;; You can omit either argument. +;; embed-fonts defaults to nil. If you do not specify output-file-name, +;; the exported file is overwritten with the static version. +;; +;; If embed-fonts is non-nil, the fonts are embedded directly into the +;; output file using data: URIs. +;; +;; output-file-name specifies the file name of the static version. You +;; can use any arbitrary lisp form here, for example: +;; output-file-name:(concat (file-name-sans-extension buffer-file-name) "-static.html") +;; +;; The StaticMathJax XULRunner application expects a UTF-8 encoded +;; input file. If the static version displays random characters instead +;; of your math, add the following line at the top of your Org file: +;; -*- coding: utf-8; -*- +;; +;;; Code: + +(defcustom org-static-mathjax-app-ini-path + (or (expand-file-name + "../scripts/staticmatchjax/application.ini" + (file-name-directory (or load-file-name buffer-file-name))) + "") + "Path to \"application.ini\" of the Static MathJax XULRunner application. +If you have extracted StaticMathJax to e.g. ~/.local/staticmathjax, set +this to ~/.local/staticmathjax/application.ini" + :type 'string) + +(defcustom org-static-mathjax-xulrunner-path + "xulrunner" + "Path to your xulrunner binary" + :type 'string) + +(defcustom org-static-mathjax-local-mathjax-path + "" + "Extract the MathJax zip file somewhere on your local +hard drive and specify the path here. + +The directory has to be writeable, as org-static-mathjax +creates a temporary file there during export." + :type 'string) + +(defvar org-static-mathjax-debug + nil + "If non-nil, org-static-mathjax will print some debug messages") + +(defun org-static-mathjax-hook-installer () + "Installs org-static-mathjax-process in after-save-hook. + +Sets the following buffer-local variables for org-static-mathjax-process to pick up: +org-static-mathjax-mathjax-path: The path to MathJax.js as used by Org HTML export +org-static-mathjax-options: The string given with #+STATICMATHJAX: in the file" + (let ((static-mathjax-option-string (plist-get opt-plist :static-mathjax))) + (if static-mathjax-option-string + (progn (set (make-local-variable 'org-static-mathjax-options) static-mathjax-option-string) + (set (make-local-variable 'org-static-mathjax-mathjax-path) + (nth 1 (assq 'path org-export-html-mathjax-options))) + (let ((mathjax-options (plist-get opt-plist :mathjax))) + (if mathjax-options + (if (string-match "\\<path:" mathjax-options) + (set 'org-static-mathjax-mathjax-path + (car (read-from-string + (substring mathjax-options (match-end 0)))))))) + (add-hook 'after-save-hook + 'org-static-mathjax-process + nil t))))) + + +(defun org-static-mathjax-process () + (save-excursion + ; some sanity checking + (if (or (string= org-static-mathjax-app-ini-path "") + (not (file-exists-p org-static-mathjax-app-ini-path))) + (error "Static MathJax: You must customize org-static-mathjax-app-ini-path!")) + (if (or (string= org-static-mathjax-local-mathjax-path "") + (not (file-exists-p org-static-mathjax-local-mathjax-path))) + (error "Static MathJax: You must customize org-static-mathjax-local-mathjax-path!")) + + ; define variables + (let* ((options org-static-mathjax-options) + (output-file-name buffer-file-name) + (input-file-name (let ((temporary-file-directory (file-name-directory org-static-mathjax-local-mathjax-path))) + (make-temp-file "org-static-mathjax-" nil ".html"))) + (html-code (buffer-string)) + (mathjax-oldpath (concat "src=\"" org-static-mathjax-mathjax-path)) + (mathjax-newpath (concat "src=\"" org-static-mathjax-local-mathjax-path)) + embed-fonts) + ; read file-local options + (mapc + (lambda (symbol) + (if (string-match (concat "\\<" (symbol-name symbol) ":") options) + (set symbol (eval (car (read-from-string + (substring options (match-end 0)))))))) + '(embed-fonts output-file-name)) + + ; debug + (when org-static-mathjax-debug + (message "output file name, embed-fonts") + (print output-file-name) + (print embed-fonts)) + + ; open (temporary) input file, copy contents there, replace MathJax path with local installation + (with-temp-buffer + (insert html-code) + (goto-char 1) + (replace-regexp mathjax-oldpath mathjax-newpath) + (write-file input-file-name)) + + ; prepare argument list for call-process + (let ((call-process-args (list org-static-mathjax-xulrunner-path + nil nil nil + org-static-mathjax-app-ini-path + input-file-name + output-file-name))) + ; if fonts are embedded, just append the --embed-fonts flag + (if embed-fonts + (add-to-list 'call-process-args "--embed-fonts" t)) + ; if fonts are not embedded, the XULRunner app must replace all references + ; to the font files with the real location (Firefox inserts file:// URLs there, + ; because we are using a local MathJax installation here) + (if (not embed-fonts) + (progn + (add-to-list 'call-process-args "--final-mathjax-url" t) + (add-to-list 'call-process-args + (file-name-directory org-static-mathjax-mathjax-path) + t))) + + ; debug + (when org-static-mathjax-debug + (print call-process-args)) + ; call it + (apply 'call-process call-process-args) + ; delete our temporary input file + (kill-buffer) + (delete-file input-file-name) + (let ((backup-file (concat input-file-name "~"))) + (if (file-exists-p backup-file) + (delete-file backup-file))))))) + +(add-to-list 'org-export-inbuffer-options-extra +'("STATICMATHJAX" :static-mathjax)) + +(add-hook 'org-export-html-final-hook 'org-static-mathjax-hook-installer) + + +(provide 'org-static-mathjax) diff --git a/contrib/lisp/org-sudoku.el b/contrib/lisp/org-sudoku.el new file mode 100644 index 0000000..baa9fcd --- /dev/null +++ b/contrib/lisp/org-sudoku.el @@ -0,0 +1,288 @@ +;;; org-sudoku.el --- Greate and solve SUDOKU games in Org tables + +;; Copyright (C) 2012-2017 Free Software Foundation, Inc. +;; +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp, games +;; Homepage: http://orgmode.org +;; Version: 0.01 +;; +;; This file is not yet part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; This is a quick hack to create and solve SUDOKU games in org tables. +;; +;; Commands: +;; +;; org-sudoku-create Create a new SUDOKU game +;; org-sudoku-solve-field Solve the field at point in a SUDOKU game +;; (this is for cheeting when you are stuck) +;; org-sudoku-solve Solve the entire game +;; + +;;; Code + +(require 'org) +(require 'org-table) + +;;; Customization + +(defvar org-sudoku-size 9 + "The size of the sudoku game, 9 for a 9x9 game and 4 for a 4x4 game. +Larger games do not seem to work because of limited resources - even though +the algorithm is general.") + +(defvar org-sudoku-timeout 2.0 + "Timeout for finding a solution when creating a new game. +After this timeout, the program starts over from scratch to create +a game.") + +;;; Interactive commands + +(defun org-sudoku-create (nfilled) + "Create a sudoku game." + (interactive "nNumber of pre-filled fields: ") + (let ((sizesq org-sudoku-size) + game) + (loop for i from 1 to org-sudoku-size do + (loop for j from 1 to org-sudoku-size do + (push (list (cons i j) 0) game))) + (setq game (nreverse game)) + (random t) + (setq game (org-sudoku-build-allowed game)) + (setq game (org-sudoku-set-field game (cons 1 1) + (1+ (random org-sudoku-size)))) + (catch 'solved + (let ((cnt 0)) + (while t + (catch 'abort + (message "Attempt %d to create a game" (setq cnt (1+ cnt))) + (setq game1 (org-sudoku-deep-copy game)) + (setq game1 (org-sudoku-solve-game + game1 'random (+ (float-time) org-sudoku-timeout))) + (when game1 + (setq game game1) + (throw 'solved t)))))) + (let ((sqrtsize (floor (sqrt org-sudoku-size)))) + (loop for i from 1 to org-sudoku-size do + (insert "| |\n") + (if (and (= (mod i sqrtsize) 0) (< i org-sudoku-size)) + (insert "|-\n"))) + (backward-char 5) + (org-table-align)) + (while (> (length game) nfilled) + (setq game (delete (nth (1+ (random (length game))) game) game))) + (mapc (lambda (e) + (org-table-put (caar e) (cdar e) (int-to-string (nth 1 e)))) + game) + (org-table-align) + (org-table-goto-line 1) + (org-table-goto-column 1) + (message "Enjoy!"))) + +(defun org-sudoku-solve () + "Solve the sudoku game in the table at point." + (interactive) + (unless (org-at-table-p) + (error "not at a table")) + (let (game) + (setq game (org-sudoku-get-game)) + (setq game (org-sudoku-build-allowed game)) + (setq game (org-sudoku-solve-game game)) + ;; Insert the values + (mapc (lambda (e) + (org-table-put (caar e) (cdar e) (int-to-string (nth 1 e)))) + game) + (org-table-align))) + +(defun org-sudoku-solve-field () + "Just solve the field at point. +This works by solving the whole game, then inserting only the single field." + (interactive) + (unless (org-at-table-p) + (error "Not at a table")) + (org-table-check-inside-data-field) + (let ((i (org-table-current-dline)) + (j (org-table-current-column)) + game) + (setq game (org-sudoku-get-game)) + (setq game (org-sudoku-build-allowed game)) + (setq game (org-sudoku-solve-game game)) + (if game + (progn + (org-table-put i j (number-to-string + (nth 1 (assoc (cons i j) game))) + 'align) + (org-table-goto-line i) + (org-table-goto-column j)) + (error "No solution")))) + +;;; Internal functions + +(defun org-sudoku-get-game () + "Interpret table at point as sudoku game and read it. +A game structure is returned." + (let (b e g i j game) + + (org-table-goto-line 1) + (org-table-goto-column 1) + (setq b (point)) + (org-table-goto-line org-sudoku-size) + (org-table-goto-column org-sudoku-size) + (setq e (point)) + (setq g (org-table-copy-region b e)) + (setq i 0 j 0) + (mapc (lambda (c) + (setq i (1+ i) j 0) + (mapc + (lambda (v) + (setq j (1+ j)) + (push (list (cons i j) + (string-to-number v)) + game)) + c)) + g) + (nreverse game))) + +(defun org-sudoku-build-allowed (game) + (let (i j v numbers) + (loop for i from 1 to org-sudoku-size do + (push i numbers)) + (setq numbers (nreverse numbers)) + ;; add the lists of allowed values for each entry + (setq game (mapcar + (lambda (e) + (list (car e) (nth 1 e) + (if (= (nth 1 e) 0) + (copy-sequence numbers) + nil))) + game)) + ;; remove the known values from the list of allowed values + (mapc + (lambda (e) + (setq i (caar e) j (cdar e) v (cadr e)) + (when (> v 0) + ;; We do have a value here + (mapc + (lambda (f) + (setq a (assoc f game)) + (setf (nth 2 a) (delete v (nth 2 a)))) + (cons (cons i j) (org-sudoku-rel-fields i j))))) + game) + game)) + +(defun org-sudoku-find-next-constrained-field (game) + (setq game (mapcar (lambda (e) (if (nth 2 e) e nil)) game)) + (setq game (delq nil game)) + (let (va vb la lb) + (setq game + (sort game (lambda (a b) + (setq va (nth 1 a) vb (nth 1 b) + la (length (nth 2 a)) lb (length (nth 2 b))) + (cond + ((and (= va 0) (> vb 0)) t) + ((and (> va 0) (= vb 0)) nil) + ((not (= (* va vb) 0)) nil) + (t (< la lb)))))) + (if (or (not game) (> 0 (nth 1 (car game)))) + nil + (caar game)))) + +(defun org-sudoku-solve-game (game &optional random stop-at) + "Solve GAME. +If RANDOM is non-nit, select candidates randomly from a fields option. +If RANDOM is nil, always start with the first allowed value and try +solving from there. +STOP-AT can be a float time, the solver will abort at that time because +it is probably stuck." + (let (e v v1 allowed next g) + (when (and stop-at + (> (float-time) stop-at)) + (setq game nil) + (throw 'abort nil)) + (while (setq next (org-sudoku-find-next-constrained-field game)) + (setq e (assoc next game) + v (nth 1 e) + allowed (nth 2 e)) + (catch 'solved + (if (= (length allowed) 1) + (setq game (org-sudoku-set-field game next (car allowed))) + (while allowed + (setq g (org-sudoku-deep-copy game)) + (if (not random) + (setq v1 (car allowed)) + (setq v1 (nth (random (length allowed)) allowed))) + (setq g (org-sudoku-set-field g next v1)) + (setq g (org-sudoku-solve-game g random stop-at)) + (when g + (setq game g) + (throw 'solved g))) + (setq game nil)))) + (if (or (not game) + (org-sudoku-unknown-field-p game)) + nil + game))) + +(defun org-sudoku-unknown-field-p (game) + "Are there still unknown fields in the game?" + (delq nil (mapcar (lambda (e) (if (> (nth 1 e) 0) nil t)) game))) + +(defun org-sudoku-deep-copy (game) + "Make a copy of the game so that manipulating the copy does not change the parent." + (mapcar (lambda(e) + (list (car e) (nth 1 e) (copy-sequence (nth 2 e)))) + game)) + +(defun org-sudoku-set-field (game field value) + "Put VALUE into FIELD, and tell related fields that they cannot be VALUE." + (let (i j) + (setq i (car field) j (cdr field)) + (setq a (assoc field game)) + (setf (nth 1 a) value) + (setf (nth 2 a) nil) + + ;; Remove value from all related fields + (mapc + (lambda (f) + (setq a (assoc f game)) + (setf (nth 2 a) (delete value (nth 2 a)))) + (org-sudoku-rel-fields i j)) + game)) + +(defun org-sudoku-rel-fields (i j) + "Compute the list of related fields for field (i j)." + (let ((sqrtsize (floor (sqrt org-sudoku-size))) + ll imin imax jmin jmax f) + (setq f (cons i j)) + (loop for ii from 1 to org-sudoku-size do + (or (= ii i) (push (cons ii j) ll))) + (loop for jj from 1 to org-sudoku-size do + (or (= jj j) (push (cons i jj) ll))) + (setq imin (1+ (* sqrtsize (/ (1- i) sqrtsize))) + imax (+ imin sqrtsize -1)) + (setq jmin (1+ (* sqrtsize (/ (1- j) sqrtsize))) + jmax (+ jmin sqrtsize -1)) + (loop for ii from imin to imax do + (loop for jj from jmin to jmax do + (setq ff (cons ii jj)) + (or (equal ff f) + (member ff ll) + (push ff ll)))) + ll)) + +;;; org-sudoku ends here diff --git a/contrib/lisp/org-toc.el b/contrib/lisp/org-toc.el new file mode 100644 index 0000000..1c14a4f --- /dev/null +++ b/contrib/lisp/org-toc.el @@ -0,0 +1,508 @@ +;;; org-toc.el --- Table of contents for Org-mode buffer + +;; Copyright 2007-2017 Free Software Foundation, Inc. +;; +;; Author: Bastien Guerry <bzg@gnu.org> +;; Keywords: Org table of contents +;; Homepage: http://www.cognition.ens.fr/~guerry/u/org-toc.el +;; Version: 0.8 + +;; 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: + +;; This library implements a browsable table of contents for Org files. + +;; Put this file into your load-path and the following into your ~/.emacs: +;; (require 'org-toc) + +;;; Code: + +(provide 'org-toc) +(eval-when-compile + (require 'cl)) + +;;; Custom variables: +(defvar org-toc-base-buffer nil) +(defvar org-toc-columns-shown nil) +(defvar org-toc-odd-levels-only nil) +(defvar org-toc-config-alist nil) +(defvar org-toc-cycle-global-status nil) +(defalias 'org-show-table-of-contents 'org-toc-show) + +(defgroup org-toc nil + "Options concerning the browsable table of contents of Org-mode." + :tag "Org TOC" + :group 'org) + +(defcustom org-toc-default-depth 1 + "Default depth when invoking `org-toc-show' without argument." + :group 'org-toc + :type '(choice + (const :tag "same as base buffer" nil) + (integer :tag "level"))) + +(defcustom org-toc-follow-mode nil + "Non-nil means navigating through the table of contents will +move the point in the Org buffer accordingly." + :group 'org-toc + :type 'boolean) + +(defcustom org-toc-info-mode nil + "Non-nil means navigating through the table of contents will +show the properties for the current headline in the echo-area." + :group 'org-toc + :type 'boolean) + +(defcustom org-toc-show-subtree-mode nil + "Non-nil means show subtree when going to headline or following +it while browsing the table of contents." + :group 'org-toc + :type '(choice + (const :tag "show subtree" t) + (const :tag "show entry" nil))) + +(defcustom org-toc-recenter-mode t + "Non-nil means recenter the Org buffer when following the +headlines in the TOC buffer." + :group 'org-toc + :type 'boolean) + +(defcustom org-toc-recenter 0 + "Where to recenter the Org buffer when unfolding a subtree. +This variable is only used when `org-toc-recenter-mode' is set to +'custom. A value >=1000 will call recenter with no arg." + :group 'org-toc + :type 'integer) + +(defcustom org-toc-info-exclude '("ALLTAGS") + "A list of excluded properties when displaying info in the +echo-area. The COLUMNS property is always exluded." + :group 'org-toc + :type 'lits) + +;;; Org TOC mode: +(defvar org-toc-mode-map (make-sparse-keymap) + "Keymap for `org-toc-mode'.") + +(defun org-toc-mode () + "A major mode for browsing the table of contents of an Org buffer. + +\\{org-toc-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map org-toc-mode-map) + (setq mode-name "Org TOC") + (setq major-mode 'org-toc-mode)) + +;; toggle modes +(define-key org-toc-mode-map "F" 'org-toc-follow-mode) +(define-key org-toc-mode-map "S" 'org-toc-show-subtree-mode) +(define-key org-toc-mode-map "s" 'org-toc-store-config) +(define-key org-toc-mode-map "g" 'org-toc-restore-config) +(define-key org-toc-mode-map "i" 'org-toc-info-mode) +(define-key org-toc-mode-map "r" 'org-toc-recenter-mode) + +;; navigation keys +(define-key org-toc-mode-map "p" 'org-toc-previous) +(define-key org-toc-mode-map "n" 'org-toc-next) +(define-key org-toc-mode-map "f" 'org-toc-forward) +(define-key org-toc-mode-map "b" 'org-toc-back) +(define-key org-toc-mode-map [(left)] 'org-toc-back) +(define-key org-toc-mode-map [(right)] 'org-toc-forward) +(define-key org-toc-mode-map [(up)] 'org-toc-previous) +(define-key org-toc-mode-map [(down)] 'org-toc-next) +(define-key org-toc-mode-map "1" (lambda() (interactive) (org-toc-show 1 (point)))) +(define-key org-toc-mode-map "2" (lambda() (interactive) (org-toc-show 2 (point)))) +(define-key org-toc-mode-map "3" (lambda() (interactive) (org-toc-show 3 (point)))) +(define-key org-toc-mode-map "4" (lambda() (interactive) (org-toc-show 4 (point)))) +(define-key org-toc-mode-map " " 'org-toc-goto) +(define-key org-toc-mode-map "q" 'org-toc-quit) +(define-key org-toc-mode-map "x" 'org-toc-quit) +;; go to the location and stay in the base buffer +(define-key org-toc-mode-map [(tab)] 'org-toc-jump) +(define-key org-toc-mode-map "v" 'org-toc-jump) +;; go to the location and delete other windows +(define-key org-toc-mode-map [(return)] + (lambda() (interactive) (org-toc-jump t))) + +;; special keys +(define-key org-toc-mode-map "c" 'org-toc-columns) +(define-key org-toc-mode-map "?" 'org-toc-help) +(define-key org-toc-mode-map ":" 'org-toc-cycle-subtree) +(define-key org-toc-mode-map "\C-c\C-o" 'org-open-at-point) +;; global cycling in the base buffer +(define-key org-toc-mode-map (kbd "C-S-<iso-lefttab>") + 'org-toc-cycle-base-buffer) +;; subtree cycling in the base buffer +(define-key org-toc-mode-map [(control tab)] + (lambda() (interactive) (org-toc-goto nil t))) + +;;; Toggle functions: +(defun org-toc-follow-mode () + "Toggle follow mode in a `org-toc-mode' buffer." + (interactive) + (setq org-toc-follow-mode (not org-toc-follow-mode)) + (message "Follow mode is %s" + (if org-toc-follow-mode "on" "off"))) + +(defun org-toc-info-mode () + "Toggle info mode in a `org-toc-mode' buffer." + (interactive) + (setq org-toc-info-mode (not org-toc-info-mode)) + (message "Info mode is %s" + (if org-toc-info-mode "on" "off"))) + +(defun org-toc-show-subtree-mode () + "Toggle show subtree mode in a `org-toc-mode' buffer." + (interactive) + (setq org-toc-show-subtree-mode (not org-toc-show-subtree-mode)) + (message "Show subtree mode is %s" + (if org-toc-show-subtree-mode "on" "off"))) + +(defun org-toc-recenter-mode (&optional line) + "Toggle recenter mode in a `org-toc-mode' buffer. If LINE is +specified, then make `org-toc-recenter' use this value." + (interactive "P") + (setq org-toc-recenter-mode (not org-toc-recenter-mode)) + (when (numberp line) + (setq org-toc-recenter-mode t) + (setq org-toc-recenter line)) + (message "Recenter mode is %s" + (if org-toc-recenter-mode + (format "on, line %d" org-toc-recenter) "off"))) + +(defun org-toc-cycle-subtree () + "Locally cycle a headline through two states: 'children and +'folded" + (interactive) + (let ((beg (point)) + (end (save-excursion (end-of-line) (point))) + (ov (car (overlays-at (point)))) + status) + (if ov (setq status (overlay-get ov 'status)) + (setq ov (make-overlay beg end))) + ;; change the folding status of this headline + (cond ((or (null status) (eq status 'folded)) + (org-show-children) + (message "CHILDREN") + (overlay-put ov 'status 'children)) + ((eq status 'children) + (show-branches) + (message "BRANCHES") + (overlay-put ov 'status 'branches)) + (t (hide-subtree) + (message "FOLDED") + (overlay-put ov 'status 'folded))))) + +;;; Main show function: +;; FIXME name this org-before-first-heading-p? +(defun org-toc-before-first-heading-p () + "Before first heading?" + (save-excursion + (null (re-search-backward org-outline-regexp-bol nil t)))) + +;;;###autoload +(defun org-toc-show (&optional depth position) + "Show the table of contents of the current Org-mode buffer." + (interactive "P") + (if (eq major-mode 'org-mode) + (progn (setq org-toc-base-buffer (current-buffer)) + (setq org-toc-odd-levels-only org-odd-levels-only)) + (if (eq major-mode 'org-toc-mode) + (org-pop-to-buffer-same-window org-toc-base-buffer) + (error "Not in an Org buffer"))) + ;; create the new window display + (let ((pos (or position + (save-excursion + (if (org-toc-before-first-heading-p) + (progn (re-search-forward org-outline-regexp-bol nil t) + (match-beginning 0)) + (point)))))) + (setq org-toc-cycle-global-status org-cycle-global-status) + (delete-other-windows) + (and (get-buffer "*org-toc*") (kill-buffer "*org-toc*")) + (switch-to-buffer-other-window + (make-indirect-buffer org-toc-base-buffer "*org-toc*")) + ;; make content before 1st headline invisible + (goto-char (point-min)) + (let* ((beg (point-min)) + (end (and (re-search-forward "^\\*" nil t) + (1- (match-beginning 0)))) + (ov (make-overlay beg end)) + (help (format "Table of contents for %s (press ? for a quick help):\n" + (buffer-name org-toc-base-buffer)))) + (overlay-put ov 'invisible t) + (overlay-put ov 'before-string help)) + ;; build the browsable TOC + (cond (depth + (let* ((dpth (if org-toc-odd-levels-only + (1- (* depth 2)) depth))) + (org-content dpth) + (setq org-toc-cycle-global-status + `(org-content ,dpth)))) + ((null org-toc-default-depth) + (if (eq org-toc-cycle-global-status 'overview) + (progn (org-overview) + (setq org-cycle-global-status 'overview) + (run-hook-with-args 'org-cycle-hook 'overview)) + (progn (org-overview) + ;; FIXME org-content to show only headlines? + (org-content) + (setq org-cycle-global-status 'contents) + (run-hook-with-args 'org-cycle-hook 'contents)))) + (t (let* ((dpth0 org-toc-default-depth) + (dpth (if org-toc-odd-levels-only + (1- (* dpth0 2)) dpth0))) + (org-content dpth) + (setq org-toc-cycle-global-status + `(org-content ,dpth))))) + (goto-char pos)) + (move-beginning-of-line nil) + (org-toc-mode) + (shrink-window-if-larger-than-buffer) + (setq buffer-read-only t)) + +;;; Navigation functions: +(defun org-toc-goto (&optional jump cycle) + "From Org TOC buffer, follow the targeted subtree in the Org window. +If JUMP is non-nil, go to the base buffer. +If JUMP is 'delete, go to the base buffer and delete other windows. +If CYCLE is non-nil, cycle the targeted subtree in the Org window." + (interactive) + (let ((pos (point)) + (toc-buf (current-buffer))) + (switch-to-buffer-other-window org-toc-base-buffer) + (goto-char pos) + (if cycle (org-cycle) + (progn (org-overview) + (if org-toc-show-subtree-mode + (org-show-subtree) + (org-show-entry)) + (org-show-context))) + (if org-toc-recenter-mode + (if (>= org-toc-recenter 1000) (recenter) + (recenter org-toc-recenter))) + (cond ((null jump) + (switch-to-buffer-other-window toc-buf)) + ((eq jump 'delete) + (delete-other-windows))))) + +(defun org-toc-cycle-base-buffer () + "Call `org-cycle' with a prefix argument in the base buffer." + (interactive) + (switch-to-buffer-other-window org-toc-base-buffer) + (org-cycle t) + (other-window 1)) + +(defun org-toc-jump (&optional delete) + "From Org TOC buffer, jump to the targeted subtree in the Org window. +If DELETE is non-nil, delete other windows when in the Org buffer." + (interactive "P") + (if delete (org-toc-goto 'delete) + (org-toc-goto t))) + +(defun org-toc-previous () + "Go to the previous headline of the TOC." + (interactive) + (if (save-excursion + (beginning-of-line) + (re-search-backward "^\\*" nil t)) + (outline-previous-visible-heading 1) + (message "No previous heading")) + (if org-toc-info-mode (org-toc-info)) + (if org-toc-follow-mode (org-toc-goto))) + +(defun org-toc-next () + "Go to the next headline of the TOC." + (interactive) + (outline-next-visible-heading 1) + (if org-toc-info-mode (org-toc-info)) + (if org-toc-follow-mode (org-toc-goto))) + +(defun org-toc-forward () + "Go to the next headline at the same level in the TOC." + (interactive) + (condition-case nil + (outline-forward-same-level 1) + (error (message "No next headline at this level"))) + (if org-toc-info-mode (org-toc-info)) + (if org-toc-follow-mode (org-toc-goto))) + +(defun org-toc-back () + "Go to the previous headline at the same level in the TOC." + (interactive) + (condition-case nil + (outline-backward-same-level 1) + (error (message "No previous headline at this level"))) + (if org-toc-info-mode (org-toc-info)) + (if org-toc-follow-mode (org-toc-goto))) + +(defun org-toc-quit () + "Quit the current Org TOC buffer." + (interactive) + (kill-buffer) + (other-window 1) + (delete-other-windows)) + +;;; Special functions: +(defun org-toc-columns () + "Toggle columns view in the Org buffer from Org TOC." + (interactive) + (let ((indirect-buffer (current-buffer))) + (org-pop-to-buffer-same-window org-toc-base-buffer) + (if (not org-toc-columns-shown) + (progn (org-columns) + (setq org-toc-columns-shown t)) + (progn (org-columns-remove-overlays) + (setq org-toc-columns-shown nil))) + (org-pop-to-buffer-same-window indirect-buffer))) + +(defun org-toc-info () + "Show properties of current subtree in the echo-area." + (interactive) + (let ((pos (point)) + (indirect-buffer (current-buffer)) + props prop msg) + (org-pop-to-buffer-same-window org-toc-base-buffer) + (goto-char pos) + (setq props (org-entry-properties)) + (while (setq prop (pop props)) + (unless (or (equal (car prop) "COLUMNS") + (member (car prop) org-toc-info-exclude)) + (let ((p (car prop)) + (v (cdr prop))) + (if (equal p "TAGS") + (setq v (mapconcat 'identity (split-string v ":" t) " "))) + (setq p (concat p ":")) + (add-text-properties 0 (length p) '(face org-special-keyword) p) + (setq msg (concat msg p " " v " "))))) + (org-pop-to-buffer-same-window indirect-buffer) + (message msg))) + +;;; Store and restore TOC configuration: +(defun org-toc-store-config () + "Store the current status of the tables of contents in +`org-toc-config-alist'." + (interactive) + (let ((file (buffer-file-name org-toc-base-buffer)) + (pos (point)) + (hlcfg (org-toc-get-headlines-status))) + (setq org-toc-config-alist + (delete (assoc file org-toc-config-alist) + org-toc-config-alist)) + (add-to-list 'org-toc-config-alist + `(,file ,pos ,org-toc-cycle-global-status ,hlcfg)) + (message "TOC configuration saved: (%s)" + (if (listp org-toc-cycle-global-status) + (concat "org-content " + (number-to-string + (cadr org-toc-cycle-global-status))) + (symbol-name org-toc-cycle-global-status))))) + +(defun org-toc-restore-config () + "Get the stored status in `org-toc-config-alist' and set the +current table of contents to it." + (interactive) + (let* ((file (buffer-file-name org-toc-base-buffer)) + (conf (cdr (assoc file org-toc-config-alist))) + (pos (car conf)) + (status (cadr conf)) + (hlcfg (caddr conf)) hlcfg0 ov) + (cond ((listp status) + (org-toc-show (cadr status) (point))) + ((eq status 'overview) + (org-overview) + (setq org-cycle-global-status 'overview) + (run-hook-with-args 'org-cycle-hook 'overview)) + (t + (org-overview) + (org-content) + (setq org-cycle-global-status 'contents) + (run-hook-with-args 'org-cycle-hook 'contents))) + (while (setq hlcfg0 (pop hlcfg)) + (save-excursion + (goto-char (point-min)) + (when (search-forward (car hlcfg0) nil t) + (unless (overlays-at (match-beginning 0)) + (setq ov (make-overlay (match-beginning 0) + (match-end 0)))) + (cond ((eq (cdr hlcfg0) 'children) + (org-show-children) + (message "CHILDREN") + (overlay-put ov 'status 'children)) + ((eq (cdr hlcfg0) 'branches) + (show-branches) + (message "BRANCHES") + (overlay-put ov 'status 'branches)))))) + (goto-char pos) + (if org-toc-follow-mode (org-toc-goto)) + (message "Last TOC configuration restored") + (sit-for 1) + (if org-toc-info-mode (org-toc-info)))) + +(defun org-toc-get-headlines-status () + "Return an alist of headlines and their associated folding +status." + (let (output ovs) + (save-excursion + (goto-char (point-min)) + (while (and (not (eobp)) + (goto-char (next-overlay-change (point)))) + (when (looking-at org-outline-regexp-bol) + (add-to-list + 'output + (cons (buffer-substring-no-properties + (match-beginning 0) + (save-excursion + (end-of-line) (point))) + (overlay-get + (car (overlays-at (point))) 'status)))))) + ;; return an alist like (("* Headline" . 'status)) + output)) + +;; In Org TOC buffer, hide headlines below the first level. +(defun org-toc-help () + "Display a quick help message in the echo-area for `org-toc-mode'." + (interactive) + (let ((st-start 0) + (help-message + "\[space\] show heading \[1-4\] hide headlines below this level +\[TAB\] jump to heading \[F\] toggle follow mode (currently %s) +\[return\] jump and delete others windows \[i\] toggle info mode (currently %s) +\[S-TAB\] cycle subtree (in Org) \[S\] toggle show subtree mode (currently %s) +\[C-S-TAB\] global cycle (in Org) \[r\] toggle recenter mode (currently %s) +\[:\] cycle subtree (in TOC) \[c\] toggle column view (currently %s) +\[n/p\] next/previous heading \[s\] save TOC configuration +\[f/b\] next/previous heading of same level +\[q\] quit the TOC \[g\] restore last TOC configuration")) + (while (string-match "\\[[^]]+\\]" help-message st-start) + (add-text-properties (match-beginning 0) + (match-end 0) '(face bold) help-message) + (setq st-start (match-end 0))) + (message help-message + (if org-toc-follow-mode "on" "off") + (if org-toc-info-mode "on" "off") + (if org-toc-show-subtree-mode "on" "off") + (if org-toc-recenter-mode (format "on, line %s" org-toc-recenter) "off") + (if org-toc-columns-shown "on" "off")))) + + +;;;;########################################################################## +;;;; User Options, Variables +;;;;########################################################################## + +;;; org-toc.el ends here diff --git a/contrib/lisp/org-track.el b/contrib/lisp/org-track.el new file mode 100644 index 0000000..36724de --- /dev/null +++ b/contrib/lisp/org-track.el @@ -0,0 +1,211 @@ +;;; org-track.el --- Track the most recent Org-mode version available. +;; +;; Copyright (C) 2009-2017 Free Software Foundation, Inc. +;; +;; Author: Bastien Guerry <bzg@gnu.org> +;; Eric S Fraga <e.fraga at ucl.ac dot uk> +;; Sebastian Rose <sebastian_rose at gmx dot de> +;; The Worg people http://orgmode.org/worg/ +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 6.29a +;; +;; Released under the GNU General Public License version 3 +;; see: http://www.gnu.org/licenses/gpl-3.0.html +;; +;; This file is not part of GNU Emacs. +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; WARNING: This library is obsolete, you should use the make targets +;; to keep track of Org latest developments. +;; +;; Download the latest development tarball, unpack and optionally compile it +;; +;; Usage: +;; +;; (require 'org-track) +;; +;; ;; ... somewhere in your setup (use customize): +;; +;; (setq org-track-directory "~/test/") +;; (setq org-track-compile-sources nil) +;; (setq org-track-remove-package t) +;; +;; M-x org-track-update RET + +(require 'url-parse) +(require 'url-handlers) +(autoload 'url-file-local-copy "url-handlers") +(autoload 'url-generic-parse-url "url-parse") + + + +;;; Variables: + +(defgroup org-track nil + "Track the most recent Org-mode version available. + +To use org-track, adjust `org-track-directory'. +Org will download the archived latest git version for you, +unpack it into that directory (i.e. a subdirectory +`org-mode/' is added), create the autoloads file +`org-loaddefs.el' for you and, optionally, compile the +sources. +All you'll have to do is call `M-x org-track-update' from +time to time." + :group 'org) + +(defcustom org-track-directory (concat user-emacs-directory "org/lisp") + "Directory where your org-mode/ directory lives. +If that directory does not exist, it will be created." + :type 'directory) + +(defcustom org-track-compile-sources t + "If `nil', never compile org-sources. +Org will only create the autoloads file `org-loaddefs.el' for +you then. If `t', compile the sources, too. +Note, that emacs preferes compiled elisp files over +non-compiled ones." + :type 'boolean) + +(defcustom org-track-org-url "http://orgmode.org/" + "The URL where the package to download can be found. +Please append a slash." + :type 'string) + +(defcustom org-track-org-package "org-latest.tar.gz" + "The basename of the package you use. +Defaults to the development version of Org-mode. +This should be a *.tar.gz package, since emacs provides all +you need to unpack it." + :type 'string) + +(defcustom org-track-remove-package nil + "Remove org-latest.tar.gz after updates?" + :type 'boolean) + + + +;;; Frontend + +(defun org-track-update () + "Update to current Org-mode version. +Also, generate autoloads and evtl. compile the sources." + (interactive) + (let* ((base (file-truename org-track-directory)) + (org-exists (file-exists-p + (file-truename + (concat base "/org-mode/lisp/org.el")))) + (nobase (not (file-directory-p + (file-truename org-track-directory))))) + (if nobase + (when (y-or-n-p + (format "Directory %s does not exist. Create it?" base)) + (make-directory base t) + (setq nobase nil))) + (if nobase + (message "Not creating %s - giving up." org-track-directory) + (condition-case err + (progn + (org-track-fetch-package) + (org-track-compile-org)) + (error (message "%s" (error-message-string err))))))) + + + +;;; tar related functions + +;; `url-retrieve-synchronously' fetches files synchronously. How can we ensure +;; that? If the maintainers of that package decide, that an assynchronous +;; download might be better??? (used by `url-file-local-copy') + +;;;###autoload +(defun org-track-fetch-package (&optional directory) + "Fetch Org package depending on `org-track-fetch-package-extension'. +If DIRECTORY is defined, unpack the package there, i.e. add the +subdirectory org-mode/ to DIRECTORY." + (interactive "Dorg-track directory: ") + (let* ((pack (concat + (if (string-match "/$" org-track-org-url) + org-track-org-url + (concat org-track-org-url "/")) + org-track-org-package)) + (base (file-truename + (or directory org-track-directory))) + (target (file-truename + (concat base "/" org-track-org-package))) + url download tarbuff) + (message "Fetching to %s - this might take some time..." base) + (setq url (url-generic-parse-url pack)) + (setq download (url-file-local-copy url)) ;; errors if fail + (copy-file download target t) + (delete-file download) + ;; (tar-mode) leads to dubious errors. We use the auto-mode-alist to + ;; ensure tar-mode is used: + (add-to-list 'auto-mode-alist '("org-latest\\.tar\\.gz\\'" . tar-mode)) + (setq tarbuff (find-file target)) + (with-current-buffer tarbuff ;; with-temp-buffer does not work with tar-mode?? + (tar-untar-buffer)) + (kill-buffer tarbuff) + (if org-track-remove-package + (delete-file target)))) + + + +;;; Compile Org-mode sources + + +;;;###autoload +(defun org-track-compile-org (&optional directory) + "Compile all *.el files that come with org-mode. +Generate the autoloads file `org-loaddefs.el'. + +DIRECTORY is where the directory org-mode/ lives (i.e. the + parent directory of your local repo." + (interactive) + ;; file-truename expands the filename and removes double slash, if exists: + (setq directory (file-truename + (concat + (or directory + (file-truename (concat org-track-directory "/org-mode/lisp"))) + "/"))) + (add-to-list 'load-path directory) + (let ((list-of-org-files (file-expand-wildcards (concat directory "*.el")))) + ;; create the org-loaddefs file + (require 'autoload) + (setq esf/org-install-file (concat directory "org-loaddefs.el")) + (find-file esf/org-install-file) + (erase-buffer) + (mapc (lambda (x) + (generate-file-autoloads x)) + list-of-org-files) + (insert "\n(provide (quote org-loaddefs))\n") + (save-buffer) + (kill-buffer) + (byte-compile-file esf/org-install-file t) + + (mapc (lambda (f) + (if (file-exists-p (concat f "c")) + (delete-file (concat f "c")))) + list-of-org-files) + (if org-track-compile-sources + (mapc (lambda (f) (byte-compile-file f)) list-of-org-files)))) + +(provide 'org-track) + +;;; org-track.el ends here diff --git a/contrib/lisp/org-velocity.el b/contrib/lisp/org-velocity.el new file mode 100644 index 0000000..bfc4d6c --- /dev/null +++ b/contrib/lisp/org-velocity.el @@ -0,0 +1,819 @@ +;;; org-velocity.el --- something like Notational Velocity for Org. -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2014 Paul M. Rodriguez + +;; Author: Paul M. Rodriguez <paulmrodriguez@gmail.com> +;; Created: 2010-05-05 +;; Version: 4.1 + +;; This file is not part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation version 2. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; Org-Velocity.el is an interface for Org inspired by the minimalist +;; notetaking program Notational Velocity. The idea is to let you +;; amass and access brief notes on many subjects with minimal fuss. +;; Each note is an entry in an ordinary Org file. + +;; Org-Velocity can be used in two ways: when called outside Org, to +;; store and access notes in a designated bucket file; or, when called +;; inside Org, as a method for navigating any Org file. (Setting the +;; option `org-velocity-always-use-bucket' disables navigation inside +;; Org files by default, although you can still force this behavior by +;; calling `org-velocity-read' with an argument.) + +;; Org-Velocity prompts for search terms in the minibuffer. A list of +;; headings of entries whose text matches your search is updated as +;; you type; you can end the search and visit an entry at any time by +;; clicking on its heading. + +;; RET displays the results. If there are no matches, Org-Velocity +;; offers to create a new entry with your search string as its +;; heading. If there are matches, it displays a list of results where +;; the heading of each matching entry is hinted with a number or +;; letter; clicking a result, or typing the matching hint, opens the +;; entry for editing in an indirect buffer. 0 forces a new entry; RET +;; reopens the search for editing. + +;; You can customize every step in this process, including the search +;; method, completion for search terms, and templates for creating new +;; entries; M-x customize-group RET org-velocity RET to see all the +;; options. + +;; Thanks to Richard Riley, Carsten Dominik, Bastien Guerry, and Jeff +;; Horn for their suggestions. + +;;; Usage: +;; (require 'org-velocity) +;; (setq org-velocity-bucket (expand-file-name "bucket.org" org-directory)) +;; (global-set-key (kbd "C-c v") 'org-velocity) + +;;; Code: +(require 'org) +(require 'button) +(require 'electric) +(require 'dabbrev) +(require 'cl-lib) + +(defgroup org-velocity nil + "Notational Velocity-style interface for Org." + :tag "Org-Velocity" + :group 'outlines + :group 'hypermedia + :group 'org) + +(defcustom org-velocity-bucket "" + "Where is the bucket file?" + :group 'org-velocity + :type 'file) + +(defcustom org-velocity-show-previews t + "Show previews of the text of each heading?" + :group 'velocity + :type 'boolean + :safe 'booleanp) + +(defcustom org-velocity-exit-on-match nil + "When searching incrementally, exit on a single match?" + :group 'org-velocity + :type 'boolean + :safe 'booleanp) + +(defcustom org-velocity-force-new nil + "Should exiting the minibuffer with C-j force a new entry?" + :group 'org-velocity + :type 'boolean + :safe 'booleanp) + +(defcustom org-velocity-use-search-ring t + "Push search to `search-ring' when visiting an entry? + +This means that C-s C-s will take you directly to the first +instance of the search string." + :group 'org-velocity + :type 'boolean + :safe 'booleanp) + +(defcustom org-velocity-always-use-bucket nil + "Use bucket file even when called from an Org buffer?" + :group 'org-velocity + :type 'boolean + :safe 'booleanp) + +(defcustom org-velocity-use-completion nil + "Use completion? + +Notwithstanding the value of this option, calling +`dabbrev-expand' always completes against the text of the bucket +file." + :group 'org-velocity + :type '(choice + (const :tag "Do not use completion" nil) + (const :tag "Use completion" t)) + :safe 'booleanp) + +(defcustom org-velocity-search-method 'phrase + "Match on whole phrase, any word, or all words?" + :group 'org-velocity + :type '(choice + (const :tag "Match whole phrase" phrase) + (const :tag "Match any word" any) + (const :tag "Match all words" all) + (const :tag "Match a regular expression" regexp)) + :safe (lambda (v) (memq v '(phrase any all regexp)))) + +(defcustom org-velocity-capture-templates + '(("v" + "Velocity entry" + entry + (file "") + "* %:search\n\n%i%?")) + "Use these template with `org-capture'. +Meanwhile `org-default-notes-file' is bound to `org-velocity-bucket-file'. +The keyword :search inserts the current search. +See the documentation for `org-capture-templates'." + :group 'org-velocity + :type (or (get 'org-capture-templates 'custom-type) 'list)) + +(defcustom org-velocity-heading-level 1 + "Only match headings at this level or higher. +0 means to match headings at any level." + :group 'org-velocity + :type 'integer + :safe (lambda (x) + (and (integerp x) + (>= x 0)))) + +(defvar crm-separator) ;Ensure dynamic binding. + +(defsubst org-velocity-grab-preview () + "Grab preview of a subtree. +The length of the preview is determined by `window-width'. + +Replace all contiguous whitespace with single spaces." + (let* ((start (progn + (forward-line 1) + (if (looking-at org-property-start-re) + (re-search-forward org-property-end-re) + (1- (point))))) + (string+props (buffer-substring + start + (min + (+ start (window-width)) + (point-max))))) + ;; We want to preserve the text properties so that, for example, + ;; we don't end up with the raw text of links in the preview. + (with-temp-buffer + (insert string+props) + (goto-char (point-min)) + (save-match-data + (while (re-search-forward split-string-default-separators + (point-max) + t) + (replace-match " "))) + (buffer-string)))) + +(cl-defstruct org-velocity-heading buffer position name level preview) + +(defsubst org-velocity-nearest-heading (position) + "Return last heading at POSITION. +If there is no last heading, return nil." + (save-excursion + (goto-char position) + (re-search-backward (org-velocity-heading-regexp)) + (let ((components (org-heading-components))) + (make-org-velocity-heading + :buffer (current-buffer) + :position (point) + :name (nth 4 components) + :level (nth 0 components) + :preview (if org-velocity-show-previews + (org-velocity-grab-preview)))))) + +(defconst org-velocity-index + (eval-when-compile + (nconc (number-sequence 49 57) ;numbers + (number-sequence 97 122) ;lowercase letters + (number-sequence 65 90))) ;uppercase letters + "List of chars for indexing results.") + +(defconst org-velocity-match-buffer-name "*Velocity matches*") + +(cl-defun org-velocity-heading-regexp (&optional (level org-velocity-heading-level)) + "Regexp to match headings at LEVEL or deeper." + (if (zerop level) + "^\\*+ " + (format "^\\*\\{1,%d\\} " level))) + +(defvar org-velocity-search nil + "Variable to bind to current search.") + +(defun org-velocity-buffer-file-name (&optional buffer) + "Return the name of the file BUFFER saves to. +Same as function `buffer-file-name' unless BUFFER is an indirect +buffer or a minibuffer. In the former case, return the file name +of the base buffer; in the latter, return the file name of +`minibuffer-selected-window' (or its base buffer)." + (let ((buffer (if (minibufferp buffer) + (window-buffer (minibuffer-selected-window)) + buffer))) + (buffer-file-name + (or (buffer-base-buffer buffer) + buffer)))) + +(defun org-velocity-minibuffer-contents () + "Return the contents of the minibuffer when it is active." + (when (active-minibuffer-window) + (with-current-buffer (window-buffer (active-minibuffer-window)) + (minibuffer-contents)))) + +(defun org-velocity-nix-minibuffer () + "Return the contents of the minibuffer and clear it." + (when (active-minibuffer-window) + (with-current-buffer (window-buffer (active-minibuffer-window)) + (prog1 (minibuffer-contents) + (delete-minibuffer-contents))))) + +(defun org-velocity-bucket-file () + "Return the proper file for Org-Velocity to search. +If `org-velocity-always-use-bucket' is t, use bucket file; +complain if missing. Otherwise, if an Org file is current, then +use it." + (let ((org-velocity-bucket + (when org-velocity-bucket (expand-file-name org-velocity-bucket))) + (buffer + (let ((buffer-file (org-velocity-buffer-file-name))) + (when buffer-file + ;; Use the target in capture buffers. + (org-find-base-buffer-visiting buffer-file))))) + (if org-velocity-always-use-bucket + (or org-velocity-bucket (error "Bucket required but not defined")) + (if (and (eq (buffer-local-value 'major-mode (or buffer (current-buffer))) + 'org-mode) + (org-velocity-buffer-file-name)) + (org-velocity-buffer-file-name) + (or org-velocity-bucket + (error "No bucket and not an Org file")))))) + +(defvar org-velocity-bucket-buffer nil) +(defvar org-velocity-navigating nil) + +(defsubst org-velocity-bucket-buffer () + (or org-velocity-bucket-buffer + (find-file-noselect (org-velocity-bucket-file)))) + +(defsubst org-velocity-match-buffer () + "Return the proper buffer for Org-Velocity to display in." + (get-buffer-create org-velocity-match-buffer-name)) + +(defsubst org-velocity-match-window () + (get-buffer-window (org-velocity-match-buffer))) + +(defun org-velocity-beginning-of-headings () + "Goto the start of the first heading." + (goto-char (point-min)) + ;; If we are before the first heading we could still be at the + ;; first heading. + (or (looking-at (org-velocity-heading-regexp)) + (re-search-forward (org-velocity-heading-regexp)))) + +(defun org-velocity-make-indirect-buffer (heading) + "Make or switch to an indirect buffer visiting HEADING." + (let* ((bucket (org-velocity-heading-buffer heading)) + (name (org-velocity-heading-name heading)) + (existing (get-buffer name))) + (if (and existing (buffer-base-buffer existing) + (equal (buffer-base-buffer existing) bucket)) + existing + (make-indirect-buffer + bucket + (generate-new-buffer-name (org-velocity-heading-name heading)) + t)))) + +(defun org-velocity-capture () + "Record a note with `org-capture'." + (let ((org-capture-templates + org-velocity-capture-templates)) + (org-capture nil + ;; This is no longer automatically selected. + (when (null (cdr org-capture-templates)) + (caar org-capture-templates))) + (when org-capture-mode + (rename-buffer org-velocity-search t)))) + +(defvar org-velocity-saved-winconf nil) +(make-variable-buffer-local 'org-velocity-saved-winconf) + +(defun org-velocity-edit-entry (heading) + (if org-velocity-navigating + (org-velocity-edit-entry/inline heading) + (org-velocity-edit-entry/indirect heading))) + +(cl-defun org-velocity-goto-entry (heading &key narrow) + (goto-char (org-velocity-heading-position heading)) + (save-excursion + (when narrow + (org-narrow-to-subtree)) + (outline-show-all))) + +(defun org-velocity-edit-entry/inline (heading) + "Edit entry at HEADING in the original buffer." + (let ((buffer (org-velocity-heading-buffer heading))) + (pop-to-buffer buffer) + (with-current-buffer buffer + (org-velocity-goto-entry heading)))) + +(defun org-velocity-format-header-line (control-string &rest args) + (set (make-local-variable 'header-line-format) + (apply #'format control-string args))) + +(defun org-velocity-edit-entry/indirect (heading) + "Edit entry at HEADING in an indirect buffer." + (let ((winconf (current-window-configuration)) + (dd default-directory) + (buffer (org-velocity-make-indirect-buffer heading)) + (inhibit-point-motion-hooks t) + (inhibit-field-text-motion t)) + (with-current-buffer buffer + (setq default-directory dd) ;Inherit default directory. + (setq org-velocity-saved-winconf winconf) + (org-velocity-goto-entry heading :narrow t) + (goto-char (point-max)) + (add-hook 'org-ctrl-c-ctrl-c-hook 'org-velocity-dismiss nil t)) + (pop-to-buffer buffer) + (org-velocity-format-header-line + "%s Use C-c C-c to finish." + (abbreviate-file-name + (buffer-file-name + (org-velocity-heading-buffer heading)))))) + +(defun org-velocity-dismiss () + "Save current entry and close indirect buffer." + (let ((winconf org-velocity-saved-winconf)) + (prog1 t ;Tell hook we're done. + (save-buffer) + (kill-buffer) + (when (window-configuration-p winconf) + (set-window-configuration winconf))))) + +(defun org-velocity-visit-button (button) + (run-hooks 'mouse-leave-buffer-hook) + (when org-velocity-use-search-ring + (add-to-history 'search-ring + (button-get button 'search) + search-ring-max)) + (let ((match (button-get button 'match))) + (throw 'org-velocity-done match))) + +(define-button-type 'org-velocity-button + 'action #'org-velocity-visit-button + 'follow-link 'mouse-face) + +(defsubst org-velocity-buttonize (heading) + "Insert HEADING as a text button with no hints." + (insert-text-button + (propertize (org-velocity-heading-name heading) 'face 'link) + :type 'org-velocity-button + 'match heading + 'search org-velocity-search)) + +(defsubst org-velocity-insert-preview (heading) + (when org-velocity-show-previews + (insert-char ?\ 1) + (insert + (propertize + (org-velocity-heading-preview heading) + 'face 'shadow)))) + +(defvar org-velocity-recursive-headings nil) +(defvar org-velocity-recursive-search nil) + +(cl-defun org-velocity-search-with (fun style search + &key (headings org-velocity-recursive-headings)) + (if headings + (save-restriction + (dolist (heading headings) + (widen) + (let ((start (org-velocity-heading-position heading))) + (goto-char start) + (let ((end (save-excursion + (org-end-of-subtree) + (point)))) + (narrow-to-region start end) + (org-velocity-search-with fun style search + :headings nil))))) + (cl-ecase style + ((phrase any regexp) + (cl-block nil + (while (re-search-forward search nil t) + (let ((match (org-velocity-nearest-heading (point)))) + (funcall fun match)) + ;; Skip to the next heading. + (unless (re-search-forward (org-velocity-heading-regexp) nil t) + (cl-return))))) + ((all) + (let ((keywords + (cl-loop for word in (split-string search) + collect (concat "\\<" (regexp-quote word) "\\>")))) + (org-map-entries + (lambda () + ;; Only search the subtree once. + (setq org-map-continue-from + (save-excursion + (org-end-of-subtree) + (point))) + (when (cl-loop for word in keywords + always (save-excursion + (re-search-forward word org-map-continue-from t))) + (let ((match (org-velocity-nearest-heading (match-end 0)))) + (funcall fun match)))))))))) + +(defun org-velocity-all-results (style search) + (with-current-buffer (org-velocity-bucket-buffer) + (save-excursion + (goto-char (point-min)) + (let (matches) + (org-velocity-search-with (lambda (match) + (push match matches)) + style + search) + (nreverse matches))))) + +(defsubst org-velocity-present-match (hint match) + (with-current-buffer (org-velocity-match-buffer) + (when hint (insert "#" hint " ")) + (org-velocity-buttonize match) + (org-velocity-insert-preview match) + (newline))) + +(defun org-velocity-present-search (style search hide-hints) + (let ((hints org-velocity-index) matches) + (cl-block nil + (org-velocity-search-with (lambda (match) + (unless hints + (cl-return)) + (let ((hint (if hide-hints + nil + (car hints)))) + (org-velocity-present-match hint match)) + (pop hints) + (push match matches)) + style + search)) + (nreverse matches))) + +(defun org-velocity-restrict-search () + (interactive) + (let ((search (org-velocity-nix-minibuffer))) + (when (equal search "") + (error "No search to restrict to")) + (push search org-velocity-recursive-search) + (setq org-velocity-recursive-headings + (org-velocity-all-results + org-velocity-search-method + search)) + ;; TODO We could extend the current search instead of starting + ;; over. + (org-velocity-update-match-header) + (minibuffer-message "Restricting search to %s" search))) + +(cl-defun org-velocity-update-match-header (&key (match-buffer (org-velocity-match-buffer)) + (bucket-buffer (org-velocity-bucket-buffer)) + (search-method org-velocity-search-method)) + (let ((navigating? org-velocity-navigating) + (recursive? org-velocity-recursive-search)) + (with-current-buffer match-buffer + (org-velocity-format-header-line + "%s search in %s%s (%s mode)" + (capitalize (symbol-name search-method)) + (abbreviate-file-name (buffer-file-name bucket-buffer)) + (if (not recursive?) + "" + (let ((sep " > ")) + (concat sep (string-join (reverse recursive?) sep)))) + (if navigating? "nav" "notes"))))) + +(cl-defun org-velocity-present (search &key hide-hints) + "Buttonize matches for SEARCH in `org-velocity-match-buffer'. +If HIDE-HINTS is non-nil, display entries without indices. SEARCH +binds `org-velocity-search'. + +Return matches." + (let ((match-buffer (org-velocity-match-buffer)) + (bucket-buffer (org-velocity-bucket-buffer)) + (search-method org-velocity-search-method)) + (if (and (stringp search) (not (string= "" search))) + ;; Fold case when the search string is all lowercase. + (let ((case-fold-search (equal search (downcase search))) + (truncate-partial-width-windows t)) + (with-current-buffer match-buffer + (erase-buffer) + ;; Permanent locals. + (setq cursor-type nil + truncate-lines t) + (org-velocity-update-match-header + :match-buffer match-buffer + :bucket-buffer bucket-buffer + :search-method search-method)) + (prog1 + (with-current-buffer bucket-buffer + (widen) + (let* ((inhibit-point-motion-hooks t) + (inhibit-field-text-motion t) + (anchored? (string-match-p "^\\s-" search)) + (search + (cl-ecase search-method + (all search) + (phrase + (if anchored? + (regexp-quote search) + ;; Anchor the search to the start of a word. + (concat "\\<" (regexp-quote search)))) + (any + (concat "\\<" (regexp-opt (split-string search)))) + (regexp search)))) + (save-excursion + (org-velocity-beginning-of-headings) + (condition-case lossage + (org-velocity-present-search search-method search hide-hints) + (invalid-regexp + (minibuffer-message "%s" lossage)))))) + (with-current-buffer match-buffer + (goto-char (point-min))))) + (with-current-buffer match-buffer + (erase-buffer))))) + +(defun org-velocity-store-link () + "Function for `org-store-link-functions'." + (if org-velocity-search + (org-store-link-props + :search org-velocity-search))) + +(add-hook 'org-store-link-functions 'org-velocity-store-link) + +(cl-defun org-velocity-create (search &key ask) + "Create new heading named SEARCH. +If ASK is non-nil, ask first." + (when (or (null ask) (y-or-n-p "No match found, create? ")) + (let ((org-velocity-search search) + (org-default-notes-file (org-velocity-bucket-file)) + ;; save a stored link + org-store-link-plist) + (org-velocity-capture)) + search)) + +(defun org-velocity-engine (search) + "Display a list of headings where SEARCH occurs." + (let ((org-velocity-search search)) + (unless (or + (not (stringp search)) + (string= "" search)) ;exit on empty string + (cl-case + (if (and org-velocity-force-new (eq last-command-event ?\C-j)) + :force + (let* ((org-velocity-index (org-velocity-adjust-index)) + (matches (org-velocity-present search))) + (cond ((null matches) :new) + ((null (cdr matches)) :follow) + (t :prompt)))) + (:prompt (progn + (pop-to-buffer (org-velocity-match-buffer)) + (let ((hint (org-velocity-electric-read-hint))) + (when hint (cl-case hint + (:edit (org-velocity-read nil search)) + (:force (org-velocity-create search)) + (otherwise (org-velocity-activate-button hint))))))) + (:new (unless (org-velocity-create search :ask t) + (org-velocity-read nil search))) + (:force (org-velocity-create search)) + (:follow (if (y-or-n-p "One match, follow? ") + (progn + (set-buffer (org-velocity-match-buffer)) + (goto-char (point-min)) + (button-activate (next-button (point)))) + (org-velocity-read nil search))))))) + +(defun org-velocity-activate-button (char) + "Go to button on line number associated with CHAR in `org-velocity-index'." + (goto-char (point-min)) + (forward-line (cl-position char org-velocity-index)) + (goto-char + (button-start + (next-button (point)))) + (message "%s" (button-label (button-at (point)))) + (button-activate (button-at (point)))) + +(defun org-velocity-electric-undefined () + "Complain about an undefined key." + (interactive) + (message "%s" + (substitute-command-keys + "\\[org-velocity-electric-new] for new entry, +\\[org-velocity-electric-edit] to edit search, +\\[scroll-up] to scroll up, +\\[scroll-down] to scroll down, +\\[keyboard-quit] to quit.")) + (sit-for 4)) + +(defun org-velocity-electric-follow (ev) + "Follow a hint indexed by keyboard event EV." + (interactive (list last-command-event)) + (if (not (> (cl-position ev org-velocity-index) + (1- (count-lines (point-min) (point-max))))) + (throw 'org-velocity-select ev) + (call-interactively 'org-velocity-electric-undefined))) + +(defun org-velocity-electric-edit () + "Edit the search string." + (interactive) + (throw 'org-velocity-select :edit)) + +(defun org-velocity-electric-new () + "Force a new entry." + (interactive) + (throw 'org-velocity-select :force)) + +(defvar org-velocity-electric-map + (let ((map (make-sparse-keymap))) + (define-key map [t] 'org-velocity-electric-undefined) + (dolist (c org-velocity-index) + (define-key map (char-to-string c) + 'org-velocity-electric-follow)) + (define-key map "0" 'org-velocity-electric-new) + (define-key map "\C-v" 'scroll-up) + (define-key map "\M-v" 'scroll-down) + (define-key map (kbd "RET") 'org-velocity-electric-edit) + (define-key map [mouse-1] nil) + (define-key map [mouse-2] nil) + (define-key map [escape] 'keyboard-quit) + (define-key map "\C-h" 'help-command) + map)) + +(defun org-velocity-electric-read-hint () + "Read index of button electrically." + (with-current-buffer (org-velocity-match-buffer) + (when (featurep 'evil) + ;; NB Idempotent. + (evil-make-overriding-map org-velocity-electric-map)) + (use-local-map org-velocity-electric-map) + (catch 'org-velocity-select + (Electric-command-loop 'org-velocity-select "Follow: ")))) + +(defvar org-velocity-incremental-keymap + (let ((map (make-sparse-keymap))) + (define-key map "\C-v" 'scroll-up) + (define-key map "\M-v" 'scroll-down) + map)) + +(defun org-velocity-displaying-completions-p () + "Is there a *Completions* buffer showing?" + (get-window-with-predicate + (lambda (w) + (eq (buffer-local-value 'major-mode (window-buffer w)) + 'completion-list-mode)))) + +(defun org-velocity-update () + "Display results of search without hinting." + (unless (org-velocity-displaying-completions-p) + (let* ((search (org-velocity-minibuffer-contents)) + (matches (org-velocity-present search :hide-hints t))) + (cond ((null matches) + (select-window (active-minibuffer-window)) + (unless (or (null search) (= (length search) 0)) + (minibuffer-message "No match; RET to create"))) + ((and (null (cdr matches)) + org-velocity-exit-on-match) + (throw 'click search)) + (t + (with-current-buffer (org-velocity-match-buffer) + (use-local-map org-velocity-incremental-keymap))))))) + +(defvar dabbrev--last-abbreviation) + +(defun org-velocity-dabbrev-completion-list (abbrev) + "Return all dabbrev completions for ABBREV." + ;; This is based on `dabbrev-completion'. + (dabbrev--reset-global-variables) + (setq dabbrev--last-abbreviation abbrev) + (dabbrev--find-all-expansions abbrev case-fold-search)) + +(defvar org-velocity-local-completion-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map minibuffer-local-completion-map) + (define-key map " " 'self-insert-command) + (define-key map "?" 'self-insert-command) + (define-key map [remap minibuffer-complete] 'minibuffer-complete-word) + (define-key map [(control ?@)] 'org-velocity-restrict-search) + (define-key map [(control ?\s)] 'org-velocity-restrict-search) + map) + "Keymap for completion with `completing-read'.") + +(defun org-velocity-read-with-completion (prompt) + "Completing read with PROMPT." + (let ((minibuffer-local-completion-map + org-velocity-local-completion-map) + (completion-no-auto-exit t) + (crm-separator " ")) + (completing-read prompt + (completion-table-dynamic + 'org-velocity-dabbrev-completion-list)))) + +(cl-defun org-velocity-adjust-index + (&optional (match-window (org-velocity-match-window))) + "Truncate or extend `org-velocity-index' to the lines in +MATCH-WINDOW." + (with-selected-window match-window + (let ((lines (window-height)) + (hints (length org-velocity-index))) + (cond ((= lines hints) + org-velocity-index) + ;; Truncate the index to the size of + ;; the buffer to be displayed. + ((< lines hints) + (cl-subseq org-velocity-index 0 lines)) + ;; If the window is so tall we run out of indices, at + ;; least make the additional results clickable. + ((> lines hints) + (append org-velocity-index + (make-list (- lines hints) nil))))))) + +(defun org-velocity-incremental-read (prompt) + "Read string with PROMPT and display results incrementally. +Stop searching once there are more matches than can be +displayed." + (let ((res + (unwind-protect + (let* ((match-window (display-buffer (org-velocity-match-buffer))) + (org-velocity-index (org-velocity-adjust-index match-window))) + (catch 'click + (add-hook 'post-command-hook 'org-velocity-update) + (cond ((eq org-velocity-search-method 'regexp) + (read-regexp prompt)) + (org-velocity-use-completion + (org-velocity-read-with-completion prompt)) + (t (read-string prompt))))) + (remove-hook 'post-command-hook 'org-velocity-update)))) + (if (bufferp res) (org-pop-to-buffer-same-window res) res))) + +(defun org-velocity (arg &optional search) + "Read a search string SEARCH for Org-Velocity interface. +This means that a buffer will display all headings where SEARCH +occurs, where one can be selected by a mouse click or by typing +its index. If SEARCH does not occur, then a new heading may be +created named SEARCH. + +If `org-velocity-bucket' is defined and +`org-velocity-always-use-bucket' is non-nil, then the bucket file +will be used; otherwise, this will work when called in any Org +file. + +Calling with ARG reverses which file – the current file or the +bucket file – to use. If the bucket file would have been used, +then the current file is used instead, and vice versa." + (interactive "P") + (let ((org-velocity-always-use-bucket + (if org-velocity-always-use-bucket + (not arg) + arg))) + ;; complain if inappropriate + (cl-assert (org-velocity-bucket-file)) + (let* ((starting-buffer (current-buffer)) + (org-velocity-bucket-buffer + (find-file-noselect (org-velocity-bucket-file))) + (org-velocity-navigating + (eq starting-buffer org-velocity-bucket-buffer)) + (org-velocity-recursive-headings '()) + (org-velocity-recursive-search '()) + (org-velocity-heading-level + (if org-velocity-navigating + 0 + org-velocity-heading-level)) + (dabbrev-search-these-buffers-only + (list org-velocity-bucket-buffer))) + (unwind-protect + (let ((match + (catch 'org-velocity-done + (org-velocity-engine + (or search + (org-velocity-incremental-read "Velocity search: "))) + nil))) + (when (org-velocity-heading-p match) + (org-velocity-edit-entry match))) + (kill-buffer (org-velocity-match-buffer)))))) + +(defalias 'org-velocity-read 'org-velocity) + +(provide 'org-velocity) + +;;; org-velocity.el ends here diff --git a/contrib/lisp/org-vm.el b/contrib/lisp/org-vm.el new file mode 100644 index 0000000..4deca8f --- /dev/null +++ b/contrib/lisp/org-vm.el @@ -0,0 +1,168 @@ +;;; org-vm.el --- Support for links to VM messages from within Org-mode + +;; Copyright (C) 2004-2017 Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; +;; Support for IMAP folders added +;; by Konrad Hinsen <konrad dot hinsen at fastmail dot net> +;; Requires VM 8.2.0a or later. +;; +;; This file is not part of GNU Emacs. +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; This file implements links to VM messages and folders from within Org-mode. +;; Org-mode loads this module by default - if this is not what you want, +;; configure the variable `org-modules'. + +;;; Code: + +(require 'org) + +;; Declare external functions and variables +(declare-function vm-preview-current-message "ext:vm-page" ()) +(declare-function vm-follow-summary-cursor "ext:vm-motion" ()) +(declare-function vm-get-header-contents "ext:vm-summary" + (message header-name-regexp &optional clump-sep)) +(declare-function vm-isearch-narrow "ext:vm-search" ()) +(declare-function vm-isearch-update "ext:vm-search" ()) +(declare-function vm-select-folder-buffer "ext:vm-macro" ()) +(declare-function vm-su-message-id "ext:vm-summary" (m)) +(declare-function vm-su-subject "ext:vm-summary" (m)) +(declare-function vm-summarize "ext:vm-summary" (&optional display raise)) +(declare-function vm-imap-folder-p "ext:vm-save" ()) +(declare-function vm-imap-find-spec-for-buffer "ext:vm-imap" (buffer)) +(declare-function vm-imap-folder-for-spec "ext:vm-imap" (spec)) +(declare-function vm-imap-parse-spec-to-list "ext:vm-imap" (spec)) +(declare-function vm-imap-spec-for-account "ext:vm-imap" (account)) +(defvar vm-message-pointer) +(defvar vm-folder-directory) + +;; Install the link type +(org-link-set-parameters "vm" :follow #'org-vm-open :store #'org-vm-store-link) +(org-link-set-parameters "vm-imap" :follow #'org-vm-imap-open) + +;; Implementation +(defun org-vm-store-link () + "Store a link to a VM folder or message." + (when (and (or (eq major-mode 'vm-summary-mode) + (eq major-mode 'vm-presentation-mode)) + (save-window-excursion + (vm-select-folder-buffer) buffer-file-name)) + (and (eq major-mode 'vm-presentation-mode) (vm-summarize)) + (vm-follow-summary-cursor) + (save-excursion + (vm-select-folder-buffer) + (let* ((message (car vm-message-pointer)) + (subject (vm-su-subject message)) + (to (vm-get-header-contents message "To")) + (from (vm-get-header-contents message "From")) + (message-id (vm-su-message-id message)) + (link-type (if (vm-imap-folder-p) "vm-imap" "vm")) + (date (vm-get-header-contents message "Date")) + folder desc link) + (if (vm-imap-folder-p) + (let ((spec (vm-imap-find-spec-for-buffer (current-buffer)))) + (setq folder (vm-imap-folder-for-spec spec))) + (progn + (setq folder (abbreviate-file-name buffer-file-name)) + (if (and vm-folder-directory + (string-match (concat "^" (regexp-quote vm-folder-directory)) + folder)) + (setq folder (replace-match "" t t folder))))) + (setq message-id (org-unbracket-string "<" ">" message-id)) + (org-store-link-props :type link-type :from from :to to :subject subject + :message-id message-id :date date) + (setq desc (org-email-link-description)) + (setq link (concat (concat link-type ":") folder "#" message-id)) + (org-add-link-props :link link :description desc) + link)))) + +(defun org-vm-open (path) + "Follow a VM message link specified by PATH." + (let (folder article) + (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) + (error "Error in VM link")) + (setq folder (match-string 1 path) + article (match-string 3 path)) + ;; The prefix argument will be interpreted as read-only + (org-vm-follow-link folder article current-prefix-arg))) + +(defun org-vm-follow-link (&optional folder article readonly) + "Follow a VM link to FOLDER and ARTICLE." + (require 'vm) + (setq article (org-add-angle-brackets article)) + (if (string-match "^//\\([a-zA-Z]+@\\)?\\([^:]+\\):\\(.*\\)" folder) + ;; ange-ftp or efs or tramp access + (let ((user (or (match-string 1 folder) (user-login-name))) + (host (match-string 2 folder)) + (file (match-string 3 folder))) + (cond + ((featurep 'tramp) + ;; use tramp to access the file + (setq folder (format "/%s@%s:%s" user host file))) + (t + ;; use ange-ftp or efs + (require 'ange-ftp) + (setq folder (format "/%s@%s:%s" user host file)))))) + (when folder + (funcall (cdr (assq 'vm org-link-frame-setup)) folder readonly) + (when article + (org-vm-select-message (org-add-angle-brackets article))))) + +(defun org-vm-imap-open (path) + "Follow a VM link to an IMAP folder." + (require 'vm-imap) + (when (string-match "\\([^:]+\\):\\([^#]+\\)#?\\(.+\\)?" path) + (let* ((account-name (match-string 1 path)) + (mailbox-name (match-string 2 path)) + (message-id (match-string 3 path)) + (account-spec (vm-imap-parse-spec-to-list + (vm-imap-spec-for-account account-name))) + (mailbox-spec (mapconcat 'identity + (append (butlast account-spec 4) + (cons mailbox-name + (last account-spec 3))) + ":"))) + (funcall (cdr (assq 'vm-imap org-link-frame-setup)) + mailbox-spec) + (when message-id + (org-vm-select-message (org-add-angle-brackets message-id)))))) + +(defun org-vm-select-message (message-id) + "Go to the message with message-id in the current folder." + (require 'vm-search) + (sit-for 0.1) + (vm-select-folder-buffer) + (widen) + (let ((case-fold-search t)) + (goto-char (point-min)) + (if (not (re-search-forward + (concat "^" "message-id: *" (regexp-quote message-id)))) + (error "Could not find the specified message in this folder")) + (vm-isearch-update) + (vm-isearch-narrow) + (vm-preview-current-message) + (vm-summarize))) + +(provide 'org-vm) + + + +;;; org-vm.el ends here diff --git a/contrib/lisp/org-wikinodes.el b/contrib/lisp/org-wikinodes.el new file mode 100644 index 0000000..35242db --- /dev/null +++ b/contrib/lisp/org-wikinodes.el @@ -0,0 +1,327 @@ +;;; org-wikinodes.el --- Wiki-like CamelCase links to outline nodes + +;; Copyright (C) 2010-2017 Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.01trans +;; +;; This file is not part of GNU Emacs. +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(require 'org) +(eval-when-compile + (require 'cl)) + +(defgroup org-wikinodes nil + "Wiki-like CamelCase links words to outline nodes in Org mode." + :tag "Org WikiNodes" + :group 'org) + +(defconst org-wikinodes-camel-regexp "\\<[A-Z]+[a-z]+[A-Z]+[a-z]+[a-zA-Z]*\\>" + "Regular expression matching CamelCase words.") + +(defcustom org-wikinodes-active t + "Should CamelCase links be active in the current file?" + :group 'org-wikinodes + :type 'boolean) +(put 'org-wikinodes-active 'safe-local-variable 'booleanp) + +(defcustom org-wikinodes-scope 'file + "The scope of searches for wiki targets. +Allowed values are: + +file Search for targets in the current file only +directory Search for targets in all org files in the current directory" + :group 'org-wikinodes + :type '(choice + (const :tag "Find targets in current file" file) + (const :tag "Find targets in current directory" directory))) + +(defcustom org-wikinodes-create-targets 'query + "Non-nil means create Wiki target when following a wiki link fails. +Allowed values are: + +nil never create node, just throw an error if the target does not exist +query ask the user what to do +t create the node in the current buffer +\"file.org\" create the node in the file \"file.org\", in the same directory + +If you are using wiki links across files, you need to set `org-wikinodes-scope' +to `directory'." + :group 'org-wikinodes + :type '(choice + (const :tag "Never automatically create node" nil) + (const :tag "In current file" t) + (file :tag "In one special file\n") + (const :tag "Query the user" query))) + +;;; Link activation + +(defun org-wikinodes-activate-links (limit) + "Activate CamelCase words as links to Wiki targets." + (when org-wikinodes-active + (let (case-fold-search) + (if (re-search-forward org-wikinodes-camel-regexp limit t) + (if (equal (char-after (point-at-bol)) ?*) + (progn + ;; in heading - deactivate flyspell + (org-remove-flyspell-overlays-in (match-beginning 0) + (match-end 0)) + t) + ;; this is a wiki link + (org-remove-flyspell-overlays-in (match-beginning 0) + (match-end 0)) + (add-text-properties (match-beginning 0) (match-end 0) + (list 'mouse-face 'highlight + 'face 'org-link + 'keymap org-mouse-map + 'help-echo "Wiki Link")) + t))))) + +;;; Following links and creating non-existing target nodes + +(defun org-wikinodes-open-at-point () + "Check if the cursor is on a Wiki link and follow the link. + +This function goes into `org-open-at-point-functions'." + (and org-wikinodes-active + (not (org-at-heading-p)) + (let (case-fold-search) (org-in-regexp org-wikinodes-camel-regexp)) + (progn (org-wikinodes-follow-link (match-string 0)) t))) + +(defun org-wikinodes-follow-link (target) + "Follow a wiki link to TARGET. + +This need to be found as an exact headline match, either in the current +buffer, or in any .org file in the current directory, depending on the +variable `org-wikinodes-scope'. + +If a target headline is not found, it may be created according to the +setting of `org-wikinodes-create-targets'." + (if current-prefix-arg (org-wikinodes-clear-directory-targets-cache)) + (let ((create org-wikinodes-create-targets) + visiting buffer m pos file rpl) + (setq pos + (or (org-find-exact-headline-in-buffer target (current-buffer)) + (and (eq org-wikinodes-scope 'directory) + (setq file (org-wikinodes-which-file + target (file-name-directory (buffer-file-name)))) + (org-find-exact-headline-in-buffer + target (or (get-file-buffer file) + (find-file-noselect file)))))) + (if pos + (progn + (org-mark-ring-push (point)) + (org-goto-marker-or-bmk pos) + (move-marker pos nil)) + (when (eq create 'query) + (if (eq org-wikinodes-scope 'directory) + (progn + (message "Node \"%s\" does not exist. Should it be created? +\[RET] in this buffer [TAB] in another file [q]uit" target) + (setq rpl (read-char-exclusive)) + (cond + ((member rpl '(?\C-g ?q)) (error "Abort")) + ((equal rpl ?\C-m) (setq create t)) + ((equal rpl ?\C-i) + (setq create (file-name-nondirectory + (read-file-name "Create in file: ")))) + (t (error "Invalid selection")))) + (if (y-or-n-p (format "Create new node \"%s\" in current buffer? " + target)) + (setq create t) + (error "Abort")))) + + (cond + ((not create) + ;; We are not allowed to create the new node + (error "No match for link to \"%s\"" target)) + ((stringp create) + ;; Make new node in another file + (org-mark-ring-push (point)) + (org-pop-to-buffer-same-window (find-file-noselect create)) + (goto-char (point-max)) + (or (bolp) (newline)) + (insert "\n* " target "\n") + (backward-char 1) + (org-wikinodes-add-target-to-cache target) + (message "New Wiki target `%s' created in file \"%s\"" + target create)) + (t + ;; Make new node in current buffer + (org-mark-ring-push (point)) + (goto-char (point-max)) + (or (bolp) (newline)) + (insert "* " target "\n") + (backward-char 1) + (org-wikinodes-add-target-to-cache target) + (message "New Wiki target `%s' created in current buffer" + target)))))) + +;;; The target cache + +(defvar org-wikinodes-directory-targets-cache nil) + +(defun org-wikinodes-clear-cache-when-on-target () + "When on a headline that is a Wiki target, clear the cache." + (when (and (org-at-heading-p) + (org-in-regexp (format org-complex-heading-regexp-format + org-wikinodes-camel-regexp)) + (org-in-regexp org-wikinodes-camel-regexp)) + (org-wikinodes-clear-directory-targets-cache) + t)) + +(defun org-wikinodes-clear-directory-targets-cache () + "Clear the cache where to find wiki targets." + (interactive) + (setq org-wikinodes-directory-targets-cache nil) + (message "Wiki target cache cleared, so that it will update when used again")) + +(defun org-wikinodes-get-targets () + "Return a list of all wiki targets in the current buffer." + (let ((re (format org-complex-heading-regexp-format + org-wikinodes-camel-regexp)) + (case-fold-search nil) + targets) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (while (re-search-forward re nil t) + (push (match-string-no-properties 4) targets)))) + (nreverse targets))) + +(defun org-wikinodes-get-links-for-directory (dir) + "Return an alist that connects wiki links to files in directory DIR." + (let ((files (directory-files dir nil "\\`[^.#].*\\.org\\'")) + (org-inhibit-startup t) + target-file-alist file visiting m buffer) + (while (setq file (pop files)) + (setq visiting (org-find-base-buffer-visiting file)) + (setq buffer (or visiting (find-file-noselect file))) + (with-current-buffer buffer + (mapc + (lambda (target) + (setq target-file-alist (cons (cons target file) target-file-alist))) + (org-wikinodes-get-targets))) + (or visiting (kill-buffer buffer))) + target-file-alist)) + +(defun org-wikinodes-add-target-to-cache (target &optional file) + (setq file (or file buffer-file-name (error "No file for new wiki target"))) + (set-text-properties 0 (length target) nil target) + (let ((dir (file-name-directory (expand-file-name file))) + a) + (setq a (assoc dir org-wikinodes-directory-targets-cache)) + (if a + ;; Push the new target onto the existing list + (push (cons target (expand-file-name file)) (cdr a)) + ;; Call org-wikinodes-which-file so that the cache will be filled + (org-wikinodes-which-file target dir)))) + +(defun org-wikinodes-which-file (target &optional directory) + "Return the file for wiki headline TARGET DIRECTORY. +If there is no such wiki target, return nil." + (let* ((directory (expand-file-name (or directory default-directory))) + (founddir (assoc directory org-wikinodes-directory-targets-cache)) + (foundfile (cdr (assoc target (cdr founddir))))) + (or foundfile + (and (push (cons directory (org-wikinodes-get-links-for-directory directory)) + org-wikinodes-directory-targets-cache) + (cdr (assoc target (cdr (assoc directory + org-wikinodes-directory-targets-cache)))))))) + +;;; Exporting Wiki links + +(defvar target) +(defvar target-alist) +(defvar last-section-target) +(defvar org-export-target-aliases) +(defun org-wikinodes-set-wiki-targets-during-export (_) + (let ((line (buffer-substring (point-at-bol) (point-at-eol))) + (case-fold-search nil) + wtarget a) + (when (string-match (format org-complex-heading-regexp-format + org-wikinodes-camel-regexp) + line) + (setq wtarget (match-string 4 line)) + (push (cons wtarget target) target-alist) + (setq a (or (assoc last-section-target org-export-target-aliases) + (progn + (push (list last-section-target) + org-export-target-aliases) + (car org-export-target-aliases)))) + (push (caar target-alist) (cdr a))))) + +(defun org-wikinodes-process-links-for-export (_) + "Process Wiki links in the export preprocess buffer. +Try to find target matches in the wiki scope and replace CamelCase words +with working links." + (let ((re org-wikinodes-camel-regexp) + (case-fold-search nil) + link file) + (goto-char (point-min)) + (while (re-search-forward re nil t) + (unless (save-match-data + (or (org-at-heading-p) + (org-in-regexp org-bracket-link-regexp) + (org-in-regexp org-plain-link-re) + (org-in-regexp "<<[^<>]+>>"))) + (setq link (match-string 0)) + (delete-region (match-beginning 0) (match-end 0)) + (save-match-data + (cond + ((org-find-exact-headline-in-buffer link (current-buffer)) + ;; Found in current buffer + (insert (format "[[*%s][%s]]" link link))) + ((eq org-wikinodes-scope 'file) + ;; No match in file, and other files are not allowed + (insert (format "%s" link))) + (t ;; No match for this link + (insert (format "%s" link))))))))) + +;;; Hook the WikiNode mechanism into Org + +;; `C-c C-o' should follow wiki links +(add-hook 'org-open-at-point-functions 'org-wikinodes-open-at-point) + +;; `C-c C-c' should clear the cache +(add-hook 'org-ctrl-c-ctrl-c-hook 'org-wikinodes-clear-cache-when-on-target) + +;; Make Wiki haeding create additional link names for headlines +(add-hook 'org-export-before-parsing-hook + 'org-wikinodes-set-wiki-targets-during-export) + +;; Turn Wiki links into links the exporter will treat correctly +(add-hook 'org-export-before-parsing-hook + 'org-wikinodes-process-links-for-export) + +;; Activate CamelCase words as part of Org mode font lock + +(defun org-wikinodes-add-to-font-lock-keywords () + "Add wikinode CamelCase highlighting to `org-font-lock-extra-keywords'." + (let ((m (member '(org-activate-links) org-font-lock-extra-keywords))) + (if m (push '(org-wikinodes-activate-links) (cdr m)) + (message "Failed to add wikinodes to `org-font-lock-extra-keywords'.")))) + +(add-hook 'org-font-lock-set-keywords-hook + 'org-wikinodes-add-to-font-lock-keywords) + +(provide 'org-wikinodes) + +;;; org-wikinodes.el ends here diff --git a/contrib/lisp/org-wl.el b/contrib/lisp/org-wl.el new file mode 100644 index 0000000..4f74d47 --- /dev/null +++ b/contrib/lisp/org-wl.el @@ -0,0 +1,302 @@ +;;; org-wl.el --- Support for links to Wanderlust messages from within Org-mode + +;; Copyright (C) 2004-2017 Free Software Foundation, Inc. + +;; Author: Tokuya Kameshima <kames at fa2 dot so-net dot ne dot jp> +;; David Maus <dmaus at ictsoc dot de> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; +;; This file is not part of GNU Emacs. +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file implements links to Wanderlust messages from within Org-mode. +;; Org-mode loads this module by default - if this is not what you want, +;; configure the variable `org-modules'. + +;;; Code: + +(require 'org) + +(defgroup org-wl nil + "Options concerning the Wanderlust link." + :tag "Org Startup" + :group 'org-link) + +(defcustom org-wl-link-to-refile-destination t + "Create a link to the refile destination if the message is marked as refile." + :group 'org-wl + :type 'boolean) + +(defcustom org-wl-link-remove-filter nil + "Remove filter condition if message is filter folder." + :group 'org-wl + :type 'boolean) + +(defcustom org-wl-shimbun-prefer-web-links nil + "If non-nil create web links for shimbun messages." + :group 'org-wl + :type 'boolean) + +(defcustom org-wl-nntp-prefer-web-links nil + "If non-nil create web links for nntp messages. +When folder name contains string \"gmane\" link to gmane, +googlegroups otherwise." + :type 'boolean + :group 'org-wl) + +(defcustom org-wl-disable-folder-check t + "Disable check for new messages when open a link." + :type 'boolean + :group 'org-wl) + +(defcustom org-wl-namazu-default-index nil + "Default namazu search index." + :type '(choice (const nil) (directory)) + :group 'org-wl) + +;; Declare external functions and variables +(declare-function elmo-folder-exists-p "ext:elmo" (folder) t) +(declare-function elmo-message-entity-field "ext:elmo-msgdb" + (entity field &optional type)) +(declare-function elmo-message-field "ext:elmo" + (folder number field &optional type) t) +(declare-function elmo-msgdb-overview-get-entity "ext:elmo" (id msgdb) t) +;; Backward compatibility to old version of wl +(declare-function wl "ext:wl" () t) +(declare-function wl-summary-buffer-msgdb "ext:wl-folder" () t) +(declare-function wl-summary-jump-to-msg-by-message-id "ext:wl-summary" + (&optional id)) +(declare-function wl-summary-jump-to-msg "ext:wl-summary" + (&optional number beg end)) +(declare-function wl-summary-line-from "ext:wl-summary" ()) +(declare-function wl-summary-line-subject "ext:wl-summary" ()) +(declare-function wl-summary-message-number "ext:wl-summary" ()) +(declare-function wl-summary-redisplay "ext:wl-summary" (&optional arg)) +(declare-function wl-summary-registered-temp-mark "ext:wl-action" (number)) +(declare-function wl-folder-goto-folder-subr "ext:wl-folder" + (&optional folder sticky)) +(declare-function wl-folder-get-petname "ext:wl-folder" (name)) +(declare-function wl-folder-get-entity-from-buffer "ext:wl-folder" + (&optional getid)) +(declare-function wl-folder-buffer-group-p "ext:wl-folder") +(defvar wl-init) +(defvar wl-summary-buffer-elmo-folder) +(defvar wl-summary-buffer-folder-name) +(defvar wl-folder-group-regexp) +(defvar wl-auto-check-folder-name) +(defvar elmo-nntp-default-server) + +(defconst org-wl-folder-types + '(("%" . imap) ("-" . nntp) ("+" . mh) ("=" . spool) + ("$" . archive) ("&" . pop) ("@" . shimbun) ("[" . search) + ("*" . multi) ("/" . filter) ("|" . pipe) ("'" . internal)) + "List of folder indicators. See Wanderlust manual, section 3.") + +;; Install the link type +(org-link-set-parameters "wl" :follow #'org-wl-open :store #'org-wl-store-link) + +;; Implementation + +(defun org-wl-folder-type (folder) + "Return symbol that indicates the type of FOLDER. +FOLDER is the wanderlust folder name. The first character of the +folder name determines the folder type." + (let* ((indicator (substring folder 0 1)) + (type (cdr (assoc indicator org-wl-folder-types)))) + ;; maybe access or file folder + (when (not type) + (setq type + (cond + ((and (>= (length folder) 5) + (string= (substring folder 0 5) "file:")) + 'file) + ((and (>= (length folder) 7) + (string= (substring folder 0 7) "access:")) + 'access) + (t + nil)))) + type)) + +(defun org-wl-message-field (field entity) + "Return content of FIELD in ENTITY. +FIELD is a symbol of a rfc822 message header field. +ENTITY is a message entity." + (let ((content (elmo-message-entity-field entity field 'string))) + (if (listp content) (car content) content))) + +(defun org-wl-store-link () + "Store a link to a WL message or folder." + (unless (eobp) + (cond + ((memq major-mode '(wl-summary-mode mime-view-mode)) + (org-wl-store-link-message)) + ((eq major-mode 'wl-folder-mode) + (org-wl-store-link-folder)) + (t + nil)))) + +(defun org-wl-store-link-folder () + "Store a link to a WL folder." + (let* ((folder (wl-folder-get-entity-from-buffer)) + (petname (wl-folder-get-petname folder)) + (link (concat "wl:" folder))) + (save-excursion + (beginning-of-line) + (unless (and (wl-folder-buffer-group-p) + (looking-at wl-folder-group-regexp)) + (org-store-link-props :type "wl" :description petname + :link link) + link)))) + +(defun org-wl-store-link-message () + "Store a link to a WL message." + (save-excursion + (let ((buf (if (eq major-mode 'wl-summary-mode) + (current-buffer) + (and (boundp 'wl-message-buffer-cur-summary-buffer) + wl-message-buffer-cur-summary-buffer)))) + (when buf + (with-current-buffer buf + (let* ((msgnum (wl-summary-message-number)) + (mark-info (wl-summary-registered-temp-mark msgnum)) + (folder-name + (if (and org-wl-link-to-refile-destination + mark-info + (equal (nth 1 mark-info) "o")) ; marked as refile + (nth 2 mark-info) + wl-summary-buffer-folder-name)) + (folder-type (org-wl-folder-type folder-name)) + (wl-message-entity + (if (fboundp 'elmo-message-entity) + (elmo-message-entity + wl-summary-buffer-elmo-folder msgnum) + (elmo-msgdb-overview-get-entity + msgnum (wl-summary-buffer-msgdb)))) + (message-id + (org-wl-message-field 'message-id wl-message-entity)) + (message-id-no-brackets + (org-unbracket-string "<" ">" message-id)) + (from (org-wl-message-field 'from wl-message-entity)) + (to (org-wl-message-field 'to wl-message-entity)) + (xref (org-wl-message-field 'xref wl-message-entity)) + (subject (org-wl-message-field 'subject wl-message-entity)) + (date (org-wl-message-field 'date wl-message-entity)) + desc link) + + ;; remove text properties of subject string to avoid possible bug + ;; when formatting the subject + ;; (Emacs bug #5306, fixed) + (set-text-properties 0 (length subject) nil subject) + + ;; maybe remove filter condition + (when (and (eq folder-type 'filter) org-wl-link-remove-filter) + (while (eq (org-wl-folder-type folder-name) 'filter) + (setq folder-name + (replace-regexp-in-string "^/[^/]+/" "" folder-name)))) + + ;; maybe create http link + (cond + ((and (eq folder-type 'shimbun) + org-wl-shimbun-prefer-web-links xref) + (org-store-link-props :type "http" :link xref :description subject + :from from :to to :message-id message-id + :message-id-no-brackets message-id-no-brackets + :subject subject)) + ((and (eq folder-type 'nntp) org-wl-nntp-prefer-web-links) + (setq link + (format + (if (string-match "gmane\\." folder-name) + "http://mid.gmane.org/%s" + "http://groups.google.com/groups/search?as_umsgid=%s") + (org-fixup-message-id-for-http message-id))) + (org-store-link-props :type "http" :link link :description subject + :from from :to to :message-id message-id + :message-id-no-brackets message-id-no-brackets + :subject subject)) + (t + (org-store-link-props :type "wl" :from from :to to + :subject subject :message-id message-id + :message-id-no-brackets message-id-no-brackets) + (setq desc (org-email-link-description)) + (setq link (concat "wl:" folder-name "#" message-id-no-brackets)) + (org-add-link-props :link link :description desc))) + (org-add-link-props :date date) + (or link xref))))))) + +(defun org-wl-open-nntp (path) + "Follow the nntp: link specified by PATH." + (let* ((spec (split-string path "/")) + (server (split-string (nth 2 spec) "@")) + (group (nth 3 spec)) + (article (nth 4 spec))) + (org-wl-open + (concat "-" group ":" (if (cdr server) + (car (split-string (car server) ":")) + "") + (if (string= elmo-nntp-default-server (nth 2 spec)) + "" + (concat "@" (or (cdr server) (car server)))) + (if article (concat "#" article) ""))))) + +(defun org-wl-open (path) + "Follow the WL message link specified by PATH. +When called with one prefix, open message in namazu search folder +with `org-wl-namazu-default-index' as search index. When called +with two prefixes or `org-wl-namazu-default-index' is nil, ask +for namazu index." + (require 'wl) + (let ((wl-auto-check-folder-name + (if org-wl-disable-folder-check + 'none + wl-auto-check-folder-name))) + (unless wl-init (wl)) + ;; XXX: The imap-uw's MH folder names start with "%#". + (if (not (string-match "\\`\\(\\(?:%#\\)?[^#]+\\)\\(#\\(.*\\)\\)?" path)) + (error "Error in Wanderlust link")) + (let ((folder (match-string 1 path)) + (article (match-string 3 path))) + ;; maybe open message in namazu search folder + (when current-prefix-arg + (setq folder (concat "[" article "]" + (if (and (equal current-prefix-arg '(4)) + org-wl-namazu-default-index) + org-wl-namazu-default-index + (read-directory-name "Namazu index: "))))) + (if (not (elmo-folder-exists-p (with-no-warnings + (wl-folder-get-elmo-folder folder)))) + (error "No such folder: %s" folder)) + (let ((old-buf (current-buffer)) + (old-point (point-marker))) + (wl-folder-goto-folder-subr folder) + (with-current-buffer old-buf + ;; XXX: `wl-folder-goto-folder-subr' moves point to the + ;; beginning of the current line. So, restore the point + ;; in the old buffer. + (goto-char old-point)) + (when article + (if (string-match-p "@" article) + (wl-summary-jump-to-msg-by-message-id (org-add-angle-brackets + article)) + (or (wl-summary-jump-to-msg (string-to-number article)) + (error "No such message: %s" article))) + (wl-summary-redisplay)))))) + +(provide 'org-wl) + +;;; org-wl.el ends here diff --git a/contrib/lisp/orgtbl-sqlinsert.el b/contrib/lisp/orgtbl-sqlinsert.el new file mode 100644 index 0000000..8fba18f --- /dev/null +++ b/contrib/lisp/orgtbl-sqlinsert.el @@ -0,0 +1,118 @@ +;;; orgtbl-sqlinsert.el --- orgtbl to SQL insert statements. + +;; Copyright (C) 2008-2017 Free Software Foundation + +;; Author: Jason Riedy <jason@acm.org> +;; Keywords: org, tables, sql + +;; This file is not part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Converts an orgtbl to a sequence of SQL insertion commands. +;; Table cells are quoted and escaped very conservatively. + +;;; Code: + +(defun orgtbl-to-sqlinsert (table params) + "Convert the orgtbl-mode TABLE to SQL insert statements. +TABLE is a list, each entry either the symbol `hline' for a horizontal +separator line, or a list of fields for that line. +PARAMS is a property list of parameters that can influence the conversion. + +Names and strings are modified slightly by default. Single-ticks +are doubled as per SQL's standard mechanism. Backslashes and +dollar signs are deleted. And tildes are changed to spaces. +These modifications were chosed for use with TeX. See +ORGTBL-SQL-STRIP-AND-QUOTE. + +Supports all parameters from ORGTBL-TO-GENERIC. New to this function +are: + +:sqlname The name of the database table; defaults to the name of the + target region. + +:nowebname If not nil, used as a wrapping noweb fragment name. + +The most important parameters of ORGTBL-TO-GENERIC for SQL are: + +:splice When set to t, return only insert statements, don't wrap + them in a transaction. Default is nil. + +:tstart, :tend + The strings used to begin and commit the transaction. + +:hfmt A function that gathers the quoted header names into a + dynamically scoped variable HDRLIST. Probably should + not be changed by the user. + +The general parameters :skip and :skipcols have already been applied when +this function is called." + (let* (hdrlist + (alignment (mapconcat (lambda (x) (if x "r" "l")) + org-table-last-alignment "")) + (nowebname (plist-get params :nowebname)) + (breakvals (plist-get params :breakvals)) + (firstheader t) + (*orgtbl-default-fmt* 'orgtbl-sql-strip-and-quote) + (params2 + (list + :sqlname (plist-get params :sqlname) + :tstart (lambda () (concat (if nowebname + (format "<<%s>>= \n" nowebname) + "") + "BEGIN TRANSACTION;")) + :tend (lambda () (concat "COMMIT;" (if nowebname "\n@ " ""))) + :hfmt (lambda (f) (progn (if firstheader (push f hdrlist) ""))) + :hlfmt (lambda (&rest cells) (setq firstheader nil)) + :lstart (lambda () (concat "INSERT INTO " + sqlname "( " + (mapconcat 'identity (reverse hdrlist) + ", ") + " )" (if breakvals "\n" " ") + "VALUES ( ")) + :lend " );" + :sep " , " + :hline nil + :remove-nil-lines t)) + (params (org-combine-plists params2 params)) + (sqlname (plist-get params :sqlname))) + (orgtbl-to-generic table params))) + +(defun orgtbl-sql-quote (str) + "Convert single ticks to doubled single ticks and wrap in single ticks." + (concat "'" (mapconcat 'identity (split-string str "'") "''") "'")) + +(defun orgtbl-sql-strip-dollars-escapes-tildes (str) + "Strip dollarsigns and backslash escapes, replace tildes with spaces." + (mapconcat 'identity + (split-string (mapconcat 'identity + (split-string str "\\$\\|\\\\") + "") + "~") + " ")) + +(defun orgtbl-sql-strip-and-quote (str) + "Apply ORGBTL-SQL-QUOTE and ORGTBL-SQL-STRIP-DOLLARS-ESCAPES-TILDES +to sanitize STR for use in SQL statements." + (cond ((stringp str) + (orgtbl-sql-quote (orgtbl-sql-strip-dollars-escapes-tildes str))) + ((sequencep str) (mapcar 'orgtbl-sql-strip-and-quote str)) + (t nil))) + +(provide 'orgtbl-sqlinsert) + +;;; orgtbl-sqlinsert.el ends here diff --git a/contrib/lisp/ox-bibtex.el b/contrib/lisp/ox-bibtex.el new file mode 100644 index 0000000..fb34a5e --- /dev/null +++ b/contrib/lisp/ox-bibtex.el @@ -0,0 +1,431 @@ +;;; ox-bibtex.el --- Export bibtex fragments + +;; Copyright (C) 2009-2014 Taru Karttunen + +;; Author: Taru Karttunen <taruti@taruti.net> +;; Nicolas Goaziou <n dot goaziou at gmail dot com> +;; This file is not currently 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 is an utility to handle BibTeX export to LaTeX, html and ascii +;; exports. For HTML and ascii it uses the bibtex2html software from: +;; +;; http://www.lri.fr/~filliatr/bibtex2html/ +;; +;; For ascii it uses the pandoc software from: +;; +;; http://johnmacfarlane.net/pandoc/ +;; +;; It also introduces "cite" syntax for Org links. +;; +;; The usage is as follows: +;; +;; #+BIBLIOGRAPHY: bibfilename stylename optional-options +;; +;; e.g. given foo.bib and using style plain: +;; +;; #+BIBLIOGRAPHY: foo plain option:-d +;; +;; "stylename" can also be "nil", in which case no style will be used. +;; +;; Full filepaths are also possible: +;; +;; #+BIBLIOGRAPHY: /home/user/Literature/foo.bib plain option:-d +;; +;; Optional options are of the form: +;; +;; option:-foobar pass '-foobar' to bibtex2html +;; +;; e.g., +;; +;; option:-d sort by date +;; option:-a sort as BibTeX (usually by author) *default* +;; option:-u unsorted i.e. same order as in .bib file +;; option:-r reverse the sort +;; +;; See the bibtex2html man page for more. Multiple options can be +;; combined like: +;; +;; option:-d option:-r +;; +;; Limiting to only the entries cited in the document: +;; +;; limit:t +;; +;; For LaTeX export this simply inserts the lines +;; +;; \bibliographystyle{plain} +;; \bibliography{foo} +;; +;; into the TeX file when exporting. +;; +;; For HTML export it: +;; 1) converts all \cite{foo} and [[cite:foo]] to links to the +;; bibliography, +;; 2) creates a foo.html and foo_bib.html, +;; 3) includes the contents of foo.html in the exported HTML file. +;; +;; For ascii export it: +;; 1) converts all \cite{foo} and [[cite:foo]] to links to the +;; bibliography, +;; 2) creates a foo.txt and foo_bib.html, +;; 3) includes the contents of foo.txt in the exported ascii file. +;; +;; For LaTeX export it: +;; 1) converts all [[cite:foo]] to \cite{foo}. + +;; Initialization + +(require 'cl-lib) + +;;; Internal Functions + +(defun org-bibtex-get-file (keyword) + "Return bibliography file as a string. +KEYWORD is a \"BIBLIOGRAPHY\" keyword. If no file is found, +return nil instead." + (let ((value (org-element-property :value keyword))) + (and value + (string-match "\\(\\S-+\\)[ \t]+\\(\\S-+\\)\\(.*\\)" value) + (match-string 1 value)))) + +(defun org-bibtex-get-style (keyword) + "Return bibliography style as a string. +KEYWORD is a \"BIBLIOGRAPHY\" keyword. If no style is found, +return nil instead." + (let ((value (org-element-property :value keyword))) + (and value + (string-match "\\(\\S-+\\)[ \t]+\\(\\S-+\\)\\(.*\\)" value) + (match-string 2 value)))) + +(defun org-bibtex-get-arguments (keyword) + "Return \"bibtex2html\" arguments specified by the user. +KEYWORD is a \"BIBLIOGRAPHY\" keyword. Return value is a plist +containing `:options' and `:limit' properties. The former +contains a list of strings to be passed as options to +\"bibtex2html\" process. The latter contains a boolean." + (let ((value (org-element-property :value keyword))) + (and value + (string-match "\\(\\S-+\\)[ \t]+\\(\\S-+\\)\\(.*\\)" value) + (let (options limit) + (dolist (arg (org-split-string (match-string 3 value)) + ;; Return value. + (list :options (nreverse options) :limit limit)) + (let* ((s (split-string arg ":")) + (key (car s)) + (value (nth 1 s))) + (cond ((equal "limit" key) + (setq limit (not (equal "nil" value)))) + ((equal "option" key) (push value options))))))))) + +(defun org-bibtex-citation-p (object) + "Non-nil when OBJECT is a citation." + (cl-case (org-element-type object) + (link (equal (org-element-property :type object) "cite")) + (latex-fragment + (string-match "\\`\\\\cite{" (org-element-property :value object))))) + +(defun org-bibtex-get-citation-key (citation) + "Return key for a given citation, as a string. +CITATION is a `latex-fragment' or `link' type object satisfying +to `org-bibtex-citation-p' predicate." + (if (eq (org-element-type citation) 'link) + (org-element-property :path citation) + (let ((value (org-element-property :value citation))) + (and (string-match "\\`\\\\cite{" value) + (substring value (match-end 0) -1))))) + + +;;; Follow cite: links + +(defun org-bibtex-file nil "Org-mode file of bibtex entries.") + +(defun org-bibtex-goto-citation (&optional citation) + "Visit a citation given its ID." + (interactive) + (let ((citation (or citation (completing-read "Citation: " (obe-citations))))) + (find-file (or org-bibtex-file + (error "`org-bibtex-file' has not been configured"))) + (goto-char (point-min)) + (when (re-search-forward (format " :CUSTOM_ID: %s" citation) nil t) + (outline-previous-visible-heading 1) + t))) + +(let ((jump-fn (car (cl-remove-if-not #'fboundp '(ebib org-bibtex-goto-citation))))) + (org-add-link-type "cite" jump-fn)) + + + +;;; Filters + +(defun org-bibtex-process-bib-files (tree backend info) + "Send each bibliography in parse tree to \"bibtex2html\" process. +Return new parse tree." + (when (org-export-derived-backend-p backend 'ascii 'html) + ;; Initialize dynamically scoped variables. The first one + ;; contain an alist between keyword objects and their HTML + ;; translation. The second one will contain an alist between + ;; citation keys and names in the output (according to style). + (setq org-bibtex-html-entries-alist nil + org-bibtex-html-keywords-alist nil) + (org-element-map tree 'keyword + (lambda (keyword) + (when (equal (org-element-property :key keyword) "BIBLIOGRAPHY") + (let ((arguments (org-bibtex-get-arguments keyword)) + (file (org-bibtex-get-file keyword)) + temp-file + out-file) + ;; Test if filename is given with .bib-extension and strip + ;; it off. Filenames with another extensions will be + ;; untouched and will finally rise an error in bibtex2html. + (setq file (if (equal (file-name-extension file) "bib") + (file-name-sans-extension file) file)) + ;; Outpufiles of bibtex2html will be put into current working directory + ;; so define a variable for this. + (setq out-file (file-name-sans-extension + (file-name-nondirectory file))) + ;; limit is set: collect citations throughout the document + ;; in TEMP-FILE and pass it to "bibtex2html" as "-citefile" + ;; argument. + (when (plist-get arguments :limit) + (let ((citations + (org-element-map tree '(latex-fragment link) + (lambda (object) + (and (org-bibtex-citation-p object) + (org-bibtex-get-citation-key object)))))) + (with-temp-file (setq temp-file (make-temp-file "ox-bibtex")) + (insert (mapconcat 'identity citations "\n"))) + (setq arguments + (plist-put arguments + :options + (append (plist-get arguments :options) + (list "-citefile" temp-file)))))) + ;; Call "bibtex2html" on specified file. + (unless (eq 0 (apply + 'call-process + (append '("bibtex2html" nil nil nil) + '("-a" "-nodoc" "-noheader" "-nofooter") + (let ((style + (org-not-nil + (org-bibtex-get-style keyword)))) + (and style (list "--style" style))) + (plist-get arguments :options) + (list (concat file ".bib"))))) + (error "Executing bibtex2html failed")) + (and temp-file (delete-file temp-file)) + ;; Open produced HTML file, and collect Bibtex key names + (with-temp-buffer + (insert-file-contents (concat out-file ".html")) + ;; Update `org-bibtex-html-entries-alist'. + (goto-char (point-min)) + (while (re-search-forward + "a name=\"\\([-_a-zA-Z0-9:]+\\)\">\\([^<]+\\)" nil t) + (push (cons (match-string 1) (match-string 2)) + org-bibtex-html-entries-alist))) + ;; Open produced HTML file, wrap references within a block and + ;; return it. + (with-temp-buffer + (cond + ((org-export-derived-backend-p backend 'html) + (insert (format "<div id=\"bibliography\">\n<h2>%s</h2>\n" + (org-export-translate "References" :html info))) + (insert-file-contents (concat out-file ".html")) + (goto-char (point-max)) + (insert "\n</div>")) + ((org-export-derived-backend-p backend 'ascii) + ;; convert HTML references to text w/pandoc + (unless (eq 0 (call-process "pandoc" nil nil nil + (concat out-file ".html") + "-o" + (concat out-file ".txt"))) + (error "Executing pandoc failed")) + (insert + (format + "%s\n==========\n\n" + (org-export-translate + "References" + (intern (format ":%s" (plist-get info :ascii-charset))) + info))) + (insert-file-contents (concat out-file ".txt")) + (goto-char (point-min)) + (while (re-search-forward + "\\[ \\[bib\\][^ ]+ \\(\\]\\||[\n\r]\\)" nil t) + (replace-match "")) + (goto-char (point-min)) + (while (re-search-forward "\\( \\]\\| \\]\\| |\\)" nil t) + (replace-match "")) + (goto-char (point-min)) + (while (re-search-forward "[\n\r]\\([\n\r][\n\r]\\)" nil t) + (replace-match "\\1")))) + ;; Update `org-bibtex-html-keywords-alist'. + (push (cons keyword (buffer-string)) + org-bibtex-html-keywords-alist))))))) + ;; Return parse tree unchanged. + tree) + +(defun org-bibtex-merge-contiguous-citations (tree backend info) + "Merge all contiguous citation in parse tree. +As a side effect, this filter will also turn all \"cite\" links +into \"\\cite{...}\" LaTeX fragments and will extract options. +Cite options are placed into square brackets at the beginning of +the \"\\cite\" command for the LaTeX backend, and are removed for +the HTML and ASCII backends." + (when (org-export-derived-backend-p backend 'html 'latex 'ascii) + (org-element-map tree '(link latex-fragment) + (lambda (object) + (when (org-bibtex-citation-p object) + (let ((new-citation (list 'latex-fragment + (list :value "" + :post-blank (org-element-property + :post-blank object)))) + option) + ;; Insert NEW-CITATION right before OBJECT. + (org-element-insert-before new-citation object) + ;; Remove all subsequent contiguous citations from parse + ;; tree, keeping only their citation key. + (let ((keys (list (org-bibtex-get-citation-key object))) + next) + (while (and (setq next (org-export-get-next-element object info)) + (or (and (stringp next) + (not (string-match-p "\\S-" next))) + (org-bibtex-citation-p next))) + (unless (stringp next) + (push (org-bibtex-get-citation-key next) keys)) + (org-element-extract-element object) + (setq object next)) + ;; Find any options in keys, e.g., "(Chapter 2)key" has + ;; the option "Chapter 2". + (setq keys + (mapcar + (lambda (k) + (if (string-match "^(\\([^)]\+\\))\\(.*\\)" k) + (progn + (when (org-export-derived-backend-p backend 'latex) + (setq option (format "[%s]" (match-string 1 k)))) + (match-string 2 k)) + k)) + keys)) + (org-element-extract-element object) + ;; Eventually merge all keys within NEW-CITATION. Also + ;; ensure NEW-CITATION has the same :post-blank property + ;; as the last citation removed. + (org-element-put-property + new-citation + :post-blank (org-element-property :post-blank object)) + (org-element-put-property + new-citation + :value (format "\\cite%s{%s}" + (or option "") + (mapconcat 'identity (nreverse keys) ","))))))))) + tree) + +(eval-after-load 'ox + '(progn (add-to-list 'org-export-filter-parse-tree-functions + 'org-bibtex-process-bib-files) + (add-to-list 'org-export-filter-parse-tree-functions + 'org-bibtex-merge-contiguous-citations))) + + + +;;; LaTeX Part + +(defadvice org-latex-keyword (around bibtex-keyword) + "Translate \"BIBLIOGRAPHY\" keywords into LaTeX syntax. +Fallback to `latex' back-end for other keywords." + (let ((keyword (ad-get-arg 0))) + (if (not (equal (org-element-property :key keyword) "BIBLIOGRAPHY")) + ad-do-it + (let ((file (org-bibtex-get-file keyword)) + (style (org-not-nil (org-bibtex-get-style keyword)))) + (setq ad-return-value + (when file + (concat (and style (format "\\bibliographystyle{%s}\n" style)) + (format "\\bibliography{%s}" file)))))))) + +(ad-activate 'org-latex-keyword) + + + +;;; HTML Part + +(defvar org-bibtex-html-entries-alist nil) ; Dynamically scoped. +(defvar org-bibtex-html-keywords-alist nil) ; Dynamically scoped. + + +;;;; Advices + +(defadvice org-html-keyword (around bibtex-keyword) + "Translate \"BIBLIOGRAPHY\" keywords into HTML syntax. +Fallback to `html' back-end for other keywords." + (let ((keyword (ad-get-arg 0))) + (if (not (equal (org-element-property :key keyword) "BIBLIOGRAPHY")) + ad-do-it + (setq ad-return-value + (cdr (assq keyword org-bibtex-html-keywords-alist)))))) + +(defadvice org-html-latex-fragment (around bibtex-citation) + "Translate \"\\cite\" LaTeX fragments into HTML syntax. +Fallback to `html' back-end for other keywords." + (let ((fragment (ad-get-arg 0))) + (if (not (org-bibtex-citation-p fragment)) ad-do-it + (setq ad-return-value + (format "[%s]" + (mapconcat + (lambda (key) + (format "<a href=\"#%s\">%s</a>" + key + (or (cdr (assoc key org-bibtex-html-entries-alist)) + key))) + (org-split-string + (org-bibtex-get-citation-key fragment) ",") ",")))))) + +(ad-activate 'org-html-keyword) +(ad-activate 'org-html-latex-fragment) + + +;;; Ascii Part +(defadvice org-ascii-keyword (around bibtex-keyword) + "Translate \"BIBLIOGRAPHY\" keywords into ascii syntax. +Fallback to `ascii' back-end for other keywords." + (let ((keyword (ad-get-arg 0))) + (if (not (equal (org-element-property :key keyword) "BIBLIOGRAPHY")) + ad-do-it + (setq ad-return-value + (cdr (assq keyword org-bibtex-html-keywords-alist)))))) + +(defadvice org-ascii-latex-fragment (around bibtex-citation) + "Translate \"\\cite\" LaTeX fragments into ascii syntax. +Fallback to `ascii' back-end for other keywords." + (let ((fragment (ad-get-arg 0))) + (if (not (org-bibtex-citation-p fragment)) ad-do-it + (setq ad-return-value + (format "[%s]" + (mapconcat + (lambda (key) + (or (cdr (assoc key org-bibtex-html-entries-alist)) + key)) + (org-split-string + (org-bibtex-get-citation-key fragment) ",") ",")))))) + +(ad-activate 'org-ascii-keyword) +(ad-activate 'org-ascii-latex-fragment) + +(provide 'ox-bibtex) + +;;; ox-bibtex.el ends here diff --git a/contrib/lisp/ox-confluence.el b/contrib/lisp/ox-confluence.el new file mode 100644 index 0000000..9de6ce7 --- /dev/null +++ b/contrib/lisp/ox-confluence.el @@ -0,0 +1,228 @@ +;;; ox-confluence --- Confluence Wiki Back-End for Org Export Engine + +;; Copyright (C) 2012, 2014 Sébastien Delafond + +;; Author: Sébastien Delafond <sdelafond@gmail.com> +;; Keywords: outlines, confluence, wiki + +;; This file is not part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; ox-confluence.el lets you convert Org files to confluence files +;; using the ox.el export engine. +;; +;; Put this file into your load-path and the following into your ~/.emacs: +;; (require 'ox-confluence) +;; +;; Export Org files to confluence: +;; M-x org-confluence-export-as-confluence RET +;; +;;; Code: + +(require 'ox) +(require 'ox-ascii) + +;; Define the backend itself +(org-export-define-derived-backend 'confluence 'ascii + :translate-alist '((bold . org-confluence-bold) + (example-block . org-confluence-example-block) + (fixed-width . org-confluence-fixed-width) + (footnote-definition . org-confluence-empty) + (footnote-reference . org-confluence-empty) + (headline . org-confluence-headline) + (italic . org-confluence-italic) + (item . org-confluence-item) + (link . org-confluence-link) + (paragraph . org-confluence-paragraph) + (property-drawer . org-confluence-property-drawer) + (section . org-confluence-section) + (src-block . org-confluence-src-block) + (strike-through . org-confluence-strike-through) + (table . org-confluence-table) + (table-cell . org-confluence-table-cell) + (table-row . org-confluence-table-row) + (template . org-confluence-template) + (timestamp . org-confluence-timestamp) + (underline . org-confluence-underline))) + +(defcustom org-confluence-lang-alist + '(("sh" . "bash")) + "Map from org-babel language name to confluence wiki language name" + :type '(alist :key-type string :value-type string)) + +;; All the functions we use +(defun org-confluence-bold (bold contents info) + (format "*%s*" contents)) + +(defun org-confluence-empty (empty contents info) + "") + +(defun org-confluence-example-block (example-block contents info) + ;; FIXME: provide a user-controlled variable for theme + (let ((content (org-export-format-code-default example-block info))) + (org-confluence--block "none" "Confluence" content))) + +(defun org-confluence-italic (italic contents info) + (format "_%s_" contents)) + +(defun org-confluence-item (item contents info) + (concat (make-string (1+ (org-confluence--li-depth item)) ?\-) + " " + (org-trim contents))) + +(defun org-confluence-fixed-width (fixed-width contents info) + (format "\{\{%s\}\}" contents)) + +(defun org-confluence-headline (headline contents info) + (let* ((low-level-rank (org-export-low-level-p headline info)) + (text (org-export-data (org-element-property :title headline) + info)) + (todo (org-export-data (org-element-property :todo-keyword headline) + info)) + (level (org-export-get-relative-level headline info)) + (todo-text (if (or (not (plist-get info :with-todo-keywords)) + (string= todo "")) + "" + (format "*{{%s}}* " todo)))) + ;; Else: Standard headline. + (format "h%s. %s%s\n%s" level todo-text text + (if (org-string-nw-p contents) contents "")))) + +(defun org-confluence-link (link desc info) + (let ((raw-link (org-element-property :raw-link link))) + (concat "[" + (when (org-string-nw-p desc) (format "%s|" desc)) + (cond + ((string-match "^confluence:" raw-link) + (replace-regexp-in-string "^confluence:" "" raw-link)) + (t + raw-link)) + "]"))) + +(defun org-confluence-paragraph (paragraph contents info) + "Transcode PARAGRAPH element for Confluence. +CONTENTS is the paragraph contents. INFO is a plist used as +a communication channel." + contents) + +(defun org-confluence-property-drawer (property-drawer contents info) + (and (org-string-nw-p contents) + (format "\{\{%s\}\}" contents))) + +(defun org-confluence-section (section contents info) + contents) + +(defun org-confluence-src-block (src-block contents info) + ;; FIXME: provide a user-controlled variable for theme + (let* ((lang (org-element-property :language src-block)) + (language (or (cdr (assoc lang org-confluence-lang-alist)) lang)) + (content (org-export-format-code-default src-block info))) + (org-confluence--block language "Emacs" content))) + +(defun org-confluence-strike-through (strike-through contents info) + (format "-%s-" contents)) + +(defun org-confluence-table (table contents info) + contents) + +(defun org-confluence-table-row (table-row contents info) + (concat + (if (org-string-nw-p contents) (format "|%s" contents) + "") + (when (org-export-table-row-ends-header-p table-row info) + "|"))) + +(defun org-confluence-table-cell (table-cell contents info) + (let ((table-row (org-export-get-parent table-cell))) + (concat (and (org-export-table-row-starts-header-p table-row info) "|") + (if (= (length contents) 0) " " contents) + "|"))) + +(defun org-confluence-template (contents info) + (let ((depth (plist-get info :with-toc))) + (concat (when depth "\{toc\}\n\n") contents))) + +(defun org-confluence-timestamp (timestamp _contents _info) + "Transcode a TIMESTAMP object from Org to Confluence. +CONTENTS and INFO are ignored." + (let ((translated (org-timestamp-translate timestamp))) + (if (string-prefix-p "[" translated) + (concat "(" (substring translated 1 -1) ")") + translated))) + +(defun org-confluence-underline (underline contents info) + (format "+%s+" contents)) + +(defun org-confluence--block (language theme contents) + (concat "\{code:theme=" theme + (when language (format "|language=%s" language)) + "}\n" + contents + "\{code\}\n")) + +(defun org-confluence--li-depth (item) + "Return depth of a list item; -1 means not a list item" + ;; FIXME check whether it's worth it to cache depth + ;; (it gets recalculated quite a few times while + ;; traversing a list) + (let ((depth -1) + (tag)) + (while (and item + (setq tag (car item)) + (or (eq tag 'item) ; list items interleave with plain-list + (eq tag 'plain-list))) + (when (eq tag 'item) + (incf depth)) + (setq item (org-export-get-parent item))) + depth)) + +;; main interactive entrypoint +(defun org-confluence-export-as-confluence + (&optional async subtreep visible-only body-only ext-plist) + "Export current buffer to a text buffer. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +A non-nil optional argument ASYNC means the process should happen +asynchronously. The resulting buffer should be accessible +through the `org-export-stack' interface. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, strip title, table +of contents and footnote definitions from output. + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +Export is done in a buffer named \"*Org CONFLUENCE Export*\", which +will be displayed when `org-export-show-temporary-export-buffer' +is non-nil." + (interactive) + (org-export-to-buffer 'confluence "*org CONFLUENCE Export*" + async subtreep visible-only body-only ext-plist (lambda () (text-mode)))) + +(provide 'ox-confluence) diff --git a/contrib/lisp/ox-deck.el b/contrib/lisp/ox-deck.el new file mode 100644 index 0000000..427c7d7 --- /dev/null +++ b/contrib/lisp/ox-deck.el @@ -0,0 +1,585 @@ +;;; ox-deck.el --- deck.js Presentation Back-End for Org Export Engine + +;; Copyright (C) 2013, 2014 Rick Frankel + +;; Author: Rick Frankel <emacs at rickster dot com> +;; Keywords: outlines, hypermedia, slideshow + +;; This file is not part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This library implements a deck.js presentation back-end for the Org +;; generic exporter. + +;; Installation +;; ------------- +;; Get a copy of deck.js from http://imakewebthings.com/deck.js/ or +;; the gitub repository at https://github.com/imakewebthings/deck.js. +;; +;; Add the path to the extracted code to the variable +;; `org-deck-directories' There are a number of customization in the +;; org-export-deck group, most of which can be overrriden with buffer +;; local customization (starting with DECK_.) + +;; See ox.el and ox-html.el for more details on how this exporter +;; works (it is derived from ox-html.) + +;; TODOs +;; ------ +;; The title page is formatted using format-spec. This is error prone +;; when details are missing and may insert empty tags, like <h2></h2>, +;; for missing values. + +(require 'ox-html) +(eval-when-compile (require 'cl)) + +(org-export-define-derived-backend 'deck 'html + :menu-entry + '(?d "Export to deck.js HTML Presentation" + ((?H "To temporary buffer" org-deck-export-as-html) + (?h "To file" org-deck-export-to-html) + (?o "To file and open" + (lambda (a s v b) + (if a (org-deck-export-to-html t s v b) + (org-open-file (org-deck-export-to-html nil s v b))))))) + :options-alist + '((:description "DESCRIPTION" nil nil newline) + (:keywords "KEYWORDS" nil nil space) + (:html-link-home "HTML_LINK_HOME" nil nil) + (:html-link-up "HTML_LINK_UP" nil nil) + (:deck-postamble "DECK_POSTAMBLE" nil org-deck-postamble newline) + (:deck-preamble "DECK_PREAMBLE" nil org-deck-preamble newline) + (:html-head-include-default-style "HTML_INCLUDE_DEFAULT_STYLE" "html-style" nil) + (:html-head-include-scripts "HTML_INCLUDE_SCRIPTS" nil nil) + (:deck-base-url "DECK_BASE_URL" nil org-deck-base-url) + (:deck-theme "DECK_THEME" nil org-deck-theme) + (:deck-transition "DECK_TRANSITION" nil org-deck-transition) + (:deck-include-extensions "DECK_INCLUDE_EXTENSIONS" nil + org-deck-include-extensions split) + (:deck-exclude-extensions "DECK_EXCLUDE_EXTENSIONS" nil + org-deck-exclude-extensions split)) + :translate-alist + '((headline . org-deck-headline) + (inner-template . org-deck-inner-template) + (item . org-deck-item) + (link . org-deck-link) + (template . org-deck-template))) + +(defgroup org-export-deck nil + "Options for exporting Org mode files to deck.js HTML Presentations." + :tag "Org Export DECK" + :group 'org-export-html) + +(defcustom org-deck-directories '("./deck.js") + "Directories to search for deck.js components (jquery, +modernizr; core, extensions and themes directories.)" + :group 'org-export-deck + :type '(repeat (string :tag "Directory"))) + +(defun org-deck--cleanup-components (components) + (remove-duplicates + (car (remove 'nil components)) + :test (lambda (x y) + (string= (file-name-nondirectory x) + (file-name-nondirectory y))))) + +(defun org-deck--find-extensions () + "Returns a unique list of all extensions found in +in the extensions directories under `org-deck-directories'" + (org-deck--cleanup-components + (mapcar ; extensions under existing dirs + (lambda (dir) + (when (file-directory-p dir) (directory-files dir t "^[^.]"))) + (mapcar ; possible extension directories + (lambda (x) (expand-file-name "extensions" x)) + org-deck-directories)))) + +(defun org-deck--find-css (type) + "Return a unique list of all the css stylesheets in the themes/TYPE +directories under `org-deck-directories'." + (org-deck--cleanup-components + (mapcar + (lambda (dir) + (let ((css-dir (expand-file-name + (concat (file-name-as-directory "themes") type) dir))) + (when (file-directory-p css-dir) + (directory-files css-dir t "\\.css$")))) + org-deck-directories))) + +(defun org-deck-list-components () + "List all available deck extensions, styles and +transitions (with full paths) to a temporary buffer." + (interactive) + (let ((outbuf (get-buffer-create "*deck.js Extensions*"))) + (with-current-buffer outbuf + (erase-buffer) + (insert "Extensions\n----------\n") + (insert (mapconcat 'identity (org-deck--find-extensions) "\n")) + (insert "\n\nStyles\n------\n") + (insert (mapconcat 'identity (org-deck--find-css "style") "\n")) + (insert "\n\nTransitions\n----------\n") + (insert (mapconcat 'identity (org-deck--find-css "transition") "\n"))) + (switch-to-buffer-other-window outbuf))) + +(defcustom org-deck-include-extensions nil + "If non-nil, list of extensions to include instead of all available. +Can be overriden or set with the DECK_INCLUDE_EXTENSIONS property. +During output generation, the extensions found by +`org-deck--find-extensions' are searched for the appropriate +files (scripts and/or stylesheets) to include in the generated +html. The href/src attributes are created relative to `org-deck-base-url'." + :group 'org-export-deck + :type '(repeat (string :tag "Extension"))) + +(defcustom org-deck-exclude-extensions nil + "If non-nil, list of extensions to exclude. +Can be overriden or set with the DECK_EXCLUDE_EXTENSIONS property." + :group 'org-export-deck + :type '(repeat (string :tag "Extension"))) + +(defcustom org-deck-theme "swiss.css" + "deck.js theme. Can be overriden with the DECK_THEME property. +If this value contains a path component (\"/\"), it is used as a +literal path (url). Otherwise it is prepended with +`org-deck-base-url'/themes/style/." + :group 'org-export-deck + :type 'string) + +(defcustom org-deck-transition "fade.css" + "deck.js transition theme. Can be overriden with the +DECK_TRANSITION property. +If this value contains a path component (\"/\"), it is used as a +literal path (url). Otherwise it is prepended with +`org-deck-base-url'/themes/transition/." + :group 'org-export-deck + :type 'string) + +(defcustom org-deck-base-url "deck.js" + "Url prefix to deck.js base directory containing the core, extensions +and themes directories. +Can be overriden with the DECK_BASE_URL property." + :group 'org-export-deck + :type 'string) + +(defvar org-deck-pre/postamble-styles + `((both "left: 5px; width: 100%;") + (preamble "position: absolute; top: 10px;") + (postamble "")) + "Alist of css styles for the preamble, postamble and both respectively. +Can be overriden in `org-deck-styles'. See also `org-html-divs'.") + +(defcustom org-deck-postamble "<h1>%a - %t</h1>" + "Non-nil means insert a postamble in HTML export. + +When set to a string, use this string +as the postamble. When t, insert a string as defined by the +formatting string in `org-html-postamble-format'. + +When set to a function, apply this function and insert the +returned string. The function takes the property list of export +options as its only argument. + +This is included in the document at the bottom of the content +section, and uses the postamble element and id from +`org-html-divs'. The default places the author and presentation +title at the bottom of each slide. + +The css styling is controlled by `org-deck-pre/postamble-styles'. + +Setting :deck-postamble in publishing projects will take +precedence over this variable." + :group 'org-export-deck + :type '(choice (const :tag "No postamble" nil) + (const :tag "Default formatting string" t) + (string :tag "Custom formatting string") + (function :tag "Function (must return a string)"))) + +(defcustom org-deck-preamble nil + "Non-nil means insert a preamble in HTML export. + +When set to a string, use this string +as the preamble. When t, insert a string as defined by the +formatting string in `org-html-preamble-format'. + +When set to a function, apply this function and insert the +returned string. The function takes the property list of export +options as its only argument. + +This is included in the document at the top of content section, and +uses the preamble element and id from `org-html-divs'. The css +styling is controlled by `org-deck-pre/postamble-styles'. + +Setting :deck-preamble in publishing projects will take +precedence over this variable." + :group 'org-export-deck + :type '(choice (const :tag "No preamble" nil) + (const :tag "Default formatting string" t) + (string :tag "Custom formatting string") + (function :tag "Function (must return a string)"))) + +(defvar org-deck-toc-styles + (mapconcat + 'identity + (list + "#table-of-contents a {color: inherit;}" + "#table-of-contents ul {margin-bottom: 0;}" + "#table-of-contents li {padding: 0;}") "\n") + "Default css styles used for formatting a table of contents slide. +Can be overriden in `org-deck-styles'. +Note that when the headline numbering option is true, a \"list-style: none\" +is automatically added to avoid both numbers and bullets on the toc entries.") + +(defcustom org-deck-styles + " +#title-slide h1 { + position: static; padding: 0; + margin-top: 10%; + -webkit-transform: none; + -moz-transform: none; + -ms-transform: none; + -o-transform: none; + transform: none; +} +#title-slide h2 { + text-align: center; + border:none; + padding: 0; + margin: 0; +}" + "Deck specific CSS styles to include in exported html. +Defaults to styles for the title page." + :group 'org-export-deck + :type 'string) + +(defcustom org-deck-title-slide-template + "<h1>%t</h1> +<h2>%s</h2> +<h2>%a</h2> +<h2>%e</h2> +<h2>%d</h2>" + "Format template to specify title page section. +See `org-html-postamble-format' for the valid elements which +can be included. + +It will be wrapped in the element defined in the :html-container +property, and defaults to the value of `org-html-container-element', +and have the id \"title-slide\"." + :group 'org-export-deck + :type 'string) + +(defun org-deck-toc (depth info) + (concat + (format "<%s id='table-of-contents' class='slide'>\n" + (plist-get info :html-container)) + (format "<h2>%s</h2>\n" (org-html--translate "Table of Contents" info)) + (org-html--toc-text + (mapcar + (lambda (headline) + (let* ((class (org-element-property :HTML_CONTAINER_CLASS headline)) + (section-number + (when + (and (not (org-export-low-level-p headline info)) + (org-export-numbered-headline-p headline info)) + (concat + (mapconcat + 'number-to-string + (org-export-get-headline-number headline info) ".") ". "))) + (title + (concat + section-number + (replace-regexp-in-string ; remove any links in headline... + "</?a[^>]*>" "" + (org-export-data + (org-element-property :title headline) info))))) + (cons + (if (and class (string-match-p "\\<slide\\>" class)) + (format + "<a href='#outline-container-%s'>%s</a>" + (or (org-element-property :CUSTOM_ID headline) + (concat + "sec-" + (mapconcat + 'number-to-string + (org-export-get-headline-number headline info) "-"))) + title) + title) + (org-export-get-relative-level headline info)))) + (org-export-collect-headlines info depth))) + (format "</%s>\n" (plist-get info :html-container)))) + +(defun org-deck--get-packages (info) + (let ((prefix (concat (plist-get info :deck-base-url) "/")) + (theme (plist-get info :deck-theme)) + (transition (plist-get info :deck-transition)) + (include (plist-get info :deck-include-extensions)) + (exclude (plist-get info :deck-exclude-extensions)) + (scripts '()) (sheets '()) (snippets '())) + (add-to-list 'scripts (concat prefix "jquery.min.js")) + (add-to-list 'scripts (concat prefix "core/deck.core.js")) + (add-to-list 'scripts (concat prefix "modernizr.custom.js")) + (add-to-list 'sheets (concat prefix "core/deck.core.css")) + (mapc + (lambda (extdir) + (let* ((name (file-name-nondirectory extdir)) + (dir (file-name-as-directory extdir)) + (path (concat prefix "extensions/" name "/")) + (base (format "deck.%s." name))) + (when (and (or (eq nil include) (member name include)) + (not (member name exclude))) + (when (file-exists-p (concat dir base "js")) + (add-to-list 'scripts (concat path base "js"))) + (when (file-exists-p (concat dir base "css")) + (add-to-list 'sheets (concat path base "css"))) + (when (file-exists-p (concat dir base "html")) + (add-to-list 'snippets (concat dir base "html")))))) + (org-deck--find-extensions)) + (if (not (string-match-p "^[[:space:]]*$" theme)) + (add-to-list 'sheets + (if (file-name-directory theme) theme + (format "%sthemes/style/%s" prefix theme)))) + (if (not (string-match-p "^[[:space:]]*$" transition)) + (add-to-list + 'sheets + (if (file-name-directory transition) transition + (format "%sthemes/transition/%s" prefix transition)))) + (list :scripts (nreverse scripts) :sheets (nreverse sheets) + :snippets snippets))) + +(defun org-deck-inner-template (contents info) + "Return body of document string after HTML conversion. +CONTENTS is the transcoded contents string. INFO is a plist +holding export options." + (concat contents "\n")) + +(defun org-deck-headline (headline contents info) + (let ((org-html-toplevel-hlevel 2) + (class (or (org-element-property :HTML_CONTAINER_CLASS headline) "")) + (level (org-export-get-relative-level headline info))) + (when (and (= 1 level) (not (string-match-p "\\<slide\\>" class))) + (org-element-put-property headline :HTML_CONTAINER_CLASS (concat class " slide"))) + (org-html-headline headline contents info))) + +(defun org-deck-item (item contents info) + "Transcode an ITEM element from Org to HTML. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information. +If the containing headline has the property :STEP, then +the \"slide\" class will be added to the to the list element, + which will make the list into a \"build\"." + (let ((text (org-html-item item contents info))) + (if (org-export-get-node-property :STEP item t) + (progn + (replace-regexp-in-string "^<li>" "<li class='slide'>" text) + (replace-regexp-in-string "^<li class='checkbox'>" "<li class='checkbox slide'>" text)) + text))) + +(defun org-deck-link (link desc info) + (replace-regexp-in-string "href=\"#" "href=\"#outline-container-" + (org-export-with-backend 'html link desc info))) + +(defun org-deck-template (contents info) + "Return complete document string after HTML conversion. +CONTENTS is the transcoded contents string. INFO is a plist +holding export options." + (let ((pkg-info (org-deck--get-packages info)) + (org-html--pre/postamble-class "deck-status") + (info (plist-put + (plist-put info :html-preamble (plist-get info :deck-preamble)) + :html-postamble (plist-get info :deck-postamble)))) + (mapconcat + 'identity + (list + (org-html-doctype info) + (let ((lang (plist-get info :language))) + (mapconcat + (lambda (x) + (apply + 'format + "<!--%s <html %s lang='%s' xmlns='http://www.w3.org/1999/xhtml'> %s<![endif]-->" + x)) + (list `("[if lt IE 7]>" "class='no-js ie6'" ,lang "") + `("[if IE 7]>" "class='no-js ie7'" ,lang "") + `("[if IE 8]>" "class='no-js ie8'" ,lang "") + `("[if gt IE 8]><!-->" "" ,lang "<!--")) "\n")) + "<head>" + (org-deck--build-meta-info info) + (mapconcat + (lambda (sheet) + (format + "<link rel='stylesheet' href='%s' type='text/css' />" sheet)) + (plist-get pkg-info :sheets) "\n") + (mapconcat + (lambda (script) + (format + "<script src='%s' type='text/javascript'></script>" script)) + (plist-get pkg-info :scripts) "\n") + (org-html--build-mathjax-config info) + "<script type='text/javascript'>" + " $(document).ready(function () { $.deck('.slide'); });" + "</script>" + (org-html--build-head info) + "<style type='text/css'>" + org-deck-toc-styles + (when (plist-get info :section-numbers) + "#table-of-contents ul li {list-style-type: none;}") + (format "#%s, #%s {%s}" + (nth 2 (assq 'preamble org-html-divs)) + (nth 2 (assq 'postamble org-html-divs)) + (nth 1 (assq 'both org-deck-pre/postamble-styles))) + (format "#%s {%s}" + (nth 2 (assq 'preamble org-html-divs)) + (nth 1 (assq 'preamble org-deck-pre/postamble-styles))) + (format "#%s {%s}" + (nth 2 (assq 'postamble org-html-divs)) + (nth 1 (assq 'postamble org-deck-pre/postamble-styles))) + org-deck-styles + "</style>" + "</head>" + "<body>" + (format "<%s id='%s' class='deck-container'>" + (nth 1 (assq 'content org-html-divs)) + (nth 2 (assq 'content org-html-divs))) + (org-html--build-pre/postamble 'preamble info) + ;; title page + (format "<%s id='title-slide' class='slide'>" + (plist-get info :html-container)) + (format-spec org-deck-title-slide-template (org-html-format-spec info)) + (format "</%s>" (plist-get info :html-container)) + ;; toc page + (let ((depth (plist-get info :with-toc))) + (when depth (org-deck-toc depth info))) + contents + (mapconcat + (lambda (snippet) + (with-temp-buffer (insert-file-contents snippet) + (buffer-string))) + (plist-get pkg-info :snippets) "\n") + (org-html--build-pre/postamble 'postamble info) + (format "</%s>" (nth 1 (assq 'content org-html-divs))) + "</body>" + "</html>\n") "\n"))) + +(defun org-deck--build-meta-info (info) + "Return meta tags for exported document. +INFO is a plist used as a communication channel." + (let* ((title (org-export-data (plist-get info :title) info)) + (author (and (plist-get info :with-author) + (let ((auth (plist-get info :author))) + (and auth (org-export-data auth info))))) + (date (and (plist-get info :with-date) + (let ((date (org-export-get-date info))) + (and date (org-export-data date info))))) + (description (plist-get info :description)) + (keywords (plist-get info :keywords))) + (mapconcat + 'identity + (list + (format "<title>%s</title>" title) + (format "<meta http-equiv='Content-Type' content='text/html; charset=%s'/>" + (or (and org-html-coding-system + (fboundp 'coding-system-get) + (coding-system-get + org-html-coding-system 'mime-charset)) + "iso-8859-1")) + (mapconcat + (lambda (attr) + (when (< 0 (length (car attr))) + (format "<meta name='%s' content='%s'/>\n" + (nth 1 attr) (car attr)))) + (list '("Org-mode" "generator") + `(,author "author") + `(,description "description") + `(,keywords "keywords")) "")) "\n"))) +(defun org-deck-export-as-html + (&optional async subtreep visible-only body-only ext-plist) + "Export current buffer to an HTML buffer. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +A non-nil optional argument ASYNC means the process should happen +asynchronously. The resulting buffer should be accessible +through the `org-export-stack' interface. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only write code +between \"<body>\" and \"</body>\" tags. + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +Export is done in a buffer named \"*Org deck.js Export*\", which +will be displayed when `org-export-show-temporary-export-buffer' +is non-nil." + (interactive) + (org-export-to-buffer 'deck "*Org deck.js Export*" + async subtreep visible-only body-only ext-plist (lambda () (nxml-mode)))) + +(defun org-deck-export-to-html + (&optional async subtreep visible-only body-only ext-plist) + "Export current buffer to a deck.js HTML file. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +A non-nil optional argument ASYNC means the process should happen +asynchronously. The resulting file should be accessible through +the `org-export-stack' interface. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only write code +between \"<body>\" and \"</body>\" tags. + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +Return output file's name." + (interactive) + (let* ((extension (concat "." org-html-extension)) + (file (org-export-output-file-name extension subtreep)) + (org-export-coding-system org-html-coding-system)) + (org-export-to-file 'deck file + async subtreep visible-only body-only ext-plist))) + +(defun org-deck-publish-to-html (plist filename pub-dir) + "Publish an org file to deck.js HTML Presentation. +FILENAME is the filename of the Org file to be published. PLIST +is the property list for the given project. PUB-DIR is the +publishing directory. Returns output file name." + (org-publish-org-to 'deck filename ".html" plist pub-dir)) + +(provide 'ox-deck) + +;;; ox-deck.el ends here diff --git a/contrib/lisp/ox-extra.el b/contrib/lisp/ox-extra.el new file mode 100644 index 0000000..9cd6980 --- /dev/null +++ b/contrib/lisp/ox-extra.el @@ -0,0 +1,211 @@ +;;; ox-extra.el --- Convenience functions for org export + +;; Copyright (C) 2014 Aaron Ecay + +;; Author: Aaron Ecay <aaronecay@gmail.com> + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file contains some convenience functions for org export, which +;; are not part of org's core. Call `ox-extras-activate' passing a +;; list of symbols naming extras, which will be installed globally in +;; your org session. +;; +;; For example, you could include the following in your .emacs file: +;; +;; (require 'ox-extra) +;; (ox-extras-activate '(latex-header-blocks ignore-headlines)) +;; + +;; Currently available extras: + +;; - `latex-header-blocks' -- allow the use of latex blocks, the +;; contents of which which will be interpreted as #+latex_header lines +;; for export. These blocks should be tagged with #+header: :header +;; yes. For example: +;; #+header: :header yes +;; #+begin_export latex +;; ... +;; #+end_export + +;; - `ignore-headlines' -- allow a headline (but not its children) to +;; be ignored. Any headline tagged with the 'ignore' tag will be +;; ignored (i.e. will not be included in the export), but any child +;; headlines will not be ignored (unless explicitly tagged to be +;; ignored), and will instead have their levels promoted by one. + +;; TODO: +;; - add a function to org-mode-hook that looks for a ox-extras local +;; variable and activates the specified extras buffer-locally +;; - allow specification of desired extras to be activated via +;; customize + +;;; Code: + +(require 'ox) +(require 'cl-lib) + +(defun org-latex-header-blocks-filter (backend) + (when (org-export-derived-backend-p backend 'latex) + (let ((positions + (org-element-map (org-element-parse-buffer 'greater-element nil) 'export-block + (lambda (block) + (when (and (string= (org-element-property :type block) "LATEX") + (string= (org-export-read-attribute + :header block :header) + "yes")) + (list (org-element-property :begin block) + (org-element-property :end block) + (org-element-property :post-affiliated block))))))) + (mapc (lambda (pos) + (goto-char (nth 2 pos)) + (cl-destructuring-bind + (beg end &rest ignore) + ;; FIXME: `org-edit-src-find-region-and-lang' was + ;; removed in 9c06f8cce (2014-11-11). + (org-edit-src-find-region-and-lang) + (let ((contents-lines (split-string + (buffer-substring-no-properties beg end) + "\n"))) + (delete-region (nth 0 pos) (nth 1 pos)) + (dolist (line contents-lines) + (insert (concat "#+latex_header: " + (replace-regexp-in-string "\\` *" "" line) + "\n")))))) + ;; go in reverse, to avoid wrecking the numeric positions + ;; earlier in the file + (reverse positions))))) + + +;; During export headlines which have the "ignore" tag are removed +;; from the parse tree. Their contents are retained (leading to a +;; possibly invalid parse tree, which nevertheless appears to function +;; correctly with most export backends) all children headlines are +;; retained and are promoted to the level of the ignored parent +;; headline. +;; +;; This makes it possible to add structure to the original Org-mode +;; document which does not effect the exported version, such as in the +;; following examples. +;; +;; Wrapping an abstract in a headline +;; +;; * Abstract :ignore: +;; #+LaTeX: \begin{abstract} +;; #+HTML: <div id="abstract"> +;; +;; ... +;; +;; #+HTML: </div> +;; #+LaTeX: \end{abstract} +;; +;; Placing References under a headline (using ox-bibtex in contrib) +;; +;; * References :ignore: +;; #+BIBLIOGRAPHY: dissertation plain +;; +;; Inserting an appendix for LaTeX using the appendix package. +;; +;; * Appendix :ignore: +;; #+LaTeX: \begin{appendices} +;; ** Reproduction +;; ... +;; ** Definitions +;; #+LaTeX: \end{appendices} +;; +(defun org-export-ignore-headlines (data backend info) + "Remove headlines tagged \"ignore\" retaining contents and promoting children. +Each headline tagged \"ignore\" will be removed retaining its +contents and promoting any children headlines to the level of the +parent." + (org-element-map data 'headline + (lambda (object) + (when (member "ignore" (org-element-property :tags object)) + (let ((level-top (org-element-property :level object)) + level-diff) + (mapc (lambda (el) + ;; recursively promote all nested headlines + (org-element-map el 'headline + (lambda (el) + (when (equal 'headline (org-element-type el)) + (unless level-diff + (setq level-diff (- (org-element-property :level el) + level-top))) + (org-element-put-property el + :level (- (org-element-property :level el) + level-diff))))) + ;; insert back into parse tree + (org-element-insert-before el object)) + (org-element-contents object))) + (org-element-extract-element object))) + info nil) + (org-extra--merge-sections data backend info) + data) + +(defun org-extra--merge-sections (data _backend info) + (org-element-map data 'headline + (lambda (hl) + (let ((sections + (cl-loop + for el in (org-element-map (org-element-contents hl) + '(headline section) #'identity info) + until (eq (org-element-type el) 'headline) + collect el))) + (when (and sections + (> (length sections) 1)) + (apply #'org-element-adopt-elements + (car sections) + (cl-mapcan (lambda (s) (org-element-contents s)) + (cdr sections))) + (mapc #'org-element-extract-element (cdr sections))))) + info)) + +(defconst ox-extras + '((latex-header-blocks org-latex-header-blocks-filter org-export-before-parsing-hook) + (ignore-headlines org-export-ignore-headlines org-export-filter-parse-tree-functions)) + "A list of org export extras that can be enabled. + +Should be a list of items of the form (NAME FN HOOK). NAME is a +symbol, which can be passed to `ox-extras-activate'. FN is a +function which will be added to HOOK.") + +(defun ox-extras-activate (extras) + "Activate certain org export extras. + +EXTRAS should be a list of extras (defined in `ox-extras') which +should be activated." + (dolist (extra extras) + (let* ((lst (assq extra ox-extras)) + (fn (nth 1 lst)) + (hook (nth 2 lst))) + (when (and fn hook) + (add-hook hook fn))))) + +(defun ox-extras-deactivate (extras) + "Deactivate certain org export extras. + +This function is the opposite of `ox-extras-activate'. EXTRAS +should be a list of extras (defined in `ox-extras') which should +be activated." + (dolist (extra extras) + (let* ((lst (assq extra ox-extras)) + (fn (nth 1 lst)) + (hook (nth 2 lst))) + (when (and fn hook) + (remove-hook hook fn))))) + +(provide 'ox-extra) +;;; ox-extra.el ends here diff --git a/contrib/lisp/ox-freemind.el b/contrib/lisp/ox-freemind.el new file mode 100644 index 0000000..a2bf129 --- /dev/null +++ b/contrib/lisp/ox-freemind.el @@ -0,0 +1,527 @@ +;;; ox-freemind.el --- Freemind Mindmap Back-End for Org Export Engine + +;; Copyright (C) 2013-2017 Free Software Foundation, Inc. + +;; Author: Jambunathan K <kjambunathan at gmail dot com> +;; Keywords: outlines, hypermedia, calendar, wp + +;; This file is not part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This library implements a Freemind Mindmap back-end for Org generic +;; exporter. + +;; To test it, run: +;; +;; M-x org-freemind-export-to-freemind +;; +;; in an Org mode buffer. See ox.el for more details on how this +;; exporter works. + +;;; Code: + +;;; Dependencies + +(require 'ox-html) + + + +;;; Define Back-End + +(org-export-define-derived-backend 'freemind 'html + :menu-entry + '(?f "Export to Freemind Mindmap" + ((?f "As Freemind Mindmap file" org-freemind-export-to-freemind) + (?o "As Freemind Mindmap file and open" + (lambda (a s v b) + (if a (org-freemind-export-to-freemind t s v b) + (org-open-file (org-freemind-export-to-freemind nil s v b))))))) + :translate-alist '((headline . org-freemind-headline) + (template . org-freemind-template) + (inner-template . org-freemind-inner-template) + (section . org-freemind-section) + (entity . org-freemind-entity)) + :filters-alist '((:filter-options . org-freemind-options-function) + (:filter-final-output . org-freemind-final-function))) + + + +;;; User Configuration Variables + +(defgroup org-export-freemind nil + "Options for exporting Org mode files to Freemind Mindmap." + :tag "Org Export Freemind Mindmap" + :group 'org-export) + +(defcustom org-freemind-styles + '((default . "<node>\n</node>") + (0 . "<node COLOR=\"#000000\">\n<font NAME=\"SansSerif\" SIZE=\"20\"/>\n</node>") + (1 . "<node COLOR=\"#0033ff\">\n<edge STYLE=\"sharp_bezier\" WIDTH=\"8\"/>\n<font NAME=\"SansSerif\" SIZE=\"18\"/>\n</node>") + (2 . "<node COLOR=\"#00b439\">\n<edge STYLE=\"bezier\" WIDTH=\"thin\"/>\n<font NAME=\"SansSerif\" SIZE=\"16\"/>\n</node>") + (3 . "<node COLOR=\"#990000\" FOLDED=\"true\">\n<font NAME=\"SansSerif\" SIZE=\"14\"/>\n</node>") + (4 . "<node COLOR=\"#111111\">\n</node>")) + "List of Freemind node styles. +Each entry is of the form (STYLE-NAME . STYLE-SPEC). STYLE-NAME +can be one of an integer (signifying an outline level), a string +or the symbol `default'. STYLE-SPEC, a string, is a Freemind +node style." + :type '(alist :options (default 0 1 2 3) + :key-type (choice :tag "Style tag" + (integer :tag "Outline level") + (const :tag "Default value" default) + (string :tag "Node style")) + :value-type (string :tag "Style spec")) + :group 'org-export-freemind) + +(defcustom org-freemind-style-map-function 'org-freemind-style-map--automatic + "Function to map an Org element to it's node style. +The mapping function takes two arguments an Org ELEMENT and INFO. +ELEMENT can be one of the following types - `org-data', +`headline' or `section'. INFO is a plist holding contextual +information during export. The function must return a STYLE-SPEC +to be applied to ELEMENT. + +See `org-freemind-style-map--automatic' for a sample style +function. See `org-freemind-styles' for a list of named styles." + :type '(radio + (function-item org-freemind-style-map--automatic) + (function-item org-freemind-style-map--default) + function) + :group 'org-export-freemind) + +(defcustom org-freemind-section-format 'note + "Specify how outline sections are to be formatted. +If `inline', append it to the contents of it's heading node. If +`note', attach it as a note to it's heading node. If `node', +attach it as a separate node to it's heading node. + +Use `note', if the input Org file contains large sections. Use +`node', if the Org file contains mid-sized sections that need to +stand apart. Otherwise, use `inline'." + :type '(choice + (const :tag "Append to outline title" inline) + (const :tag "Attach as a note" note) + (const :tag "Create a separate node" node)) + :group 'org-export-freemind) + +;;;; Debugging + +(defcustom org-freemind-pretty-output nil + "Enable this to generate pretty Freemind Mindmap." + :type 'boolean + :group 'org-export-freemind) + + +;;; Internal Functions + +;;;; XML Manipulation + +(defun org-freemind--serialize (parsed-xml &optional contents) + "Convert PARSED-XML in to XML string. +PARSED-XML is a parse tree as returned by +`libxml-parse-xml-region'. CONTENTS is an optional string. + +Ignore CONTENTS, if PARSED-XML is not a sole XML element. +Otherwise, append CONTENTS to the contents of top-level element +in PARSED-XML. + +This is an inverse function of `libxml-parse-xml-region'. + +For purposes of Freemind export, PARSED-XML is a node style +specification - \"<node ...>...</node>\" - as a parse tree." + (when contents + (assert (symbolp (car parsed-xml)))) + (cond + ((null parsed-xml) "") + ((stringp parsed-xml) parsed-xml) + ((symbolp (car parsed-xml)) + (let ((attributes (mapconcat + (lambda (av) + (format "%s=\"%s\"" (car av) (cdr av))) + (cadr parsed-xml) " "))) + (if (or (cddr parsed-xml) contents) + (format "\n<%s%s>%s\n</%s>" + (car parsed-xml) + (if (string= attributes "") "" (concat " " attributes)) + (concat (org-freemind--serialize (cddr parsed-xml)) + contents ) + (car parsed-xml)) + (format "\n<%s%s/>" + (car parsed-xml) + (if (string= attributes "") "" (concat " " attributes)))))) + (t (mapconcat #'org-freemind--serialize parsed-xml "")))) + +(defun org-freemind--parse-xml (xml-string) + "Return parse tree for XML-STRING using `libxml-parse-xml-region'. +For purposes of Freemind export, XML-STRING is a node style +specification - \"<node ...>...</node>\" - as a string." + (with-temp-buffer + (insert (or xml-string "")) + (libxml-parse-xml-region (point-min) (point-max)))) + + +;;;; Style mappers :: Default and Automatic layout + +(defun org-freemind-style-map--automatic (element info) + "Return a node style corresponding to relative outline level of ELEMENT. +ELEMENT can be any of the following types - `org-data', +`headline' or `section'. See `org-freemind-styles' for style +mappings of different outline levels." + (let ((style-name + (case (org-element-type element) + (headline + (org-export-get-relative-level element info)) + (section + (let ((parent (org-export-get-parent-headline element))) + (if (not parent) 1 + (1+ (org-export-get-relative-level parent info))))) + (t 0)))) + (or (assoc-default style-name org-freemind-styles) + (assoc-default 'default org-freemind-styles) + "<node></node>"))) + +(defun org-freemind-style-map--default (element info) + "Return the default style for all ELEMENTs. +ELEMENT can be any of the following types - `org-data', +`headline' or `section'. See `org-freemind-styles' for current +value of default style." + (or (assoc-default 'default org-freemind-styles) + "<node></node>")) + + +;;;; Helpers :: Retrieve, apply Freemind styles + +(defun org-freemind--get-node-style (element info) + "Return Freemind node style applicable for HEADLINE. +ELEMENT is an Org element of type `org-data', `headline' or +`section'. INFO is a plist holding contextual information." + (unless (fboundp org-freemind-style-map-function) + (setq org-freemind-style-map-function 'org-freemind-style-map--default)) + (let ((style (funcall org-freemind-style-map-function element info))) + ;; Sanitize node style. + + ;; Loop through the attributes of node element and purge those + ;; attributes that look suspicious. This is an extra bit of work + ;; that allows one to copy verbatim node styles from an existing + ;; Freemind Mindmap file without messing with the exported data. + (let* ((data (org-freemind--parse-xml style)) + (attributes (cadr data)) + (ignored-attrs '(POSITION FOLDED TEXT CREATED ID + MODIFIED))) + (let (attr) + (while (setq attr (pop ignored-attrs)) + (setq attributes (assq-delete-all attr attributes)))) + (when data (setcar (cdr data) attributes)) + (org-freemind--serialize data)))) + +(defun org-freemind--build-stylized-node (style-1 style-2 &optional contents) + "Build a Freemind node with style STYLE-1 + STYLE-2 and add CONTENTS to it. +STYLE-1 and STYLE-2 are Freemind node styles as a string. +STYLE-1 is the base node style and STYLE-2 is the overriding +style that takes precedence over STYLE-1. CONTENTS is a string. + +Return value is a Freemind node with following properties: + + 1. The attributes of \"<node ...> </node>\" element is the union + of corresponding attributes of STYLE-1 and STYLE-2. When + STYLE-1 and STYLE-2 specify values for the same attribute + name, choose the attribute value from STYLE-2. + + 2. The children of \"<node ...> </node>\" element is the union of + top-level children of STYLE-1 and STYLE-2 with CONTENTS + appended to it. When STYLE-1 and STYLE-2 share a child + element of same type, the value chosen is that from STYLE-2. + +For example, merging with following parameters + + STYLE-1 => + <node COLOR=\"#00b439\" STYLE=\"Bubble\"> + <edge STYLE=\"bezier\" WIDTH=\"thin\"/> + <font NAME=\"SansSerif\" SIZE=\"16\"/> + </node> + + STYLE-2 => + <node COLOR=\"#990000\" FOLDED=\"true\"> + <font NAME=\"SansSerif\" SIZE=\"14\"/> + </node> + + CONTENTS => + <attribute NAME=\"ORGTAG\" VALUE=\"@home\"/> + +will result in following node: + + RETURN => + <node STYLE=\"Bubble\" COLOR=\"#990000\" FOLDED=\"true\"> + <edge STYLE=\"bezier\" WIDTH=\"thin\"/> + <font NAME=\"SansSerif\" SIZE=\"14\"/> + <attribute NAME=\"ORGTAG\" VALUE=\"@home\"/> + </node>." + (let* ((data1 (org-freemind--parse-xml (or style-1 ""))) + (data2 (org-freemind--parse-xml (or style-2 ""))) + (attr1 (cadr data1)) + (attr2 (cadr data2)) + (merged-attr attr2) + (children1 (cddr data1)) + (children2 (cddr data2)) + (merged-children children2)) + (let (attr) + (while (setq attr (pop attr1)) + (unless (assq (car attr) merged-attr) + (push attr merged-attr)))) + (let (child) + (while (setq child (pop children1)) + (when (or (stringp child) (not (assq (car child) merged-children))) + (push child merged-children)))) + (let ((merged-data (nconc (list 'node merged-attr) merged-children))) + (org-freemind--serialize merged-data contents)))) + + +;;;; Helpers :: Node contents + +(defun org-freemind--richcontent (type contents &optional css-style) + (let* ((type (case type + (note "NOTE") + (node "NODE") + (t "NODE"))) + (contents (org-trim contents))) + (if (string= (org-trim contents) "") "" + (format "\n<richcontent TYPE=\"%s\">%s\n</richcontent>" + type + (format "\n<html>\n<head>%s\n</head>\n%s\n</html>" + (or css-style "") + (format "<body>\n%s\n</body>" contents)))))) + +(defun org-freemind--build-node-contents (element contents info) + (let* ((title (case (org-element-type element) + (headline + (org-element-property :title element)) + (org-data + (plist-get info :title)) + (t (error "Shouldn't come here")))) + (element-contents (org-element-contents element)) + (section (assq 'section element-contents)) + (section-contents + (let ((backend (org-export-create-backend + :parent (org-export-backend-name + (plist-get info :back-end)) + :transcoders '((section . (lambda (e c i) c)))))) + (org-export-data-with-backend section backend info))) + (itemized-contents-p (let ((first-child-headline + (org-element-map element-contents + 'headline 'identity info t))) + (when first-child-headline + (org-export-low-level-p first-child-headline + info)))) + (node-contents (concat section-contents + (when itemized-contents-p + contents)))) + (concat (let ((title (org-export-data title info))) + (case org-freemind-section-format + (inline + (org-freemind--richcontent + 'node (concat (format "\n<h2>%s</h2>" title) + node-contents) )) + (note + (concat (org-freemind--richcontent + 'node (format "\n<p>%s\n</p>" title)) + (org-freemind--richcontent + 'note node-contents))) + (node + (concat + (org-freemind--richcontent + 'node (format "\n<p>%s\n</p>" title)) + (when section + (org-freemind--build-stylized-node + (org-freemind--get-node-style section info) nil + (org-freemind--richcontent 'node node-contents))))))) + (unless itemized-contents-p + contents)))) + + + +;;; Template + +(defun org-freemind-template (contents info) + "Return complete document string after Freemind Mindmap conversion. +CONTENTS is the transcoded contents string. RAW-DATA is the +original parsed data. INFO is a plist holding export options." + (format + "<map version=\"0.9.0\">\n%s\n</map>" + (org-freemind--build-stylized-node + (org-freemind--get-node-style nil info) nil + (let ((org-data (plist-get info :parse-tree))) + (org-freemind--build-node-contents org-data contents info))))) + +(defun org-freemind-inner-template (contents info) + "Return body of document string after Freemind Mindmap conversion. +CONTENTS is the transcoded contents string. INFO is a plist +holding export options." + contents) + +;;;; Tags + +(defun org-freemind--tags (tags) + (mapconcat (lambda (tag) + (format "\n<attribute NAME=\"%s\" VALUE=\"%s\"/>" tag "")) + tags "\n")) + + + +;;; Transcode Functions + +;;;; Entity + +(defun org-freemind-entity (entity contents info) + "Transcode an ENTITY object from Org to Freemind Mindmap. +CONTENTS are the definition itself. INFO is a plist holding +contextual information." + (org-element-property :utf-8 entity)) + +;;;; Headline + +(defun org-freemind-headline (headline contents info) + "Transcode a HEADLINE element from Org to Freemind Mindmap. +CONTENTS holds the contents of the headline. INFO is a plist +holding contextual information." + ;; Empty contents? + (setq contents (or contents "")) + (let* ((numberedp (org-export-numbered-headline-p headline info)) + (level (org-export-get-relative-level headline info)) + (text (org-export-data (org-element-property :title headline) info)) + (todo (and (plist-get info :with-todo-keywords) + (let ((todo (org-element-property :todo-keyword headline))) + (and todo (org-export-data todo info))))) + (todo-type (and todo (org-element-property :todo-type headline))) + (tags (and (plist-get info :with-tags) + (org-export-get-tags headline info))) + (priority (and (plist-get info :with-priority) + (org-element-property :priority headline))) + (section-number (and (not (org-export-low-level-p headline info)) + (org-export-numbered-headline-p headline info) + (mapconcat 'number-to-string + (org-export-get-headline-number + headline info) "."))) + ;; Create the headline text. + (full-text (org-export-data (org-element-property :title headline) + info)) + ;; Headline order (i.e, first digit of the section number) + (headline-order (car (org-export-get-headline-number headline info)))) + (cond + ;; Case 1: This is a footnote section: ignore it. + ((org-element-property :footnote-section-p headline) nil) + ;; Case 2. This is a deep sub-tree, export it as a list item. + ;; Delegate the actual export to `html' backend. + ((org-export-low-level-p headline info) + (org-html-headline headline contents info)) + ;; Case 3. Standard headline. Export it as a section. + (t + (let* ((section-number (mapconcat 'number-to-string + (org-export-get-headline-number + headline info) "-")) + (ids (remove 'nil + (list (org-element-property :CUSTOM_ID headline) + (concat "sec-" section-number) + (org-element-property :ID headline)))) + (preferred-id (car ids)) + (extra-ids (cdr ids)) + (left-p (zerop (% headline-order 2)))) + (org-freemind--build-stylized-node + (org-freemind--get-node-style headline info) + (format "<node ID=\"%s\" POSITION=\"%s\" FOLDED=\"%s\">\n</node>" + preferred-id + (if left-p "left" "right") + (if (= level 1) "true" "false")) + (concat (org-freemind--build-node-contents headline contents info) + (org-freemind--tags tags)))))))) + + +;;;; Section + +(defun org-freemind-section (section contents info) + "Transcode a SECTION element from Org to Freemind Mindmap. +CONTENTS holds the contents of the section. INFO is a plist +holding contextual information." + (let ((parent (org-export-get-parent-headline section))) + (when (and parent (org-export-low-level-p parent info)) + contents))) + + + +;;; Filter Functions + +(defun org-freemind-final-function (contents backend info) + "Return CONTENTS as pretty XML using `indent-region'." + (if (not org-freemind-pretty-output) contents + (with-temp-buffer + (nxml-mode) + (insert contents) + (indent-region (point-min) (point-max)) + (buffer-substring-no-properties (point-min) (point-max))))) + +(defun org-freemind-options-function (info backend) + "Install script in export options when appropriate. +EXP-PLIST is a plist containing export options. BACKEND is the +export back-end currently used." + ;; Freemind/Freeplane doesn't seem to like named html entities in + ;; richcontent. For now, turn off smart quote processing so that + ;; entities like "’" & friends are avoided in the exported + ;; output. + (plist-put info :with-smart-quotes nil)) + + + +;;; End-user functions + +;;;###autoload +(defun org-freemind-export-to-freemind + (&optional async subtreep visible-only body-only ext-plist) + "Export current buffer to a Freemind Mindmap file. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +A non-nil optional argument ASYNC means the process should happen +asynchronously. The resulting file should be accessible through +the `org-export-stack' interface. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only write code +between \"<body>\" and \"</body>\" tags. + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +Return output file's name." + (interactive) + (let* ((extension (concat ".mm" )) + (file (org-export-output-file-name extension subtreep)) + (org-export-coding-system 'utf-8)) + (org-export-to-file 'freemind file + async subtreep visible-only body-only ext-plist))) + +(provide 'ox-freemind) + +;;; ox-freemind.el ends here diff --git a/contrib/lisp/ox-groff.el b/contrib/lisp/ox-groff.el new file mode 100644 index 0000000..555a89d --- /dev/null +++ b/contrib/lisp/ox-groff.el @@ -0,0 +1,1962 @@ +;;; ox-groff.el --- Groff Back-End for Org Export Engine + +;; Copyright (C) 2011-2017 Free Software Foundation, Inc. + +;; Author: Nicolas Goaziou <n.goaziou at gmail dot com> +;; Author: Luis R Anaya <papoanaya aroba hot mail punto com> +;; Keywords: outlines, hypermedia, calendar, wp + +;; This file is not part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. +;;; Commentary: +;; +;; This library implements a Groff Memorandum Macro back-end for Org +;; generic exporter. +;; +;; To test it, run +;; +;; M-: (org-export-to-buffer 'groff "*Test Groff*") RET +;; +;; in an org-mode buffer then switch to the buffer to see the Groff +;; export. See ox.el for more details on how this exporter works. +;; +;; It introduces two new buffer keywords: "GROFF_CLASS" and +;; "GROFF_CLASS_OPTIONS". + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'ox) + +(defvar orgtbl-exp-regexp) + + +;;; Define Back-End + +(org-export-define-backend 'groff + '((bold . org-groff-bold) + (center-block . org-groff-center-block) + (clock . org-groff-clock) + (code . org-groff-code) + (drawer . org-groff-drawer) + (dynamic-block . org-groff-dynamic-block) + (entity . org-groff-entity) + (example-block . org-groff-example-block) + (export-block . org-groff-export-block) + (export-snippet . org-groff-export-snippet) + (fixed-width . org-groff-fixed-width) + (footnote-definition . org-groff-footnote-definition) + (footnote-reference . org-groff-footnote-reference) + (headline . org-groff-headline) + (horizontal-rule . org-groff-horizontal-rule) + (inline-src-block . org-groff-inline-src-block) + (inlinetask . org-groff-inlinetask) + (italic . org-groff-italic) + (item . org-groff-item) + (keyword . org-groff-keyword) + (line-break . org-groff-line-break) + (link . org-groff-link) + (node-property . org-groff-node-property) + (paragraph . org-groff-paragraph) + (plain-list . org-groff-plain-list) + (plain-text . org-groff-plain-text) + (planning . org-groff-planning) + (property-drawer . org-groff-property-drawer) + (quote-block . org-groff-quote-block) + (radio-target . org-groff-radio-target) + (section . org-groff-section) + (special-block . org-groff-special-block) + (src-block . org-groff-src-block) + (statistics-cookie . org-groff-statistics-cookie) + (strike-through . org-groff-strike-through) + (subscript . org-groff-subscript) + (superscript . org-groff-superscript) + (table . org-groff-table) + (table-cell . org-groff-table-cell) + (table-row . org-groff-table-row) + (target . org-groff-target) + (template . org-groff-template) + (timestamp . org-groff-timestamp) + (underline . org-groff-underline) + (verbatim . org-groff-verbatim) + (verse-block . org-groff-verse-block)) + :menu-entry + '(?g "Export to GROFF" + ((?g "As GROFF file" org-groff-export-to-groff) + (?p "As PDF file" org-groff-export-to-pdf) + (?o "As PDF file and open" + (lambda (a s v b) + (if a (org-groff-export-to-pdf t s v b) + (org-open-file (org-groff-export-to-pdf nil s v b))))))) + :options-alist + '((:groff-class "GROFF_CLASS" nil org-groff-default-class t) + (:groff-class-options "GROFF_CLASS_OPTIONS" nil nil t) + (:groff-header-extra "GROFF_HEADER" nil nil newline))) + + + +;;; User Configurable Variables + +(defgroup org-export-groff nil + "Options for exporting Org mode files to Groff." + :tag "Org Export Groff" + :group 'org-export) + +;;; Preamble + +(defcustom org-groff-default-class "internal" + "The default Groff class." + :group 'org-export-groff + :type '(string :tag "Groff class")) + +(defcustom org-groff-classes + '(("file" ".MT 1" + (:heading 'default :type "memo" :last-section "toc")) + ("internal" ".MT 0" + (:heading 'default :type "memo" :last-section "toc")) + ("programmer" ".MT 2" + (:heading 'default :type "memo" :last-section "toc")) + ("engineer" ".MT 3" + (:heading 'default :type "memo" :last-section "toc")) + ("external" ".MT 4" + (:heading 'default :type "memo" :last-section "toc")) + ("letter" ".MT 5" + (:heading 'default :type "memo" :last-section "sign")) + ("custom" ".so file" + (:heading custom-function :type "custom" :last-section "toc")) + ("dummy" "" + (:heading 'default :type "memo")) + ("ms" "ms" + (:heading 'default :type "cover" :last-section "toc")) + ("se_ms" "se_ms" + (:heading 'default :type "cover" :last-section "toc")) + ("block" "BL" + (:heading 'default :type "letter" :last-section "sign")) + ("semiblock" "SB" + (:heading 'default :type "letter" :last-section "sign")) + ("fullblock" "FB" + (:heading 'default :type "letter" :last-section "sign")) + ("simplified" "SP" + (:heading 'default :type "letter" :last-section "sign")) + ("none" "" (:heading 'default :type "custom"))) + + ;; none means, no Cover or Memorandum Type and no calls to AU, AT, ND and TL + ;; This is to facilitate the creation of custom pages. + + ;; dummy means, no Cover or Memorandum Type but calls to AU, AT, ND and TL + ;; are made. This is to facilitate Abstract Insertion. + + "This list describes the attributes for the documents being created. + It allows for the creation of new " + :group 'org-export-groff + :type '(repeat + (list (string :tag "Document Type") + (string :tag "Header") + (repeat :tag "Options" :inline t + (choice + (list :tag "Heading") + (function :tag "Hook computing sectioning")))))) + +;;; Headline + +(defconst org-groff-special-tags + '("FROM" "TO" "ABSTRACT" "APPENDIX" "BODY" "NS")) + +(defcustom org-groff-format-headline-function nil + "Function to format headline text. + +This function will be called with 5 arguments: +TODO the todo keyword (string or nil). +TODO-TYPE the type of todo (symbol: `todo', `done', nil) +PRIORITY the priority of the headline (integer or nil) +TEXT the main headline text (string). +TAGS the tags as a list of strings (list of strings or nil). + +The function result will be used in the section format string. + +As an example, one could set the variable to the following, in +order to reproduce the default set-up: + +\(defun org-groff-format-headline (todo todo-type priority text tags) + \"Default format function for a headline.\" + \(concat (when todo + \(format \"\\fB%s\\fP \" todo)) + \(when priority + \(format \"[\\#%c] \" priority)) + text + \(when tags + \(format \" %s \" + \(mapconcat 'identity tags \":\"))))" + :group 'org-export-groff + :type 'function) + +;;; Timestamps + +(defcustom org-groff-active-timestamp-format "\\fI%s\\fP" + "A printf format string to be applied to active timestamps." + :group 'org-export-groff + :type 'string) + +(defcustom org-groff-inactive-timestamp-format "\\fI%s\\fP" + "A printf format string to be applied to inactive timestamps." + :group 'org-export-groff + :type 'string) + +(defcustom org-groff-diary-timestamp-format "\\fI%s\\fP" + "A printf format string to be applied to diary timestamps." + :group 'org-export-groff + :type 'string) + +;;; Links + +(defcustom org-groff-inline-image-rules + '(("file" . "\\.\\(jpg\\|png\\|pdf\\|ps\\|eps\\|pic\\)\\'") + ("fuzzy" . "\\.\\(jpg\\|png\\|pdf\\|ps\\|eps\\|pic\\)\\'")) + "Rules characterizing image files that can be inlined into Groff. + +A rule consists in an association whose key is the type of link +to consider, and value is a regexp that will be matched against +link's path. + +Note that, by default, the image extensions actually allowed +depend on the way the Groff file is processed. When used with +pdfgroff, pdf, jpg and png images are OK. When processing +through dvi to Postscript, only ps and eps are allowed. The +default we use here encompasses both." + :group 'org-export-groff + :type '(alist :key-type (string :tag "Type") + :value-type (regexp :tag "Path"))) + +(defcustom org-groff-link-with-unknown-path-format "\\fI%s\\fP" + "Format string for links with unknown path type." + :group 'org-export-groff + :type 'string) + +;;; Tables + +(defcustom org-groff-tables-centered t + "When non-nil, tables are exported in a center environment." + :group 'org-export-groff + :type 'boolean) + +(defcustom org-groff-tables-verbatim nil + "When non-nil, tables are exported verbatim." + :group 'org-export-groff + :type 'boolean) + +(defcustom org-groff-table-scientific-notation "%sE%s" + "Format string to display numbers in scientific notation. +The format should have \"%s\" twice, for mantissa and exponent +\(i.e. \"%s\\\\times10^{%s}\"). + +When nil, no transformation is made." + :group 'org-export-groff + :type '(choice + (string :tag "Format string") + (const :tag "No formatting"))) + +;;; Text markup + +(defcustom org-groff-text-markup-alist + '((bold . "\\fB%s\\fP") + (code . "\\fC%s\\fP") + (italic . "\\fI%s\\fP") + (strike-through . "\\fC%s\\fP") ; Strike through and underline + (underline . "\\fI%s\\fP") ; need to be revised. + (verbatim . "protectedtexttt")) + "Alist of Groff expressions to convert text markup. + +The key must be a symbol among `bold', `code', `italic', +`strike-through', `underline' and `verbatim'. The value is +a formatting string to wrap fontified text with it. + +If no association can be found for a given markup, text will be +returned as-is." + :group 'org-export-groff + :type 'alist + :options '(bold code italic strike-through underline verbatim)) + +;;; Drawers + +(defcustom org-groff-format-drawer-function nil + "Function called to format a drawer in Groff code. + +The function must accept two parameters: + NAME the drawer name, like \"LOGBOOK\" + CONTENTS the contents of the drawer. + +The function should return the string to be exported. + +For example, the variable could be set to the following function +in order to mimic default behaviour: + +\(defun org-groff-format-drawer-default \(name contents\) + \"Format a drawer element for Groff export.\" + contents\)" + :group 'org-export-groff + :type 'function) + +;;; Inlinetasks + +(defcustom org-groff-format-inlinetask-function nil + "Function called to format an inlinetask in Groff code. + +The function must accept six parameters: + TODO the todo keyword, as a string + TODO-TYPE the todo type, a symbol among `todo', `done' and nil. + PRIORITY the inlinetask priority, as a string + NAME the inlinetask name, as a string. + TAGS the inlinetask tags, as a list of strings. + CONTENTS the contents of the inlinetask, as a string. + +The function should return the string to be exported. + +For example, the variable could be set to the following function +in order to mimic default behaviour: + +\(defun org-groff-format-inlinetask \(todo type priority name tags contents\) +\"Format an inline task element for Groff export.\" + \(let ((full-title + \(concat + \(when todo + \(format \"\\fB%s\\fP \" todo)) + \(when priority (format \"[\\#%c] \" priority)) + title + \(when tags + \(format \":%s:\" + \(mapconcat 'identity tags \":\"))))) + \(format (concat \".DS L\\n\" + \"%s\\n\\n\" + \"%s\" + \".DE\") + full-title contents))" + :group 'org-export-groff + :type 'function) + +;; Src blocks + +(defcustom org-groff-source-highlight nil + "Use GNU source highlight to embellish source blocks " + :group 'org-export-groff + :type 'boolean) + +(defcustom org-groff-source-highlight-langs + '((emacs-lisp "lisp") (lisp "lisp") (clojure "lisp") + (scheme "scheme") + (c "c") (cc "cpp") (csharp "csharp") (d "d") + (fortran "fortran") (cobol "cobol") (pascal "pascal") + (ada "ada") (asm "asm") + (perl "perl") (cperl "perl") + (python "python") (ruby "ruby") (tcl "tcl") (lua "lua") + (java "java") (javascript "javascript") + (tex "latex") + (shell-script "sh") (awk "awk") (diff "diff") (m4 "m4") + (ocaml "caml") (caml "caml") + (sql "sql") (sqlite "sql") + (html "html") (css "css") (xml "xml") + (bat "bat") (bison "bison") (clipper "clipper") + (ldap "ldap") (opa "opa") + (php "php") (postscript "postscript") (prolog "prolog") + (properties "properties") (makefile "makefile") + (tml "tml") (vala "vala") (vbscript "vbscript") (xorg "xorg")) + "Alist mapping languages to their listing language counterpart. +The key is a symbol, the major mode symbol without the \"-mode\". +The value is the string that should be inserted as the language +parameter for the listings package. If the mode name and the +listings name are the same, the language does not need an entry +in this list - but it does not hurt if it is present." + :group 'org-export-groff + :type '(repeat + (list + (symbol :tag "Major mode ") + (string :tag "Listings language")))) + +(defcustom org-groff-source-highlight-options nil + "Association list of options for the groff listings package. + +These options are supplied as a comma-separated list to the +\\lstset command. Each element of the association list should be +a list containing two strings: the name of the option, and the +value. For example, + + (setq org-groff-source-highlight-options + '((\"basicstyle\" \"\\small\") + (\"keywordstyle\" \"\\color{black}\\bfseries\\underbar\"))) + +will typeset the code in a small size font with underlined, bold +black keywords. + +Note that the same options will be applied to blocks of all +languages." + :group 'org-export-groff + :type '(repeat + (list + (string :tag "Listings option name ") + (string :tag "Listings option value")))) + +(defvar org-groff-custom-lang-environments nil + "Alist mapping languages to language-specific Groff environments. + +It is used during export of src blocks by the listings and +groff packages. For example, + + \(setq org-groff-custom-lang-environments + '\(\(python \"pythoncode\"\)\)\) + +would have the effect that if org encounters begin_src python +during groff export it will use pythoncode as the source-highlight +language.") + +;;; Plain text + +(defcustom org-groff-special-char + '(("(c)" . "\\\\(co") + ("(tm)" . "\\\\(tm") + ("(rg)" . "\\\\(rg")) + "CONS list in which the value of the car + is replace on the value of the CDR. " + :group 'org-export-groff + :type '(list + (cons :tag "Character Subtitute" + (string :tag "Original Character Group") + (string :tag "Replacement Character")))) + +;;; Compilation + +(defcustom org-groff-pdf-process + '("pic %f | tbl | eqn | groff -mm | ps2pdf - > %b.pdf" + "pic %f | tbl | eqn | groff -mm | ps2pdf - > %b.pdf" + "pic %f | tbl | eqn | groff -mm | ps2pdf - > %b.pdf") + + "Commands to process a Groff file to a PDF file. +This is a list of strings, each of them will be given to the +shell as a command. %f in the command will be replaced by the +full file name, %b by the file base name \(i.e. without +extension) and %o by the base directory of the file." + :group 'org-export-pdf + :type '(choice + (repeat :tag "Shell command sequence" + (string :tag "Shell command")) + (const :tag "2 runs of pdfgroff" + ("pic %f | tbl | eqn | groff -mm | ps2pdf - > %b.pdf" + "pic %f | tbl | eqn | groff -mm | ps2pdf - > %b.pdf")) + (const :tag "3 runs of pdfgroff" + ("pic %f | tbl | eqn | groff -mm | ps2pdf - > %b.pdf" + "pic %f | tbl | eqn | groff -mm | ps2pdf - > %b.pdf" + "pic %f | tbl | eqn | groff -mm | ps2pdf - > %b.pdf")) + (function))) + +(defcustom org-groff-logfiles-extensions + '("aux" "idx" "log" "out" "toc" "nav" "snm" "vrb") + "The list of file extensions to consider as Groff logfiles." + :group 'org-export-groff + :type '(repeat (string :tag "Extension"))) + +(defcustom org-groff-remove-logfiles t + "Non-nil means remove the logfiles produced by PDF production. +These are the .aux, .log, .out, and .toc files." + :group 'org-export-groff + :type 'boolean) + +(defcustom org-groff-organization "Org User" + "Name of the organization used to populate the .AF command." + :group 'org-export-groff + :type 'string) + +(defcustom org-groff-raster-to-ps nil + "Command used to convert raster to EPS. Nil for no conversion. Make sure that + `org-groff-inline-image-rules' is adjusted accordingly if not conversion is being + done. In this case, remove the entries for jpg and png in the file and fuzzy lists." + :group 'org-export-groff + :type '(choice + (repeat :tag "Shell Command Sequence" (string :tag "Shell Command")) + (const :tag "sam2p" "a=%s;b=%s;sam2p ${a} ${b} ;grep -v BeginData ${b} > b_${b};mv b_${b} ${b}" ) + (const :tag "NetPNM" "a=%s;b=%s;pngtopnm ${a} | pnmtops -noturn > ${b}" ) + (const :tag "None" nil))) + +(defvar org-groff-registered-references nil) +(defvar org-groff-special-content nil) + + + +;;; Internal Functions + +(defun org-groff--caption/label-string (element info) + "Return caption and label Groff string for ELEMENT. + +INFO is a plist holding contextual information. If there's no +caption nor label, return the empty string. + +For non-floats, see `org-groff--wrap-label'." + (let ((main (org-export-get-caption element)) + (short (org-export-get-caption element t)) + (label (org-element-property :name element))) + (cond ((and (not main) (not label)) "") + ((not main) (format "\\fI%s\\fP" label)) + ;; Option caption format with short name. + (short (format "%s\n.br\n - %s\n" + (org-export-data short info) + (org-export-data main info))) + ;; Standard caption format. + (t (format "\\fR%s\\fP" (org-export-data main info)))))) + +(defun org-groff--wrap-label (element output) + "Wrap label associated to ELEMENT around OUTPUT, if appropriate. +This function shouldn't be used for floats. See +`org-groff--caption/label-string'." + (let ((label (org-element-property :name element))) + (if (or (not output) (not label) (string= output "") (string= label "")) + output + (concat (format "%s\n.br\n" label) output)))) + +(defun org-groff--text-markup (text markup) + "Format TEXT depending on MARKUP text markup. +See `org-groff-text-markup-alist' for details." + (let ((fmt (cdr (assq markup org-groff-text-markup-alist)))) + (cond + ;; No format string: Return raw text. + ((not fmt) text) + ((string= "protectedtexttt" fmt) + (let ((start 0) + (trans '(("\\" . "\\"))) + (rtn "") + char) + (while (string-match "[\\{}$%&_#~^]" text) + (setq char (match-string 0 text)) + (if (> (match-beginning 0) 0) + (setq rtn (concat rtn (substring text 0 (match-beginning 0))))) + (setq text (substring text (1+ (match-beginning 0)))) + (setq char (or (cdr (assoc char trans)) (concat "\\" char)) + rtn (concat rtn char))) + (setq text (concat rtn text)) + (format "\\fC%s\\fP" text))) + ;; Else use format string. + (t (format fmt text))))) + + +(defun org-groff--get-tagged-content (tag info) + (cdr (assoc tag org-groff-special-content))) + +(defun org-groff--mt-head (title contents attr info) + (concat + + ;; 1. Insert Organization + (let ((firm-option (plist-get attr :firm))) + (cond + ((stringp firm-option) + (format ".AF \"%s\" \n" firm-option)) + (t (format ".AF \"%s\" \n" (or org-groff-organization ""))))) + + ;; 2. Title + (let ((title (if (plist-get info :with-title) title "")) + (subtitle1 (plist-get attr :subtitle1)) + (subtitle2 (plist-get attr :subtitle2))) + + (cond + ((string= "" title) + (format ".TL \"%s\" \"%s\" \n%s\n" + (or subtitle1 "") + (or subtitle2 "") " ")) + + ((not (or subtitle1 subtitle2)) + (format ".TL\n%s\n" + (or title ""))) + (t + (format ".TL \"%s\" \"%s \" \n%s\n" + (or subtitle1 "") + (or subtitle2 "") title)))) + + ;; 3. Author. + ;; In Groff, .AU *MUST* be placed after .TL + ;; If From, populate with data from From else + ;; + (let ((author (and (plist-get info :with-author) + (let ((auth (plist-get info :author))) + (and auth (org-export-data auth info))))) + (email (and (plist-get info :with-email) + (org-export-data (plist-get info :email) info))) + (from-data (org-groff--get-tagged-content "FROM" info)) + + (to-data (org-groff--get-tagged-content "TO" info))) + + (cond + ((and author from-data) + (let ((au-line + (mapconcat + (lambda (from-line) + (format " \"%s\" " from-line)) + (split-string + (setq from-data + (replace-regexp-in-string "\\.P\n" "" from-data)) "\n") ""))) + + (concat + (format ".AU \"%s\" " author) au-line "\n"))) + + ((and author email (not (string= "" email))) + (format ".AU \"%s\" \"%s\"\n" author email)) + + (author (format ".AU \"%s\"\n" author)) + + (t ".AU \"\" \n"))) + + + ;; 4. Author Title, if present + (let ((at-item (plist-get attr :author-title))) + (if (and at-item (stringp at-item)) + (format ".AT \"%s\" \n" at-item) + "")) + + ;; 5. Date. + (when (plist-get info :with-date) + (let ((date (org-export-data (org-export-get-date info) info))) + (and (org-string-nw-p date) (format ".ND \"%s\"\n" date)))) + + ;; + ;; If Abstract, then Populate Abstract + ;; + + (let ((abstract-data (org-groff--get-tagged-content "ABSTRACT" info)) + (to-data (org-groff--get-tagged-content "TO" info))) + (cond + (abstract-data + (format ".AS\n%s\n.AE\n" abstract-data)) + (to-data + (format ".AS\n%s\n.AE\n" to-data)))))) + +(defun org-groff--letter-head (title contents attr info) + (let ((author (and (plist-get info :with-author) + (let ((auth (plist-get info :author))) + (and auth (org-export-data auth info))))) + (email (and (plist-get info :with-email) + (org-export-data (plist-get info :email) info))) + (from-data (org-groff--get-tagged-content "FROM" info)) + (at-item (plist-get attr :author-title)) + (to-data (org-groff--get-tagged-content "TO" info))) + + + ;; If FROM then get data from FROM + (if from-data + (setq from-data + (replace-regexp-in-string "\\.P\n" "" from-data)) + (setq from-data "")) + + (if to-data + (setq to-data + (replace-regexp-in-string "\\.P\n" "" to-data)) + (setq from-data "")) + + (concat + (cond + (from-data + (format ".WA \"%s\" \"%s\" \n%s\n.WE\n" author (or at-item "") from-data)) + ((and author email (not (string= "" email))) + (format ".WA \"%s\"\n \"%s\"\n.WE\n" author email)) + (author (format ".WA \"%s\"\n.WE\n" author)) + (t ".WA \"\" \n.WE\n")) + + ;; If TO then get data from TO + + (when to-data + (format ".IA \n%s\n.IE\n" to-data))))) + + +;;; Template + +(defun org-groff-template (contents info) + "Return complete document string after Groff conversion. +CONTENTS is the transcoded contents string. INFO is a plist +holding export options." + (let* ((title (org-export-data (plist-get info :title) info)) + (attr (read + (format "(%s)" + (mapconcat + #'identity + (list (plist-get info :groff-class-options)) + " ")))) + (class (plist-get info :groff-class)) + (class-options (plist-get info :groff-class-options)) + (classes (assoc class org-groff-classes)) + (classes-options (car (last classes))) + (heading-option (plist-get classes-options :heading)) + (type-option (plist-get classes-options :type)) + (last-option (plist-get classes-options :last-section)) + (hyphenate (plist-get attr :hyphenate)) + (justify-right (plist-get attr :justify-right)) + + (document-class-string + (progn + (org-element-normalize-string + (let* ((header (nth 1 (assoc class org-groff-classes))) + (document-class-item (if (stringp header) header ""))) + document-class-item))))) + + + (concat + (if justify-right + (case justify-right + ('yes ".SA 1 \n") + ('no ".SA 0 \n") + (t "")) + "") + + (if hyphenate + (case hyphenate + ('yes ".nr Hy 1 \n") + ('no ".nr Hy 0 \n") + (t "")) + "") + + (cond + ((string= type-option "custom") "") + + ((and (stringp document-class-string) + (string= type-option "cover")) + + (concat + (format ".COVER %s\n" document-class-string) + (org-groff--mt-head title contents attr info) + ".COVEND\n")) + + ((string= type-option "memo") + (concat + (org-groff--mt-head title contents attr info) + document-class-string)) + ((string= type-option "letter") + (concat + (org-groff--letter-head title contents attr info) + (let ((sa-item (plist-get attr :salutation)) + (cn-item (plist-get attr :confidential)) + (sj-item (plist-get attr :subject)) + (rn-item (plist-get attr :reference)) + (at-item (plist-get attr :attention))) + + (concat + + (if (stringp sa-item) + (format ".LO SA \"%s\" \n" sa-item) + ".LO SA\n") + + (when cn-item + (if (stringp cn-item) + (format ".LO CN \"%s\"\n" cn-item) + ".LO CN\n")) + + (when (and at-item (stringp at-item)) + (format ".LO AT \"%s\" \n" at-item)) + (when (and title rn-item) + (format ".LO RN \"%s\"\n" title)) + + (when (and sj-item (stringp sj-item)) + (format ".LO SJ \"%s\" \n" sj-item)) + + + ".LT " document-class-string "\n")))) + + (t "")) + + contents + + (cond + ((string= last-option "toc") + ".TC") + ((string= last-option "sign") + (let ((fc-item (plist-get attr :closing))) + (concat (if (stringp fc-item) + (format ".FC \"%s\" \n" fc-item) + ".FC\n") + ".SG\n"))) + (t "")) + + (progn + (mapconcat + (lambda (item) + (when (string= (car item) "NS") + (replace-regexp-in-string + "\\.P\n" "" (cdr item)))) + (reverse org-groff-special-content) "\n"))))) + + + +;;; Transcode Functions + +;;; Babel Call +;; +;; Babel Calls are ignored. + + +;;; Bold + +(defun org-groff-bold (bold contents info) + "Transcode BOLD from Org to Groff. +CONTENTS is the text with bold markup. INFO is a plist holding +contextual information." + (org-groff--text-markup contents 'bold)) + +;;; Center Block + +(defun org-groff-center-block (center-block contents info) + "Transcode a CENTER-BLOCK element from Org to Groff. +CONTENTS holds the contents of the center block. INFO is a plist +holding contextual information." + (org-groff--wrap-label + center-block + (format ".DS C \n%s\n.DE" contents))) + +;;; Clock + +(defun org-groff-clock (clock contents info) + "Transcode a CLOCK element from Org to Groff. +CONTENTS is nil. INFO is a plist holding contextual +information." + (concat + (format "\\fB%s\\fP " org-clock-string) + (format org-groff-inactive-timestamp-format + (concat (org-timestamp-translate (org-element-property :value clock)) + (let ((time (org-element-property :duration clock))) + (and time (format " (%s)" time))))))) + +;;; Code + +(defun org-groff-code (code contents info) + "Transcode a CODE object from Org to Groff. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (org-groff--text-markup (org-element-property :value code) 'code)) + +;;; Comments and Comment Blocks are ignored. + +;;; Drawer + +(defun org-groff-drawer (drawer contents info) + "Transcode a DRAWER element from Org to Groff. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (let* ((name (org-element-property :drawer-name drawer)) + (output (if (functionp org-groff-format-drawer-function) + (funcall org-groff-format-drawer-function + name contents) + ;; If there's no user defined function: simply + ;; display contents of the drawer. + contents))) + (org-groff--wrap-label drawer output))) + +;;; Dynamic Block + +(defun org-groff-dynamic-block (dynamic-block contents info) + "Transcode a DYNAMIC-BLOCK element from Org to Groff. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information. See `org-export-data'." + (org-groff--wrap-label dynamic-block contents)) + +;;; Entity + +(defun org-groff-entity (entity contents info) + "Transcode an ENTITY object from Org to Groff. +CONTENTS are the definition itself. INFO is a plist holding +contextual information." + (org-element-property :utf-8 entity)) + +;;; Example Block + +(defun org-groff-example-block (example-block contents info) + "Transcode an EXAMPLE-BLOCK element from Org to Groff. +CONTENTS is nil. INFO is a plist holding contextual +information." + (org-groff--wrap-label + example-block + (format ".DS L\n%s\n.DE" + (org-export-format-code-default example-block info)))) + +;;; Export Block + +(defun org-groff-export-block (export-block contents info) + "Transcode a EXPORT-BLOCK element from Org to Groff. +CONTENTS is nil. INFO is a plist holding contextual information." + (when (string= (org-element-property :type export-block) "GROFF") + (org-remove-indentation (org-element-property :value export-block)))) + +;;; Export Snippet + +(defun org-groff-export-snippet (export-snippet contents info) + "Transcode a EXPORT-SNIPPET object from Org to Groff. +CONTENTS is nil. INFO is a plist holding contextual information." + (when (eq (org-export-snippet-backend export-snippet) 'groff) + (org-element-property :value export-snippet))) + +;;; Fixed Width + +(defun org-groff-fixed-width (fixed-width contents info) + "Transcode a FIXED-WIDTH element from Org to Groff. +CONTENTS is nil. INFO is a plist holding contextual information." + (org-groff--wrap-label + fixed-width + (format "\\fC\n%s\\fP" + (org-remove-indentation + (org-element-property :value fixed-width))))) + +;;; Footnote Definition +;; +;; Footnote Definitions are ignored. +;; +;; Footnotes are handled automatically in GROFF. Although manual +;; references can be added, not really required. + +(defun org-groff-footnote-reference (footnote-reference contents info) + ;; Changing from info to footnote-reference + (let* ((raw (org-export-get-footnote-definition footnote-reference info)) + (n (org-export-get-footnote-number footnote-reference info)) + (data (org-trim (org-export-data raw info))) + (ref-id (plist-get (nth 1 footnote-reference) :label))) + ;; It is a reference + (if (string-match "fn:rl" ref-id) + (if (member ref-id org-groff-registered-references) + (format "\\*[%s]" ref-id) + (progn + (push ref-id org-groff-registered-references) + (format "\\*(Rf\n.RS \"%s\" \n%s\n.RF\n" ref-id data))) + ;; else it is a footnote + (format "\\u\\s-2%s\\d\\s+2\n.FS %s\n%s\n.FE\n" n n data)))) + +;;; Headline + +(defun org-groff-headline (headline contents info) + "Transcode a HEADLINE element from Org to Groff. +CONTENTS holds the contents of the headline. INFO is a plist +holding contextual information." + (let* ((class (plist-get info :groff-class)) + (level (org-export-get-relative-level headline info)) + (numberedp (org-export-numbered-headline-p headline info)) + ;; Section formatting will set two placeholders: one for the + ;; title and the other for the contents. + (classes (assoc class org-groff-classes)) + (classes-options (car (last classes))) + (heading-option (plist-get classes-options :heading)) + (section-fmt + (progn + (cond + ((and (symbolp heading-option) + (fboundp heading-option)) + (funcall heading-option level numberedp)) + ((> level 7) nil) + (t (if numberedp + (concat ".H " (number-to-string level) " \"%s\"\n%s") + ".HU \"%s\"\n%s"))))) + ;; End of section-fmt + (text (org-export-data (org-element-property :title headline) info)) + (todo + (and (plist-get info :with-todo-keywords) + (let ((todo (org-element-property :todo-keyword headline))) + (and todo (org-export-data todo info))))) + (todo-type (and todo (org-element-property :todo-type headline))) + (tags (and (plist-get info :with-tags) + (org-export-get-tags headline info))) + (priority (and (plist-get info :with-priority) + (org-element-property :priority headline))) + ;; Create the headline text along with a no-tag version. The + ;; latter is required to remove tags from table of contents. + (full-text (if (functionp org-groff-format-headline-function) + ;; User-defined formatting function. + (funcall org-groff-format-headline-function + todo todo-type priority text tags) + ;; Default formatting. + (concat + (when todo + (format "\\fB%s\\fP " todo)) + (when priority (format " [\\#%c] " priority)) + text + (when tags + (format " \\fC:%s:\\fP " + (mapconcat 'identity tags ":")))))) + (full-text-no-tag + (if (functionp org-groff-format-headline-function) + ;; User-defined formatting function. + (funcall org-groff-format-headline-function + todo todo-type priority text nil) + ;; Default formatting. + (concat + (when todo (format "\\fB%s\\fP " todo)) + (when priority (format " [\\#%c] " priority)) + text))) + ;; Associate some \label to the headline for internal links. + ;; (headline-label + ;; (format "\\label{sec-%s}\n" + ;; (mapconcat 'number-to-string + ;; (org-export-get-headline-number headline info) + ;; "-"))) + (headline-label "") + (pre-blanks + (make-string (org-element-property :pre-blank headline) 10))) + + (cond + ;; Case 1: Special Tag + ((member (car tags) org-groff-special-tags) + (cond + ((string= (car tags) "BODY") contents) + + ((string= (car tags) "NS") + (progn + (push (cons (car tags) + (format ".NS \"%s\" 1 \n%s" + (car (org-element-property :title headline)) + (or contents " "))) + org-groff-special-content) nil)) + + (t + (progn + (push (cons (car tags) contents) org-groff-special-content) + nil)))) + + ;; Case 2: This is a footnote section: ignore it. + ((org-element-property :footnote-section-p headline) nil) + + ;; Case 3: This is a deep sub-tree: export it as a list item. + ;; Also export as items headlines for which no section + ;; format has been found. + ((or (not section-fmt) (org-export-low-level-p headline info)) + ;; Build the real contents of the sub-tree. + (let ((low-level-body + (concat + ;; If the headline is the first sibling, start a list. + (when (org-export-first-sibling-p headline info) + (format "%s\n" (if numberedp ".AL 1\n" ".DL \n"))) + ;; Itemize headline + ".LI\n" full-text "\n" headline-label pre-blanks contents))) + ;; If headline is not the last sibling simply return + ;; LOW-LEVEL-BODY. Otherwise, also close the list, before any + ;; blank line. + (if (not (org-export-last-sibling-p headline info)) low-level-body + (replace-regexp-in-string + "[ \t\n]*\\'" + (concat "\n.LE") + low-level-body)))) + + ;; Case 4. Standard headline. Export it as a section. + (t + (format section-fmt full-text + (concat headline-label pre-blanks contents)))))) + +;;; Horizontal Rule +;; Not supported + +;;; Inline Babel Call +;; +;; Inline Babel Calls are ignored. + +;;; Inline Src Block + +(defun org-groff-inline-src-block (inline-src-block contents info) + "Transcode an INLINE-SRC-BLOCK element from Org to Groff. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((code (org-element-property :value inline-src-block))) + (cond + (org-groff-source-highlight + (let* ((tmpdir temporary-file-directory) + (in-file (make-temp-name + (expand-file-name "srchilite" tmpdir))) + (out-file (make-temp-name + (expand-file-name "reshilite" tmpdir))) + (org-lang (org-element-property :language inline-src-block)) + (lst-lang (cadr (assq (intern org-lang) + org-groff-source-highlight-langs))) + + (cmd (concat (expand-file-name "source-highlight") + " -s " lst-lang + " -f groff_mm_color " + " -i " in-file + " -o " out-file))) + (if lst-lang + (let ((code-block "")) + (with-temp-file in-file (insert code)) + (shell-command cmd) + (setq code-block (org-file-contents out-file)) + (delete-file in-file) + (delete-file out-file) + code-block) + (format ".DS I\n\\fC\\m[black]%s\\m[]\\fP\n.DE\n" + code)))) + + ;; Do not use a special package: transcode it verbatim. + (t + (concat ".DS I\n" "\\fC" code "\\fP\n.DE\n"))))) + +;;; Inlinetask + +(defun org-groff-inlinetask (inlinetask contents info) + "Transcode an INLINETASK element from Org to Groff. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (let ((title (org-export-data (org-element-property :title inlinetask) info)) + (todo (and (plist-get info :with-todo-keywords) + (let ((todo (org-element-property :todo-keyword inlinetask))) + (and todo (org-export-data todo info))))) + (todo-type (org-element-property :todo-type inlinetask)) + (tags (and (plist-get info :with-tags) + (org-export-get-tags inlinetask info))) + (priority (and (plist-get info :with-priority) + (org-element-property :priority inlinetask)))) + ;; If `org-groff-format-inlinetask-function' is provided, call it + ;; with appropriate arguments. + (if (functionp org-groff-format-inlinetask-function) + (funcall org-groff-format-inlinetask-function + todo todo-type priority title tags contents) + ;; Otherwise, use a default template. + (org-groff--wrap-label + inlinetask + (let ((full-title + (concat + (when todo (format "\\fB%s\\fP " todo)) + (when priority (format " [\\#%c] " priority)) + title + (when tags (format " \\fC:%s:\\fP " + (mapconcat 'identity tags ":")))))) + (format (concat "\n.DS I\n" + "%s\n" + ".sp" + "%s\n" + ".DE") + full-title contents)))))) + +;;; Italic + +(defun org-groff-italic (italic contents info) + "Transcode ITALIC from Org to Groff. +CONTENTS is the text with italic markup. INFO is a plist holding +contextual information." + (org-groff--text-markup contents 'italic)) + +;;; Item + +(defun org-groff-item (item contents info) + "Transcode an ITEM element from Org to Groff. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((bullet (org-element-property :bullet item)) + (type (org-element-property + :type (org-element-property :parent item))) + (checkbox (case (org-element-property :checkbox item) + (on "\\o'\\(sq\\(mu'") + (off "\\(sq") + (trans "\\o'\\(sq\\(mi'"))) + (tag (let ((tag (org-element-property :tag item))) + ;; Check-boxes must belong to the tag. + (and tag (format "%s" + (concat checkbox + (org-export-data tag info))))))) + + (cond + ((or checkbox tag) + (concat ".LI ""\"" (or tag (concat "\\ " checkbox)) "\"" + "\n" + (org-trim (or contents " ")))) + ((eq type 'ordered) + (concat ".LI" + "\n" + (org-trim (or contents " ")))) + (t + (let* ((bullet (org-trim bullet)) + (marker (cond ((string= "-" bullet) "\\(em") + ((string= "*" bullet) "\\(bu") + (t "\\(dg")))) + (concat ".LI " marker "\n" + (org-trim (or contents " ")))))))) + +;;; Keyword + +(defun org-groff-keyword (keyword contents info) + "Transcode a KEYWORD element from Org to Groff. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((key (org-element-property :key keyword)) + (value (org-element-property :value keyword))) + (cond + ((string= key "GROFF") value) + (t nil)))) + +;;; Line Break + +(defun org-groff-line-break (line-break contents info) + "Transcode a LINE-BREAK object from Org to Groff. +CONTENTS is nil. INFO is a plist holding contextual information." + ".br\n") + +;;; Link +;; Inline images just place a call to .PSPIC or .PS/.PE +;; and load the graph. + +(defun org-groff-link--inline-image (link info) + "Return Groff code for an inline image. +LINK is the link pointing to the inline image. INFO is a plist +used as a communication channel." + (let* ((parent (org-export-get-parent-element link)) + (path (let ((raw-path (org-element-property :path link))) + (if (not (file-name-absolute-p raw-path)) raw-path + (expand-file-name raw-path)))) + (attr (org-export-read-attribute :attr_groff link)) + (placement + (let ((pos (plist-get attr :position))) + (cond ((string= pos 'center) "") + ((string= pos 'left) "-L") + ((string= pos 'right) "-R") + (t "")))) + (width (or (plist-get attr :width) "")) + (height (or (plist-get attr :height) "")) + (caption (and (not (plist-get attr :disable-caption)) + (org-groff--caption/label-string parent info)))) + ;; Now clear ATTR from any special keyword and set a default value + ;; if nothing is left. Return proper string. + (concat + (cond + ((and org-groff-raster-to-ps + (or (string-match ".\.png$" path) + (string-match ".\.jpg$" path))) + (let ((eps-path (concat path ".eps"))) + (shell-command (format org-groff-raster-to-ps path eps-path)) + (format "\n.DS L F\n.PSPIC %s \"%s\" %s %s\n.DE " + placement eps-path width height))) + ((string-match ".\.pic$" path) + (format "\n.PS\ncopy \"%s\"\n.PE" path)) + (t (format "\n.DS L F\n.PSPIC %s \"%s\" %s %s\n.DE " + placement path width height))) + (and caption (format "\n.FG \"%s\"" caption))))) + +(defun org-groff-link (link desc info) + "Transcode a LINK object from Org to Groff. + +DESC is the description part of the link, or the empty string. +INFO is a plist holding contextual information. See +`org-export-data'." + + (let* ((type (org-element-property :type link)) + (raw-path (org-element-property :path link)) + ;; Ensure DESC really exists, or set it to nil. + (desc (and (not (string= desc "")) desc)) + (imagep (org-export-inline-image-p + link org-groff-inline-image-rules)) + (path (cond + ((member type '("http" "https" "ftp" "mailto")) + (concat type ":" raw-path)) + ((string= type "file") (org-export-file-uri raw-path)) + (t raw-path)))) + (cond + ((org-export-custom-protocol-maybe link desc 'groff)) + ;; Image file. + (imagep (org-groff-link--inline-image link info)) + ;; import groff files + ((and (string= type "file") + (string-match ".\.groff$" raw-path)) + (concat ".so " raw-path "\n")) + ;; Radio link: transcode target's contents and use them as link's + ;; description. + ((string= type "radio") + (let ((destination (org-export-resolve-radio-link link info))) + (if (not destination) desc + (format "\\fI [%s] \\fP" + (org-export-get-reference destination info))))) + + ;; Links pointing to a headline: find destination and build + ;; appropriate referencing command. + ((member type '("custom-id" "fuzzy" "id")) + (let ((destination (if (string= type "fuzzy") + (org-export-resolve-fuzzy-link link info) + (org-export-resolve-id-link link info)))) + (case (org-element-type destination) + ;; Id link points to an external file. + (plain-text + (if desc (format "%s \\fBat\\fP \\fIfile://%s\\fP" desc destination) + (format "\\fI file://%s \\fP" destination))) + ;; Fuzzy link points nowhere. + ('nil + (format org-groff-link-with-unknown-path-format + (or desc + (org-export-data + (org-element-property :raw-link link) info)))) + ;; LINK points to a headline. If headlines are numbered and + ;; the link has no description, display headline's number. + ;; Otherwise, display description or headline's title. + (headline + (let ((label "")) + (if (and (plist-get info :section-numbers) (not desc)) + (format "\\fI%s\\fP" label) + (format "\\fI%s\\fP" + (or desc + (org-export-data + (org-element-property :title destination) info)))))) + ;; Fuzzy link points to a target. Do as above. + (otherwise + (let ((ref (org-export-get-reference destination info))) + (if (not desc) (format "\\fI%s\\fP" ref) + (format "%s \\fBat\\fP \\fI%s\\fP" desc ref))))))) + ;; External link with a description part. + ((and path desc) (format "%s \\fBat\\fP \\fI%s\\fP" path desc)) + ;; External link without a description part. + (path (format "\\fI%s\\fP" path)) + ;; No path, only description. Try to do something useful. + (t (format org-groff-link-with-unknown-path-format desc))))) + +;;; Node Property + +(defun org-groff-node-property (node-property contents info) + "Transcode a NODE-PROPERTY element from Org to Groff. +CONTENTS is nil. INFO is a plist holding contextual +information." + (format "%s:%s" + (org-element-property :key node-property) + (let ((value (org-element-property :value node-property))) + (if value (concat " " value) "")))) + +;;; Paragraph + +(defun org-groff-paragraph (paragraph contents info) + "Transcode a PARAGRAPH element from Org to Groff. +CONTENTS is the contents of the paragraph, as a string. INFO is +the plist used as a communication channel." + (let ((parent (plist-get (nth 1 paragraph) :parent))) + (when parent + (let* ((parent-type (car parent)) + (fixed-paragraph "") + (class (plist-get info :groff-class)) + (class-options (plist-get info :groff-class-options)) + (classes (assoc class org-groff-classes)) + (classes-options (car (last classes))) + (paragraph-option (plist-get classes-options :paragraph))) + (cond + ((and (symbolp paragraph-option) + (fboundp paragraph-option)) + (funcall paragraph-option parent-type parent contents)) + ((and (eq parent-type 'item) + (plist-get (nth 1 parent) :bullet)) + (setq fixed-paragraph (concat "" contents))) + ((eq parent-type 'section) + (setq fixed-paragraph (concat ".P\n" contents))) + ((eq parent-type 'footnote-definition) + (setq fixed-paragraph (concat "" contents))) + (t (setq fixed-paragraph (concat "" contents)))) + fixed-paragraph)))) + +;;; Plain List + +(defun org-groff-plain-list (plain-list contents info) + "Transcode a PLAIN-LIST element from Org to Groff. +CONTENTS is the contents of the list. INFO is a plist holding +contextual information." + (let* ((type (org-element-property :type plain-list)) + (attr (mapconcat #'identity + (org-element-property :attr_groff plain-list) + " ")) + (groff-type (cond + ((eq type 'ordered) ".AL") + ((eq type 'unordered) ".BL") + ((eq type 'descriptive) ".VL 2.0i")))) + (org-groff--wrap-label + plain-list + (format "%s\n%s\n.LE" groff-type contents)))) + +;;; Plain Text + +(defun org-groff-plain-text (text info) + "Transcode a TEXT string from Org to Groff. +TEXT is the string to transcode. INFO is a plist holding +contextual information." +(let ((output text)) + ;; Protect various characters. + (setq output (replace-regexp-in-string + "\\(?:[^\\]\\|^\\)\\(\\\\\\)\\(?:[^%$#&{}~^_\\]\\|$\\)" + "$\\" output nil t 1)) + ;; Activate smart quotes. Be sure to provide original TEXT string + ;; since OUTPUT may have been modified. + (when (plist-get info :with-smart-quotes) + (setq output (org-export-activate-smart-quotes output :utf-8 info text))) + ;; Handle Special Characters + (if org-groff-special-char + (dolist (special-char-list org-groff-special-char) + (setq output + (replace-regexp-in-string (car special-char-list) + (cdr special-char-list) output)))) + ;; Handle break preservation if required. + (when (plist-get info :preserve-breaks) + (setq output (replace-regexp-in-string + "\\(\\\\\\\\\\)?[ \t]*\n" ".br\n" output))) + ;; Return value. + output)) + +;;; Planning + +(defun org-groff-planning (planning contents info) + "Transcode a PLANNING element from Org to Groff. +CONTENTS is nil. INFO is a plist holding contextual +information." + (concat + (mapconcat + 'identity + (delq nil + (list + (let ((closed (org-element-property :closed planning))) + (when closed + (concat + (format "\\fR %s \\fP" org-closed-string) + (format org-groff-inactive-timestamp-format + (org-timestamp-translate closed))))) + (let ((deadline (org-element-property :deadline planning))) + (when deadline + (concat + (format "\\fB %s \\fP" org-deadline-string) + (format org-groff-active-timestamp-format + (org-timestamp-translate deadline))))) + (let ((scheduled (org-element-property :scheduled planning))) + (when scheduled + (concat + (format "\\fR %s \\fP" org-scheduled-string) + (format org-groff-active-timestamp-format + (org-timestamp-translate scheduled))))))) + "") + "")) + +;;;; Property Drawer + +(defun org-groff-property-drawer (property-drawer contents info) + "Transcode a PROPERTY-DRAWER element from Org to Groff. +CONTENTS holds the contents of the drawer. INFO is a plist +holding contextual information." + (and (org-string-nw-p contents) + (format "\\fC\n%s\\fP" contents))) + +;;; Quote Block + +(defun org-groff-quote-block (quote-block contents info) + "Transcode a QUOTE-BLOCK element from Org to Groff. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (org-groff--wrap-label + quote-block + (format ".DS I\n.I\n%s\n.R\n.DE" contents))) + +;;; Radio Target + +(defun org-groff-radio-target (radio-target text info) + "Transcode a RADIO-TARGET object from Org to Groff. +TEXT is the text of the target. INFO is a plist holding +contextual information." + (format "%s - %s" (org-export-get-reference radio-target info) text)) + +;;; Section + +(defun org-groff-section (section contents info) + "Transcode a SECTION element from Org to Groff. +CONTENTS holds the contents of the section. INFO is a plist +holding contextual information." + contents) + +;;; Special Block + +(defun org-groff-special-block (special-block contents info) + "Transcode a SPECIAL-BLOCK element from Org to Groff. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (let ((type (org-element-property :type special-block))) + (org-groff--wrap-label + special-block + (format "%s\n" contents)))) + +;;; Src Block + +(defun org-groff-src-block (src-block contents info) + "Transcode a SRC-BLOCK element from Org to Groff. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((lang (org-element-property :language src-block)) + (label (org-element-property :name src-block)) + (code (org-element-property :value src-block)) + (custom-env (and lang + (cadr (assq (intern lang) + org-groff-custom-lang-environments)))) + (num-start (org-export-get-loc src-block info)) + (retain-labels (org-element-property :retain-labels src-block)) + (caption (and (not (org-export-read-attribute + :attr_groff src-block :disable-caption)) + (org-groff--caption/label-string src-block info)))) + + (cond + ;; Case 1. No source fontification. + ((not org-groff-source-highlight) + (concat + (format ".DS I\n\\fC%s\\fP\n.DE\n" + (org-export-format-code-default src-block info)) + (and caption (format ".EX \"%s\" " caption)))) + + ;; Case 2. Source fontification. + (org-groff-source-highlight + (let* ((tmpdir temporary-file-directory) + (in-file (make-temp-name + (expand-file-name "srchilite" tmpdir))) + (out-file (make-temp-name + (expand-file-name "reshilite" tmpdir))) + + (org-lang (org-element-property :language src-block)) + (lst-lang (cadr (assq (intern org-lang) + org-groff-source-highlight-langs))) + + (cmd (concat "source-highlight" + " -s " lst-lang + " -f groff_mm_color " + " -i " in-file + " -o " out-file))) + + (concat + (if lst-lang + (let ((code-block "")) + (with-temp-file in-file (insert code)) + (shell-command cmd) + (setq code-block (org-file-contents out-file)) + (delete-file in-file) + (delete-file out-file) + (format "%s\n" code-block)) + (format ".DS I\n\\fC\\m[black]%s\\m[]\\fP\n.DE\n" + code)) + (and caption (format ".EX \"%s\" " caption)))))))) + + +;;; Statistics Cookie + +(defun org-groff-statistics-cookie (statistics-cookie contents info) + "Transcode a STATISTICS-COOKIE object from Org to Groff. +CONTENTS is nil. INFO is a plist holding contextual information." + (org-element-property :value statistics-cookie)) + + +;;; Strike-Through + +(defun org-groff-strike-through (strike-through contents info) + "Transcode STRIKE-THROUGH from Org to Groff. +CONTENTS is the text with strike-through markup. INFO is a plist +holding contextual information." + (org-groff--text-markup contents 'strike-through)) + +;;; Subscript + +(defun org-groff-subscript (subscript contents info) + "Transcode a SUBSCRIPT object from Org to Groff. +CONTENTS is the contents of the object. INFO is a plist holding +contextual information." + (format "\\d\\s-2%s\\s+2\\u" contents)) + +;;; Superscript "^_%s$ + +(defun org-groff-superscript (superscript contents info) + "Transcode a SUPERSCRIPT object from Org to Groff. +CONTENTS is the contents of the object. INFO is a plist holding +contextual information." + (format "\\u\\s-2%s\\s+2\\d" contents)) + + +;;; Table +;; +;; `org-groff-table' is the entry point for table transcoding. It +;; takes care of tables with a "verbatim" attribute. Otherwise, it +;; delegates the job to `org-groff-table--org-table' function, +;; depending of the type of the table. +;; +;; `org-groff-table--align-string' is a subroutine used to build +;; alignment string for Org tables. + +(defun org-groff-table (table contents info) + "Transcode a TABLE element from Org to Groff. +CONTENTS is the contents of the table. INFO is a plist holding +contextual information." + (cond + ;; Case 1: verbatim table. + ((or org-groff-tables-verbatim + (let ((attr (read (format "(%s)" + (mapconcat + #'identity + (org-element-property :attr_groff table) " "))))) + (and attr (plist-get attr :verbatim)))) + + (format ".DS L\n\\fC%s\\fP\n.DE" + ;; Re-create table, without affiliated keywords. + (org-trim + (org-element-interpret-data + `(table nil ,@(org-element-contents table)))))) + + ;; Case 2: Standard table. + (t (org-groff-table--org-table table contents info)))) + +(defun org-groff-table--align-string (divider table info) + "Return an appropriate Groff alignment string. +TABLE is the considered table. INFO is a plist used as +a communication channel." + (let (alignment) + ;; Extract column groups and alignment from first (non-rule) row. + (org-element-map + (org-element-map table 'table-row + (lambda (row) + (and (eq (org-element-property :type row) 'standard) row)) + info 'first-match) + 'table-cell + (lambda (cell) + (let* ((borders (org-export-table-cell-borders cell info)) + (raw-width (org-export-table-cell-width cell info)) + (width-cm (when raw-width (/ raw-width 5))) + (width (if raw-width (format "w(%dc)" + (if (< width-cm 1) 1 width-cm)) ""))) + ;; Check left border for the first cell only. + ;; Alignment is nil on assignment + + (when (and (memq 'left borders) (not alignment)) + (push "|" alignment)) + (push + (case (org-export-table-cell-alignment cell info) + (left (concat "l" width divider)) + (right (concat "r" width divider)) + (center (concat "c" width divider))) + alignment) + (when (memq 'right borders) (push "|" alignment)))) + info) + (apply 'concat (reverse alignment)))) + +(defun org-groff-table--org-table (table contents info) + "Return appropriate Groff code for an Org table. + +TABLE is the table type element to transcode. CONTENTS is its +contents, as a string. INFO is a plist used as a communication +channel. + +This function assumes TABLE has `org' as its `:type' attribute." + (let* ((attr (org-export-read-attribute :attr_groff table)) + (label (org-element-property :name table)) + (caption (and (not (plist-get attr :disable-caption)) + (org-groff--caption/label-string table info))) + (divider (if (plist-get attr :divider) "|" " ")) + + ;; Determine alignment string. + (alignment (org-groff-table--align-string divider table info)) + + ;; Extract others display options. + + (lines (org-split-string contents "\n")) + + (attr-list + (delq nil + (list (and (plist-get attr :expand) "expand") + (let ((placement (plist-get attr :placement))) + (cond ((string= placement 'center) "center") + ((string= placement 'left) nil) + (t (if org-groff-tables-centered "center" "")))) + (or (plist-get attr :boxtype) "box")))) + + (title-line (plist-get attr :title-line)) + (long-cells (plist-get attr :long-cells)) + + (table-format + (concat + (or (car attr-list) "") + (or + (let (output-list) + (when (cdr attr-list) + (dolist (attr-item (cdr attr-list)) + (setq output-list (concat output-list + (format ",%s" attr-item))))) + output-list) ""))) + (first-line + (when lines (org-split-string (car lines) "\t")))) + ;; Prepare the final format string for the table. + + + (cond + ;; Others. + (lines + (concat ".TS\n " table-format ";\n" + (format "%s.\n" + (let ((final-line "")) + (when title-line + (dotimes (i (length first-line)) + (setq final-line (concat final-line "cb" divider)))) + + (setq final-line (concat final-line "\n")) + + (if alignment + (setq final-line (concat final-line alignment)) + (dotimes (i (length first-line)) + (setq final-line (concat final-line "c" divider)))) + final-line)) + + (format "%s.TE\n" + (let ((final-line "") + (long-line "") + (lines (org-split-string contents "\n"))) + + (dolist (line-item lines) + (setq long-line "") + + (if long-cells + (progn + (if (string= line-item "_") + (setq long-line (format "%s\n" line-item)) + ;; else string = + (let ((cell-item-list (org-split-string line-item "\t"))) + (dolist (cell-item cell-item-list) + + (cond ((eq cell-item (car (last cell-item-list))) + (setq long-line (concat long-line + (format "T{\n%s\nT}\t\n" cell-item)))) + (t + (setq long-line (concat long-line + (format "T{\n%s\nT}\t" cell-item)))))) + long-line)) + ;; else long cells + (setq final-line (concat final-line long-line))) + + (setq final-line (concat final-line line-item "\n")))) + final-line)) + + (if caption (format ".TB \"%s\"" caption) "")))))) + +;;; Table Cell + +(defun org-groff-table-cell (table-cell contents info) + "Transcode a TABLE-CELL element from Org to Groff +CONTENTS is the cell contents. INFO is a plist used as +a communication channel." + (progn + (concat (if (and contents + org-groff-table-scientific-notation + (string-match orgtbl-exp-regexp contents)) + ;; Use appropriate format string for scientific + ;; notation. + (format org-groff-table-scientific-notation + (match-string 1 contents) + (match-string 2 contents)) + contents) + (when (org-export-get-next-element table-cell info) "\t")))) + + +;;; Table Row + +(defun org-groff-table-row (table-row contents info) + "Transcode a TABLE-ROW element from Org to Groff +CONTENTS is the contents of the row. INFO is a plist used as +a communication channel." + ;; Rules are ignored since table separators are deduced from + ;; borders of the current row. + (when (eq (org-element-property :type table-row) 'standard) + (let* ((attr (mapconcat 'identity + (org-element-property + :attr_groff (org-export-get-parent table-row)) + " ")) + ;; TABLE-ROW's borders are extracted from its first cell. + (borders + (org-export-table-cell-borders + (car (org-element-contents table-row)) info))) + (concat + ;; Mark horizontal lines + (cond ((and (memq 'top borders) (memq 'above borders)) "_\n")) + contents + (cond + ;; When BOOKTABS are activated enforce bottom rule even when + ;; no hline was specifically marked. + ((and (memq 'bottom borders) (memq 'below borders)) "\n_") + ((memq 'below borders) "\n_")))))) + +;;; Target + +(defun org-groff-target (target contents info) + "Transcode a TARGET object from Org to Groff. +CONTENTS is nil. INFO is a plist holding contextual +information." + (format "\\fI%s\\fP" (org-export-get-reference target info))) + +;;; Timestamp + +(defun org-groff-timestamp (timestamp contents info) + "Transcode a TIMESTAMP object from Org to Groff. +CONTENTS is nil. INFO is a plist holding contextual +information." + (let ((value (org-groff-plain-text + (org-timestamp-translate timestamp) info))) + (case (org-element-property :type timestamp) + ((active active-range) + (format org-groff-active-timestamp-format value)) + ((inactive inactive-range) + (format org-groff-inactive-timestamp-format value)) + (t (format org-groff-diary-timestamp-format value))))) + +;;; Underline + +(defun org-groff-underline (underline contents info) + "Transcode UNDERLINE from Org to Groff. +CONTENTS is the text with underline markup. INFO is a plist +holding contextual information." + (org-groff--text-markup contents 'underline)) + +;;; Verbatim + +(defun org-groff-verbatim (verbatim contents info) + "Transcode a VERBATIM object from Org to Groff. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (org-groff--text-markup (org-element-property :value verbatim) 'verbatim)) + +;;; Verse Block + +(defun org-groff-verse-block (verse-block contents info) + "Transcode a VERSE-BLOCK element from Org to Groff. +CONTENTS is verse block contents. INFO is a plist holding +contextual information." + (format ".DS C\n.ft HI\n%s\n.ft\n.DE" contents)) + + +;;; Interactive functions + +(defun org-groff-export-to-groff + (&optional async subtreep visible-only body-only ext-plist) + "Export current buffer to a Groff file. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +A non-nil optional argument ASYNC means the process should happen +asynchronously. The resulting file should be accessible through +the `org-export-stack' interface. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +Return output file's name." + (interactive) + (let ((outfile (org-export-output-file-name ".groff" subtreep)) + (org-groff-registered-references nil) + (org-groff-special-content nil)) + (org-export-to-file 'groff outfile + async subtreep visible-only body-only ext-plist))) + +(defun org-groff-export-to-pdf + (&optional async subtreep visible-only body-only ext-plist) + "Export current buffer to Groff then process through to PDF. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +A non-nil optional argument ASYNC means the process should happen +asynchronously. The resulting file should be accessible through +the `org-export-stack' interface. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +Return PDF file's name." + (interactive) + (let ((outfile (org-export-output-file-name ".groff" subtreep))) + (org-export-to-file 'groff outfile + async subtreep visible-only body-only ext-plist + (lambda (file) (org-groff-compile file))))) + +(defun org-groff-compile (file) + "Compile a Groff file. + +FILE is the name of the file being compiled. Processing is done +through the command specified in `org-groff-pdf-process'. + +Return PDF file name or an error if it couldn't be produced." + (let* ((base-name (file-name-sans-extension (file-name-nondirectory file))) + (full-name (file-truename file)) + (out-dir (file-name-directory file)) + (time (current-time)) + ;; Properly set working directory for compilation. + (default-directory (if (file-name-absolute-p file) + (file-name-directory full-name) + default-directory)) + errors) + (message (format "Processing Groff file %s ..." file)) + (save-window-excursion + (cond + ;; A function is provided: Apply it. + ((functionp org-groff-pdf-process) + (funcall org-groff-pdf-process (shell-quote-argument file))) + ;; A list is provided: Replace %b, %f and %o with appropriate + ;; values in each command before applying it. Output is + ;; redirected to "*Org PDF Groff Output*" buffer. + ((consp org-groff-pdf-process) + (let ((outbuf (get-buffer-create "*Org PDF Groff Output*"))) + (mapc + (lambda (command) + (shell-command + (replace-regexp-in-string + "%b" (shell-quote-argument base-name) + (replace-regexp-in-string + "%f" (shell-quote-argument full-name) + (replace-regexp-in-string + "%o" (shell-quote-argument out-dir) command t t) + t t) t t) + outbuf)) + org-groff-pdf-process) + ;; Collect standard errors from output buffer. + (setq errors (org-groff-collect-errors outbuf)))) + (t (error "No valid command to process to PDF"))) + (let ((pdffile (concat out-dir base-name ".pdf"))) + ;; Check for process failure. Provide collected errors if + ;; possible. + (if (or (not (file-exists-p pdffile)) + ;; Only compare times up to whole seconds as some + ;; filesystems (e.g. HFS+) do not retain any finer + ;; granularity. + (time-less-p (cl-subseq (nth 5 (file-attributes pdffile)) 0 2) + (cl-subseq time 0 2))) + (error (concat (format "PDF file %s wasn't produced" pdffile) + (when errors (concat ": " errors)))) + ;; Else remove log files, when specified, and signal end of + ;; process to user, along with any error encountered. + (when org-groff-remove-logfiles + (dolist (ext org-groff-logfiles-extensions) + (let ((file (concat out-dir base-name "." ext))) + (when (file-exists-p file) (delete-file file))))) + (message (concat "Process completed" + (if (not errors) "." + (concat " with errors: " errors))))) + ;; Return output file name. + pdffile)))) + +(defun org-groff-collect-errors (buffer) + "Collect some kind of errors from \"groff\" output +BUFFER is the buffer containing output. +Return collected error types as a string, or nil if there was +none." + (with-current-buffer buffer + (save-excursion + (goto-char (point-max)) + ;; Find final run + nil))) + + +(provide 'ox-groff) +;;; ox-groff.el ends here diff --git a/contrib/lisp/ox-koma-letter.el b/contrib/lisp/ox-koma-letter.el new file mode 100644 index 0000000..37da54c --- /dev/null +++ b/contrib/lisp/ox-koma-letter.el @@ -0,0 +1,917 @@ +;;; ox-koma-letter.el --- KOMA Scrlttr2 Back-End for Org Export Engine + +;; Copyright (C) 2007-2017 Free Software Foundation, Inc. + +;; Author: Nicolas Goaziou <n.goaziou AT gmail DOT com> +;; Alan Schmitt <alan.schmitt AT polytechnique DOT org> +;; Viktor Rosenfeld <listuser36 AT gmail DOT com> +;; Rasmus Pank Roulund <emacs AT pank DOT eu> +;; Keywords: org, wp, tex + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This library implements a KOMA Scrlttr2 back-end, derived from the +;; LaTeX one. +;; +;; Depending on the desired output format, three commands are provided +;; for export: `org-koma-letter-export-as-latex' (temporary buffer), +;; `org-koma-letter-export-to-latex' ("tex" file) and +;; `org-koma-letter-export-to-pdf' ("pdf" file). +;; +;; On top of buffer keywords supported by `latex' back-end (see +;; `org-latex-options-alist'), this back-end introduces the following +;; keywords: +;; - CLOSING: see `org-koma-letter-closing', +;; - FROM_ADDRESS: see `org-koma-letter-from-address', +;; - LCO: see `org-koma-letter-class-option-file', +;; - OPENING: see `org-koma-letter-opening', +;; - PHONE_NUMBER: see `org-koma-letter-phone-number', +;; - SIGNATURE: see `org-koma-letter-signature', +;; - PLACE: see `org-koma-letter-place', +;; - LOCATION: see `org-koma-letter-location', +;; - TO_ADDRESS: If unspecified this is set to "\mbox{}". +;; +;; TO_ADDRESS, FROM_ADDRESS, LOCATION, CLOSING, and SIGNATURE can also +;; be specified using "special headings" with the special tags +;; specified in `org-koma-letter-special-tags-in-letter'. LaTeX line +;; breaks are not necessary for TO_ADDRESS, FROM_ADDRESS and LOCATION. +;; If both a headline and a keyword specify a to or from address the +;; value is determined in accordance with +;; `org-koma-letter-prefer-special-headings'. +;; +;; A number of OPTIONS settings can be set to change which contents is +;; exported. +;; - backaddress (see `org-koma-letter-use-backaddress') +;; - foldmarks (see `org-koma-letter-use-foldmarks') +;; - phone (see `org-koma-letter-use-phone') +;; - email (see `org-koma-letter-use-email') +;; - place (see `org-koma-letter-use-place') +;; - location (see `org-koma-letter-use-location') +;; - subject, a list of format options +;; (see `org-koma-letter-subject-format') +;; - after-closing-order, a list of the ordering of headings with +;; special tags after closing (see +;; `org-koma-letter-special-tags-after-closing') +;; - after-letter-order, as above, but after the end of the letter +;; (see `org-koma-letter-special-tags-after-letter'). +;; +;; The following variables works differently from the main LaTeX class +;; - AUTHOR: Default to user-full-name but may be disabled. +;; (See also `org-koma-letter-author'), +;; - EMAIL: Same as AUTHOR. (see also `org-koma-letter-email'), +;; +;; Headlines are in general ignored. However, headlines with special +;; tags can be used for specified contents like postscript (ps), +;; carbon copy (cc), enclosures (encl) and code to be inserted after +;; \end{letter} (after_letter). Specials tags are defined in +;; `org-koma-letter-special-tags-after-closing' and +;; `org-koma-letter-special-tags-after-letter'. Currently members of +;; `org-koma-letter-special-tags-after-closing' used as macros and the +;; content of the headline is the argument. +;; +;; Headlines with to and from may also be used rather than the keyword +;; approach described above. If both a keyword and a headline with +;; information is present precedence is determined by +;; `org-koma-letter-prefer-special-headings'. +;; +;; You need an appropriate association in `org-latex-classes' in order +;; to use the KOMA Scrlttr2 class. By default, a sparse scrlttr2 +;; class is provided: "default-koma-letter". You can also add you own +;; letter class. For instance: +;; +;; (add-to-list 'org-latex-classes +;; '("my-letter" +;; "\\documentclass\[% +;; DIV=14, +;; fontsize=12pt, +;; parskip=half, +;; subject=titled, +;; backaddress=false, +;; fromalign=left, +;; fromemail=true, +;; fromphone=true\]\{scrlttr2\} +;; \[DEFAULT-PACKAGES] +;; \[PACKAGES] +;; \[EXTRA]")) +;; +;; Then, in your Org document, be sure to require the proper class +;; with: +;; +;; #+LATEX_CLASS: my-letter +;; +;; Or by setting `org-koma-letter-default-class'. +;; +;; You may have to load (LaTeX) Babel as well, e.g., by adding +;; it to `org-latex-packages-alist', +;; +;; (add-to-list 'org-latex-packages-alist '("AUTO" "babel" nil)) + +;;; Code: + +(require 'ox-latex) + +;; Install a default letter class. +(unless (assoc "default-koma-letter" org-latex-classes) + (add-to-list 'org-latex-classes + '("default-koma-letter" "\\documentclass[11pt]{scrlttr2}"))) + + +;;; User-Configurable Variables + +(defgroup org-export-koma-letter nil + "Options for exporting to KOMA scrlttr2 class in LaTeX export." + :tag "Org Koma-Letter" + :group 'org-export) + +(defcustom org-koma-letter-class-option-file "NF" + "Letter Class Option File. +This option can also be set with the LCO keyword." + :group 'org-export-koma-letter + :type 'string) + +(defcustom org-koma-letter-author 'user-full-name + "Sender's name. + +This variable defaults to calling the function `user-full-name' +which just returns the current function `user-full-name'. +Alternatively a string, nil or a function may be given. +Functions must return a string. + +This option can also be set with the AUTHOR keyword." + :group 'org-export-koma-letter + :type '(radio (function-item user-full-name) + (string) + (function) + (const :tag "Do not export author" nil))) + +(defcustom org-koma-letter-email 'org-koma-letter-email + "Sender's email address. + +This variable defaults to the value `org-koma-letter-email' which +returns `user-mail-address'. Alternatively a string, nil or +a function may be given. Functions must return a string. + +This option can also be set with the EMAIL keyword." + :group 'org-export-koma-letter + :type '(radio (function-item org-koma-letter-email) + (string) + (function) + (const :tag "Do not export email" nil))) + +(defcustom org-koma-letter-from-address "" + "Sender's address, as a string. +This option can also be set with one or more FROM_ADDRESS +keywords." + :group 'org-export-koma-letter + :type 'string) + +(defcustom org-koma-letter-phone-number "" + "Sender's phone number, as a string. +This option can also be set with the PHONE_NUMBER keyword." + :group 'org-export-koma-letter + :type 'string) + +(defcustom org-koma-letter-place "" + "Place from which the letter is sent, as a string. +This option can also be set with the PLACE keyword." + :group 'org-export-koma-letter + :type 'string) + +(defcustom org-koma-letter-location "" + "Sender's extension field, as a string. + +This option can also be set with the LOCATION keyword. +Moreover, when: + (1) Either `org-koma-letter-prefer-special-headings' is non-nil + or there is no LOCATION keyword or the LOCATION keyword is + empty; + (2) the letter contains a headline with the special + tag \"location\"; +then the location will be set as the content of the location +special heading. + +The location field is typically printed right of the address +field (See Figure 4.9. in the English manual of 2015-10-03)." + :group 'org-export-koma-letter + :type 'string) + +(defcustom org-koma-letter-opening "" + "Letter's opening, as a string. + +This option can also be set with the OPENING keyword. Moreover, +when: + (1) Either `org-koma-letter-prefer-special-headings' is non-nil + or the CLOSING keyword is empty + (2) `org-koma-letter-headline-is-opening-maybe' is non-nil; + (3) the letter contains a headline without a special + tag (e.g. \"to\" or \"ps\"); +then the opening will be implicitly set as the untagged headline title." + :group 'org-export-koma-letter + :type 'string) + +(defcustom org-koma-letter-closing "" + "Letter's closing, as a string. +This option can also be set with the CLOSING keyword. Moreover, +when: + (1) Either `org-koma-letter-prefer-special-headings' is non-nil + or the CLOSING keyword is empty; + (2) `org-koma-letter-headline-is-opening-maybe' is non-nil; + (3) the letter contains a headline with the special + tag \"closing\"; +then the opening will be set as the title of the closing special +heading title." + :group 'org-export-koma-letter + :type 'string) + +(defcustom org-koma-letter-signature "" + "Signature, as a string. +This option can also be set with the SIGNATURE keyword. +Moreover, when: + (1) Either `org-koma-letter-prefer-special-headings' is non-nil + or there is no CLOSING keyword or the CLOSING keyword is empty; + (2) `org-koma-letter-headline-is-opening-maybe' is non-nil; + (3) the letter contains a headline with the special + tag \"closing\"; +then the signature will be set as the content of the +closing special heading. + +Note if the content is empty the signature will not be set." + :group 'org-export-koma-letter + :type 'string) + +(defcustom org-koma-letter-prefer-special-headings nil + "Non-nil means prefer headlines over keywords for TO and FROM. +This option can also be set with the OPTIONS keyword, e.g.: +\"special-headings:t\"." + :group 'org-export-koma-letter + :type 'boolean) + +(defcustom org-koma-letter-subject-format t + "Non-nil means include the subject. + +Support formatting options. + +When t, insert a subject using default options. When nil, do not +insert a subject at all. It can also be a list of symbols among +the following ones: + + `afteropening' Subject after opening + `beforeopening' Subject before opening + `centered' Subject centered + `left' Subject left-justified + `right' Subject right-justified + `titled' Add title/description to subject + `underlined' Set subject underlined + `untitled' Do not add title/description to subject + +Please refer to the KOMA-script manual (Table 4.16. in the +English manual of 2012-07-22). + +This option can also be set with the OPTIONS keyword, e.g.: +\"subject:(underlined centered)\"." + :type + '(choice + (const :tag "No export" nil) + (const :tag "Default options" t) + (set :tag "Configure options" + (const :tag "Subject after opening" afteropening) + (const :tag "Subject before opening" beforeopening) + (const :tag "Subject centered" centered) + (const :tag "Subject left-justified" left) + (const :tag "Subject right-justified" right) + (const :tag "Add title or description to subject" underlined) + (const :tag "Set subject underlined" titled) + (const :tag "Do not add title or description to subject" untitled))) + :group 'org-export-koma-letter) + +(defcustom org-koma-letter-use-backaddress nil + "Non-nil prints return address in line above to address. +This option can also be set with the OPTIONS keyword, e.g.: +\"backaddress:t\"." + :group 'org-export-koma-letter + :type 'boolean) + +(defcustom org-koma-letter-use-foldmarks t + "Configure appearance of folding marks. + +When t, activate default folding marks. When nil, do not insert +folding marks at all. It can also be a list of symbols among the +following ones: + + `B' Activate upper horizontal mark on left paper edge + `b' Deactivate upper horizontal mark on left paper edge + + `H' Activate all horizontal marks on left paper edge + `h' Deactivate all horizontal marks on left paper edge + + `L' Activate left vertical mark on upper paper edge + `l' Deactivate left vertical mark on upper paper edge + + `M' Activate middle horizontal mark on left paper edge + `m' Deactivate middle horizontal mark on left paper edge + + `P' Activate punch or center mark on left paper edge + `p' Deactivate punch or center mark on left paper edge + + `T' Activate lower horizontal mark on left paper edge + `t' Deactivate lower horizontal mark on left paper edge + + `V' Activate all vertical marks on upper paper edge + `v' Deactivate all vertical marks on upper paper edge + +This option can also be set with the OPTIONS keyword, e.g.: +\"foldmarks:(b l m t)\"." + :group 'org-export-koma-letter + :type '(choice + (const :tag "Activate default folding marks" t) + (const :tag "Deactivate folding marks" nil) + (set + :tag "Configure folding marks" + (const :tag "Activate upper horizontal mark on left paper edge" B) + (const :tag "Deactivate upper horizontal mark on left paper edge" b) + (const :tag "Activate all horizontal marks on left paper edge" H) + (const :tag "Deactivate all horizontal marks on left paper edge" h) + (const :tag "Activate left vertical mark on upper paper edge" L) + (const :tag "Deactivate left vertical mark on upper paper edge" l) + (const :tag "Activate middle horizontal mark on left paper edge" M) + (const :tag "Deactivate middle horizontal mark on left paper edge" m) + (const :tag "Activate punch or center mark on left paper edge" P) + (const :tag "Deactivate punch or center mark on left paper edge" p) + (const :tag "Activate lower horizontal mark on left paper edge" T) + (const :tag "Deactivate lower horizontal mark on left paper edge" t) + (const :tag "Activate all vertical marks on upper paper edge" V) + (const :tag "Deactivate all vertical marks on upper paper edge" v)))) + +(defcustom org-koma-letter-use-phone nil + "Non-nil prints sender's phone number. +This option can also be set with the OPTIONS keyword, e.g.: +\"phone:t\"." + :group 'org-export-koma-letter + :type 'boolean) + +(defcustom org-koma-letter-use-email nil + "Non-nil prints sender's email address. +This option can also be set with the OPTIONS keyword, e.g.: +\"email:t\"." + :group 'org-export-koma-letter + :type 'boolean) + +(defcustom org-koma-letter-use-place t + "Non-nil prints the letter's place next to the date. +This option can also be set with the OPTIONS keyword, e.g.: +\"place:nil\"." + :group 'org-export-koma-letter + :type 'boolean) + +(defcustom org-koma-letter-default-class "default-koma-letter" + "Default class for `org-koma-letter'. +The value must be a member of `org-latex-classes'." + :group 'org-export-koma-letter + :type 'string) + +(defcustom org-koma-letter-headline-is-opening-maybe t + "Non-nil means a headline may be used as an opening and closing. +See also `org-koma-letter-opening' and +`org-koma-letter-closing'." + :group 'org-export-koma-letter + :type 'boolean) + +(defcustom org-koma-letter-prefer-subject nil + "Non-nil means title should be interpreted as subject if subject is missing. +This option can also be set with the OPTIONS keyword, +e.g. \"title-subject:t\"." + :group 'org-export-koma-letter + :type 'boolean) + +(defconst org-koma-letter-special-tags-in-letter '(to from closing location) + "Header tags related to the letter itself.") + +(defconst org-koma-letter-special-tags-after-closing '(after_closing ps encl cc) + "Header tags to be inserted in the letter after closing.") + +(defconst org-koma-letter-special-tags-as-macro '(ps encl cc) + "Header tags to be inserted as macros") + +(defconst org-koma-letter-special-tags-after-letter '(after_letter) + "Header tags to be inserted after the letter.") + +(defvar org-koma-letter-special-contents nil + "Holds special content temporarily.") + +(make-obsolete-variable 'org-koma-letter-use-title + 'org-export-with-title + "25.1" 'set) + + +;;; Define Back-End + +(org-export-define-derived-backend 'koma-letter 'latex + :options-alist + '((:latex-class "LATEX_CLASS" nil org-koma-letter-default-class t) + (:lco "LCO" nil org-koma-letter-class-option-file) + (:author "AUTHOR" nil (org-koma-letter--get-value org-koma-letter-author) parse) + (:author-changed-in-buffer-p "AUTHOR" nil nil t) + (:from-address "FROM_ADDRESS" nil org-koma-letter-from-address newline) + (:phone-number "PHONE_NUMBER" nil org-koma-letter-phone-number) + (:email "EMAIL" nil (org-koma-letter--get-value org-koma-letter-email) t) + (:to-address "TO_ADDRESS" nil nil newline) + (:place "PLACE" nil org-koma-letter-place) + (:location "LOCATION" nil org-koma-letter-location) + (:subject "SUBJECT" nil nil parse) + (:opening "OPENING" nil org-koma-letter-opening parse) + (:closing "CLOSING" nil org-koma-letter-closing parse) + (:signature "SIGNATURE" nil org-koma-letter-signature newline) + (:special-headings nil "special-headings" org-koma-letter-prefer-special-headings) + (:special-tags-as-macro nil nil org-koma-letter-special-tags-as-macro) + (:special-tags-in-letter nil nil org-koma-letter-special-tags-in-letter) + (:special-tags-after-closing nil "after-closing-order" + org-koma-letter-special-tags-after-closing) + (:special-tags-after-letter nil "after-letter-order" + org-koma-letter-special-tags-after-letter) + (:with-backaddress nil "backaddress" org-koma-letter-use-backaddress) + (:with-email nil "email" org-koma-letter-use-email) + (:with-foldmarks nil "foldmarks" org-koma-letter-use-foldmarks) + (:with-phone nil "phone" org-koma-letter-use-phone) + (:with-place nil "place" org-koma-letter-use-place) + (:with-subject nil "subject" org-koma-letter-subject-format) + (:with-title-as-subject nil "title-subject" org-koma-letter-prefer-subject) + (:with-headline-opening nil nil org-koma-letter-headline-is-opening-maybe) + ;; Special properties non-nil when a setting happened in buffer. + ;; They are used to prioritize in-buffer settings over "lco" + ;; files. See `org-koma-letter-template'. + (:inbuffer-author "AUTHOR" nil 'koma-letter:empty) + (:inbuffer-from "FROM" nil 'koma-letter:empty) + (:inbuffer-email "EMAIL" nil 'koma-letter:empty) + (:inbuffer-phone-number "PHONE_NUMBER" nil 'koma-letter:empty) + (:inbuffer-place "PLACE" nil 'koma-letter:empty) + (:inbuffer-location "LOCATION" nil 'koma-letter:empty) + (:inbuffer-signature "SIGNATURE" nil 'koma-letter:empty) + (:inbuffer-with-backaddress nil "backaddress" 'koma-letter:empty) + (:inbuffer-with-email nil "email" 'koma-letter:empty) + (:inbuffer-with-foldmarks nil "foldmarks" 'koma-letter:empty) + (:inbuffer-with-phone nil "phone" 'koma-letter:empty) + (:inbuffer-with-place nil "place" 'koma-letter:empty)) + :translate-alist '((export-block . org-koma-letter-export-block) + (export-snippet . org-koma-letter-export-snippet) + (headline . org-koma-letter-headline) + (keyword . org-koma-letter-keyword) + (template . org-koma-letter-template)) + :menu-entry + '(?k "Export with KOMA Scrlttr2" + ((?L "As LaTeX buffer" org-koma-letter-export-as-latex) + (?l "As LaTeX file" org-koma-letter-export-to-latex) + (?p "As PDF file" org-koma-letter-export-to-pdf) + (?o "As PDF file and open" + (lambda (a s v b) + (if a (org-koma-letter-export-to-pdf t s v b) + (org-open-file (org-koma-letter-export-to-pdf nil s v b)))))))) + + + +;;; Helper functions + +(defun org-koma-letter-email () + "Return the current `user-mail-address'." + user-mail-address) + +;; The following is taken from/inspired by ox-grof.el +;; Thanks, Luis! + +(defun org-koma-letter--get-tagged-contents (key) + "Get contents from a headline tagged with KEY. +The contents is stored in `org-koma-letter-special-contents'." + (let ((value (cdr (assoc-string (org-koma-letter--get-value key) + org-koma-letter-special-contents)))) + (when value (org-string-nw-p (org-trim value))))) + +(defun org-koma-letter--get-value (value) + "Turn value into a string whenever possible. +Determines if VALUE is nil, a string, a function or a symbol and +return a string or nil." + (when value + (cond ((stringp value) value) + ((functionp value) (funcall value)) + ((symbolp value) (symbol-name value)) + (t value)))) + +(defun org-koma-letter--special-contents-inline (keywords info) + "Process KEYWORDS members of `org-koma-letter-special-contents'. +KEYWORDS is a list of symbols. Return them as a string to be +formatted. + +The function is used for inserting content of special headings +such as the one tagged with PS. +" + (mapconcat + (lambda (keyword) + (let* ((name (org-koma-letter--get-value keyword)) + (value (org-koma-letter--get-tagged-contents name)) + (macrop (memq keyword (plist-get info :special-tags-as-macro)))) + (cond ((not value) nil) + (macrop (format "\\%s{%s}\n" name value)) + (t value)))) + keywords + "\n")) + + +(defun org-koma-letter--add-latex-newlines (string) + "Replace regular newlines with LaTeX newlines (i.e. `\\\\')" + (let ((str (org-trim string))) + (when (org-string-nw-p str) + (replace-regexp-in-string "\n" "\\\\\\\\\n" str)))) + + + +;;; Transcode Functions + +;;;; Export Block + +(defun org-koma-letter-export-block (export-block contents info) + "Transcode an EXPORT-BLOCK element into KOMA Scrlttr2 code. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (when (member (org-element-property :type export-block) '("KOMA-LETTER" "LATEX")) + (org-remove-indentation (org-element-property :value export-block)))) + +;;;; Export Snippet + +(defun org-koma-letter-export-snippet (export-snippet contents info) + "Transcode an EXPORT-SNIPPET object into KOMA Scrlttr2 code. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (when (memq (org-export-snippet-backend export-snippet) '(latex koma-letter)) + (org-element-property :value export-snippet))) + +;;;; Keyword + +(defun org-koma-letter-keyword (keyword contents info) + "Transcode a KEYWORD element into KOMA Scrlttr2 code. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (let ((key (org-element-property :key keyword)) + (value (org-element-property :value keyword))) + ;; Handle specifically KOMA-LETTER keywords. Otherwise, fallback + ;; to `latex' back-end. + (if (equal key "KOMA-LETTER") value + (org-export-with-backend 'latex keyword contents info)))) + +;; Headline + +(defun org-koma-letter-headline (headline contents info) + "Transcode a HEADLINE element from Org to LaTeX. +CONTENTS holds the contents of the headline. INFO is a plist +holding contextual information. + +Note that if a headline is tagged with a tag from +`org-koma-letter-special-tags' it will not be exported, but +stored in `org-koma-letter-special-contents' and included at the +appropriate place." + (let ((special-tag (org-koma-letter--special-tag headline info))) + (if (not special-tag) + contents + (push (cons special-tag contents) org-koma-letter-special-contents) + ""))) + +(defun org-koma-letter--special-tag (headline info) + "Non-nil if HEADLINE is a special headline. +INFO is a plist holding contextual information. Return first +special tag headline." + (let ((special-tags (append + (plist-get info :special-tags-in-letter) + (plist-get info :special-tags-after-closing) + (plist-get info :special-tags-after-letter)))) + (catch 'exit + (dolist (tag (org-export-get-tags headline info)) + (let ((tag (assoc-string tag special-tags))) + (when tag (throw 'exit tag))))))) + +(defun org-koma-letter--keyword-or-headline (plist-key pred info) + "Return the correct version of opening or closing. +PLIST-KEY should be a key in info, typically :opening +or :closing. PRED is a predicate run on headline to determine +which title to use which takes two arguments, a headline element +and an info plist. INFO is a plist holding contextual +information. Return the preferred candidate for the exported of +PLIST-KEY." + (let* ((keyword-candidate (plist-get info plist-key)) + (headline-candidate (when (and (plist-get info :with-headline-opening) + (or (plist-get info :special-headings) + (not keyword-candidate))) + (org-element-map (plist-get info :parse-tree) + 'headline + (lambda (head) + (when (funcall pred head info) + (org-element-property :title head))) + info t)))) + (org-export-data (or headline-candidate keyword-candidate "") info))) + +;;;; Template + +(defun org-koma-letter-template (contents info) + "Return complete document string after KOMA Scrlttr2 conversion. +CONTENTS is the transcoded contents string. INFO is a plist +holding export options." + (concat + ;; Time-stamp. + (and (plist-get info :time-stamp-file) + (format-time-string "%% Created %Y-%m-%d %a %H:%M\n")) + ;; LaTeX compiler + (org-latex--insert-compiler info) + ;; Document class and packages. + (org-latex-make-preamble info) + ;; Settings. They can come from three locations, in increasing + ;; order of precedence: global variables, LCO files and in-buffer + ;; settings. Thus, we first insert settings coming from global + ;; variables, then we insert LCO files, and, eventually, we insert + ;; settings coming from buffer keywords. + (org-koma-letter--build-settings 'global info) + (mapconcat #'(lambda (file) (format "\\LoadLetterOption{%s}\n" file)) + (org-split-string (or (plist-get info :lco) "") " ") + "") + (org-koma-letter--build-settings 'buffer info) + ;; Date. + (format "\\date{%s}\n" (org-export-data (org-export-get-date info) info)) + ;; Hyperref, document start, and subject and title. + (let* ((with-subject (plist-get info :with-subject)) + (with-title (plist-get info :with-title)) + (title-as-subject (and with-subject + (plist-get info :with-title-as-subject))) + (subject* (org-string-nw-p + (org-export-data (plist-get info :subject) info))) + (title* (and with-title + (org-string-nw-p + (org-export-data (plist-get info :title) info)))) + (subject (cond ((not with-subject) nil) + (title-as-subject (or subject* title*)) + (t subject*))) + (title (cond ((not with-title) nil) + (title-as-subject (and subject* title*)) + (t title*))) + (hyperref-template (plist-get info :latex-hyperref-template)) + (spec (append (list (cons ?t (or title subject ""))) + (org-latex--format-spec info)))) + (concat + (when (and with-subject (not (eq with-subject t))) + (format "\\KOMAoption{subject}{%s}\n" + (if (symbolp with-subject) with-subject + (mapconcat #'symbol-name with-subject ",")))) + ;; Hyperref. + (format-spec hyperref-template spec) + ;; Document start. + "\\begin{document}\n\n" + ;; Subject and title. + (when subject (format "\\setkomavar{subject}{%s}\n" subject)) + (when title (format "\\setkomavar{title}{%s}\n" title)) + (when (or (org-string-nw-p title) (org-string-nw-p subject)) "\n"))) + ;; Letter start. + (let ((keyword-val (plist-get info :to-address)) + (heading-val (org-koma-letter--get-tagged-contents 'to))) + (format "\\begin{letter}{%%\n%s}\n\n" + (org-koma-letter--add-latex-newlines + (or (if (plist-get info :special-headings) + (or heading-val keyword-val) + (or keyword-val heading-val)) + "\\\\mbox{}")))) + ;; Opening. + (format "\\opening{%s}\n\n" + (org-koma-letter--keyword-or-headline + :opening (lambda (h i) (not (org-koma-letter--special-tag h i))) + info)) + ;; Letter body. + contents + ;; Closing. + (format "\\closing{%s}\n" + (org-koma-letter--keyword-or-headline + :closing (lambda (h i) (eq (org-koma-letter--special-tag h i) + 'closing)) + info)) + (org-koma-letter--special-contents-inline + (plist-get info :special-tags-after-closing) info) + ;; Letter end. + "\n\\end{letter}\n" + (org-koma-letter--special-contents-inline + (plist-get info :special-tags-after-letter) info) + ;; Document end. + "\n\\end{document}")) + +(defun org-koma-letter--build-settings (scope info) + "Build settings string according to type. +SCOPE is either `global' or `buffer'. INFO is a plist used as +a communication channel." + (let* ((check-scope + (function + ;; Non-nil value when SETTING was defined in SCOPE. + (lambda (setting) + (let ((property (intern (format ":inbuffer-%s" setting)))) + (if (eq scope 'global) + (eq (plist-get info property) 'koma-letter:empty) + (not (eq (plist-get info property) 'koma-letter:empty))))))) + (heading-or-key-value + (function + (lambda (heading key &optional scoped) + (let* ((heading-val + (org-koma-letter--get-tagged-contents heading)) + (key-val (org-string-nw-p (plist-get info key))) + (scopedp (funcall check-scope (or scoped heading)))) + (and (or (and key-val scopedp) heading-val) + (not (and (eq scope 'global) heading-val)) + (if scopedp key-val heading-val))))))) + (concat + ;; Name. + (let ((author (plist-get info :author))) + (and author + (funcall check-scope 'author) + (format "\\setkomavar{fromname}{%s}\n" + (org-export-data author info)))) + ;; From. + (let ((from (funcall heading-or-key-value 'from :from-address))) + (and from + (format "\\setkomavar{fromaddress}{%s}\n" + (org-koma-letter--add-latex-newlines from)))) + ;; Email. + (let ((email (plist-get info :email))) + (and email + (funcall check-scope 'email) + (format "\\setkomavar{fromemail}{%s}\n" email))) + (and (funcall check-scope 'with-email) + (format "\\KOMAoption{fromemail}{%s}\n" + (if (plist-get info :with-email) "true" "false"))) + ;; Phone number. + (let ((phone-number (plist-get info :phone-number))) + (and (org-string-nw-p phone-number) + (funcall check-scope 'phone-number) + (format "\\setkomavar{fromphone}{%s}\n" phone-number))) + (and (funcall check-scope 'with-phone) + (format "\\KOMAoption{fromphone}{%s}\n" + (if (plist-get info :with-phone) "true" "false"))) + ;; Signature. + (let* ((heading-val + (and (plist-get info :with-headline-opening) + (org-string-nw-p + (org-trim + (org-export-data + (org-koma-letter--get-tagged-contents 'closing) + info))))) + (signature (org-string-nw-p (plist-get info :signature))) + (signature-scope (funcall check-scope 'signature))) + (and (or (and signature signature-scope) + heading-val) + (not (and (eq scope 'global) heading-val)) + (format "\\setkomavar{signature}{%s}\n" + (if signature-scope signature heading-val)))) + ;; Back address. + (and (funcall check-scope 'with-backaddress) + (format "\\KOMAoption{backaddress}{%s}\n" + (if (plist-get info :with-backaddress) "true" "false"))) + ;; Place. + (let ((with-place-set (funcall check-scope 'with-place)) + (place-set (funcall check-scope 'place))) + (and (or (and with-place-set place-set) + (and (eq scope 'buffer) (or with-place-set place-set))) + (format "\\setkomavar{place}{%s}\n" + (if (plist-get info :with-place) (plist-get info :place) + "")))) + ;; Location. + (let ((location (funcall heading-or-key-value 'location :location))) + (and location + (format "\\setkomavar{location}{%s}\n" location))) + ;; Folding marks. + (and (funcall check-scope 'with-foldmarks) + (let ((foldmarks (plist-get info :with-foldmarks))) + (cond ((consp foldmarks) + (format "\\KOMAoptions{foldmarks=true,foldmarks=%s}\n" + (mapconcat #'symbol-name foldmarks ""))) + (foldmarks "\\KOMAoptions{foldmarks=true}\n") + (t "\\KOMAoptions{foldmarks=false}\n"))))))) + + + +;;; Commands + +;;;###autoload +(defun org-koma-letter-export-as-latex + (&optional async subtreep visible-only body-only ext-plist) + "Export current buffer as a KOMA Scrlttr2 letter. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +A non-nil optional argument ASYNC means the process should happen +asynchronously. The resulting buffer should be accessible +through the `org-export-stack' interface. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only write code +between \"\\begin{letter}\" and \"\\end{letter}\". + +EXT-PLIST, when provided, is a proeprty list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +Export is done in a buffer named \"*Org KOMA-LETTER Export*\". It +will be displayed if `org-export-show-temporary-export-buffer' is +non-nil." + (interactive) + (let (org-koma-letter-special-contents) + (org-export-to-buffer 'koma-letter "*Org KOMA-LETTER Export*" + async subtreep visible-only body-only ext-plist + (lambda () (LaTeX-mode))))) + +;;;###autoload +(defun org-koma-letter-export-to-latex + (&optional async subtreep visible-only body-only ext-plist) + "Export current buffer as a KOMA Scrlttr2 letter (tex). + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +A non-nil optional argument ASYNC means the process should happen +asynchronously. The resulting file should be accessible through +the `org-export-stack' interface. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only write code +between \"\\begin{letter}\" and \"\\end{letter}\". + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +When optional argument PUB-DIR is set, use it as the publishing +directory. + +Return output file's name." + (interactive) + (let ((outfile (org-export-output-file-name ".tex" subtreep)) + (org-koma-letter-special-contents)) + (org-export-to-file 'koma-letter outfile + async subtreep visible-only body-only ext-plist))) + +;;;###autoload +(defun org-koma-letter-export-to-pdf + (&optional async subtreep visible-only body-only ext-plist) + "Export current buffer as a KOMA Scrlttr2 letter (pdf). + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +A non-nil optional argument ASYNC means the process should happen +asynchronously. The resulting file should be accessible through +the `org-export-stack' interface. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only write code +between \"\\begin{letter}\" and \"\\end{letter}\". + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +Return PDF file's name." + (interactive) + (let ((file (org-export-output-file-name ".tex" subtreep)) + (org-koma-letter-special-contents)) + (org-export-to-file 'koma-letter file + async subtreep visible-only body-only ext-plist + (lambda (file) (org-latex-compile file))))) + + +(provide 'ox-koma-letter) +;;; ox-koma-letter.el ends here diff --git a/contrib/lisp/ox-rss.el b/contrib/lisp/ox-rss.el new file mode 100644 index 0000000..a3ba274 --- /dev/null +++ b/contrib/lisp/ox-rss.el @@ -0,0 +1,419 @@ +;;; ox-rss.el --- RSS 2.0 Back-End for Org Export Engine + +;; Copyright (C) 2013-2015 Bastien Guerry + +;; Author: Bastien Guerry <bzg@gnu.org> +;; Keywords: org, wp, blog, feed, rss + +;; This file is not yet part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This library implements a RSS 2.0 back-end for Org exporter, based on +;; the `html' back-end. +;; +;; It requires Emacs 24.1 at least. +;; +;; It provides two commands for export, depending on the desired output: +;; `org-rss-export-as-rss' (temporary buffer) and `org-rss-export-to-rss' +;; (as a ".xml" file). +;; +;; This backend understands three new option keywords: +;; +;; #+RSS_EXTENSION: xml +;; #+RSS_IMAGE_URL: http://myblog.org/mypicture.jpg +;; #+RSS_FEED_URL: http://myblog.org/feeds/blog.xml +;; +;; It uses #+HTML_LINK_HOME: to set the base url of the feed. +;; +;; Exporting an Org file to RSS modifies each top-level entry by adding a +;; PUBDATE property. If `org-rss-use-entry-url-as-guid', it will also add +;; an ID property, later used as the guid for the feed's item. +;; +;; The top-level headline is used as the title of each RSS item unless +;; an RSS_TITLE property is set on the headline. +;; +;; You typically want to use it within a publishing project like this: +;; +;; (add-to-list +;; 'org-publish-project-alist +;; '("homepage_rss" +;; :base-directory "~/myhomepage/" +;; :base-extension "org" +;; :rss-image-url "http://lumiere.ens.fr/~guerry/images/faces/15.png" +;; :html-link-home "http://lumiere.ens.fr/~guerry/" +;; :html-link-use-abs-url t +;; :rss-extension "xml" +;; :publishing-directory "/home/guerry/public_html/" +;; :publishing-function (org-rss-publish-to-rss) +;; :section-numbers nil +;; :exclude ".*" ;; To exclude all files... +;; :include ("index.org") ;; ... except index.org. +;; :table-of-contents nil)) +;; +;; ... then rsync /home/guerry/public_html/ with your server. +;; +;; By default, the permalink for a blog entry points to the headline. +;; You can specify a different one by using the :RSS_PERMALINK: +;; property within an entry. + +;;; Code: + +(require 'ox-html) +(declare-function url-encode-url "url-util" (url)) + +;;; Variables and options + +(defgroup org-export-rss nil + "Options specific to RSS export back-end." + :tag "Org RSS" + :group 'org-export + :version "24.4" + :package-version '(Org . "8.0")) + +(defcustom org-rss-image-url "http://orgmode.org/img/org-mode-unicorn-logo.png" + "The URL of the an image for the RSS feed." + :group 'org-export-rss + :type 'string) + +(defcustom org-rss-extension "xml" + "File extension for the RSS 2.0 feed." + :group 'org-export-rss + :type 'string) + +(defcustom org-rss-categories 'from-tags + "Where to extract items category information from. +The default is to extract categories from the tags of the +headlines. When set to another value, extract the category +from the :CATEGORY: property of the entry." + :group 'org-export-rss + :type '(choice + (const :tag "From tags" from-tags) + (const :tag "From the category property" from-category))) + +(defcustom org-rss-use-entry-url-as-guid t + "Use the URL for the <guid> metatag? +When nil, Org will create ids using `org-icalendar-create-uid'." + :group 'org-export-rss + :type 'boolean) + +;;; Define backend + +(org-export-define-derived-backend 'rss 'html + :menu-entry + '(?r "Export to RSS" + ((?R "As RSS buffer" + (lambda (a s v b) (org-rss-export-as-rss a s v))) + (?r "As RSS file" (lambda (a s v b) (org-rss-export-to-rss a s v))) + (?o "As RSS file and open" + (lambda (a s v b) + (if a (org-rss-export-to-rss t s v) + (org-open-file (org-rss-export-to-rss nil s v))))))) + :options-alist + '((:description "DESCRIPTION" nil nil newline) + (:keywords "KEYWORDS" nil nil space) + (:with-toc nil nil nil) ;; Never include HTML's toc + (:rss-extension "RSS_EXTENSION" nil org-rss-extension) + (:rss-image-url "RSS_IMAGE_URL" nil org-rss-image-url) + (:rss-feed-url "RSS_FEED_URL" nil nil t) + (:rss-categories nil nil org-rss-categories)) + :filters-alist '((:filter-final-output . org-rss-final-function)) + :translate-alist '((headline . org-rss-headline) + (comment . (lambda (&rest args) "")) + (comment-block . (lambda (&rest args) "")) + (timestamp . (lambda (&rest args) "")) + (plain-text . org-rss-plain-text) + (section . org-rss-section) + (template . org-rss-template))) + +;;; Export functions + +;;;###autoload +(defun org-rss-export-as-rss (&optional async subtreep visible-only) + "Export current buffer to a RSS buffer. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +A non-nil optional argument ASYNC means the process should happen +asynchronously. The resulting buffer should be accessible +through the `org-export-stack' interface. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +Export is done in a buffer named \"*Org RSS Export*\", which will +be displayed when `org-export-show-temporary-export-buffer' is +non-nil." + (interactive) + (let ((file (buffer-file-name (buffer-base-buffer)))) + (org-icalendar-create-uid file 'warn-user) + (org-rss-add-pubdate-property)) + (org-export-to-buffer 'rss "*Org RSS Export*" + async subtreep visible-only nil nil (lambda () (text-mode)))) + +;;;###autoload +(defun org-rss-export-to-rss (&optional async subtreep visible-only) + "Export current buffer to a RSS file. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +A non-nil optional argument ASYNC means the process should happen +asynchronously. The resulting file should be accessible through +the `org-export-stack' interface. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +Return output file's name." + (interactive) + (let ((file (buffer-file-name (buffer-base-buffer)))) + (org-icalendar-create-uid file 'warn-user) + (org-rss-add-pubdate-property)) + (let ((outfile (org-export-output-file-name + (concat "." org-rss-extension) subtreep))) + (org-export-to-file 'rss outfile async subtreep visible-only))) + +;;;###autoload +(defun org-rss-publish-to-rss (plist filename pub-dir) + "Publish an org file to RSS. + +FILENAME is the filename of the Org file to be published. PLIST +is the property list for the given project. PUB-DIR is the +publishing directory. + +Return output file name." + (let ((bf (get-file-buffer filename))) + (if bf + (with-current-buffer bf + (org-icalendar-create-uid filename 'warn-user) + (org-rss-add-pubdate-property) + (write-file filename)) + (find-file filename) + (org-icalendar-create-uid filename 'warn-user) + (org-rss-add-pubdate-property) + (write-file filename) (kill-buffer))) + (org-publish-org-to + 'rss filename (concat "." org-rss-extension) plist pub-dir)) + +;;; Main transcoding functions + +(defun org-rss-headline (headline contents info) + "Transcode HEADLINE element into RSS format. +CONTENTS is the headline contents. INFO is a plist used as a +communication channel." + (if (> (org-export-get-relative-level headline info) 1) + (org-export-data-with-backend headline 'html info) + (unless (org-element-property :footnote-section-p headline) + (let* ((email (org-export-data (plist-get info :email) info)) + (author (and (plist-get info :with-author) + (let ((auth (plist-get info :author))) + (and auth (org-export-data auth info))))) + (htmlext (plist-get info :html-extension)) + (hl-number (org-export-get-headline-number headline info)) + (hl-home (file-name-as-directory (plist-get info :html-link-home))) + (hl-pdir (plist-get info :publishing-directory)) + (hl-perm (org-element-property :RSS_PERMALINK headline)) + (anchor (org-export-get-reference headline info)) + (category (org-rss-plain-text + (or (org-element-property :CATEGORY headline) "") info)) + (pubdate0 (org-element-property :PUBDATE headline)) + (pubdate (let ((system-time-locale "C")) + (if pubdate0 + (format-time-string + "%a, %d %b %Y %H:%M:%S %z" + (org-time-string-to-time pubdate0))))) + (title (org-rss-plain-text + (or (org-element-property :RSS_TITLE headline) + (replace-regexp-in-string + org-bracket-link-regexp + (lambda (m) (or (match-string 3 m) + (match-string 1 m))) + (org-element-property :raw-value headline))) info)) + (publink + (or (and hl-perm (concat (or hl-home hl-pdir) hl-perm)) + (concat + (or hl-home hl-pdir) + (file-name-nondirectory + (file-name-sans-extension + (plist-get info :input-file))) "." htmlext "#" anchor))) + (guid (if org-rss-use-entry-url-as-guid + publink + (org-rss-plain-text + (or (org-element-property :ID headline) + (org-element-property :CUSTOM_ID headline) + publink) + info)))) + (if (not pubdate0) "" ;; Skip entries with no PUBDATE prop + (format + (concat + "<item>\n" + "<title>%s</title>\n" + "<link>%s</link>\n" + "<author>%s (%s)</author>\n" + "<guid isPermaLink=\"false\">%s</guid>\n" + "<pubDate>%s</pubDate>\n" + (org-rss-build-categories headline info) "\n" + "<description><![CDATA[%s]]></description>\n" + "</item>\n") + title publink email author guid pubdate contents)))))) + +(defun org-rss-build-categories (headline info) + "Build categories for the RSS item." + (if (eq (plist-get info :rss-categories) 'from-tags) + (mapconcat + (lambda (c) (format "<category><![CDATA[%s]]></category>" c)) + (org-element-property :tags headline) + "\n") + (let ((c (org-element-property :CATEGORY headline))) + (format "<category><![CDATA[%s]]></category>" c)))) + +(defun org-rss-template (contents info) + "Return complete document string after RSS conversion. +CONTENTS is the transcoded contents string. INFO is a plist used +as a communication channel." + (concat + (format "<?xml version=\"1.0\" encoding=\"%s\"?>" + (symbol-name org-html-coding-system)) + "\n<rss version=\"2.0\" + xmlns:content=\"http://purl.org/rss/1.0/modules/content/\" + xmlns:wfw=\"http://wellformedweb.org/CommentAPI/\" + xmlns:dc=\"http://purl.org/dc/elements/1.1/\" + xmlns:atom=\"http://www.w3.org/2005/Atom\" + xmlns:sy=\"http://purl.org/rss/1.0/modules/syndication/\" + xmlns:slash=\"http://purl.org/rss/1.0/modules/slash/\" + xmlns:georss=\"http://www.georss.org/georss\" + xmlns:geo=\"http://www.w3.org/2003/01/geo/wgs84_pos#\" + xmlns:media=\"http://search.yahoo.com/mrss/\">" + "<channel>" + (org-rss-build-channel-info info) "\n" + contents + "</channel>\n" + "</rss>")) + +(defun org-rss-build-channel-info (info) + "Build the RSS channel information." + (let* ((system-time-locale "C") + (title (org-export-data (plist-get info :title) info)) + (email (org-export-data (plist-get info :email) info)) + (author (and (plist-get info :with-author) + (let ((auth (plist-get info :author))) + (and auth (org-export-data auth info))))) + (date (format-time-string "%a, %d %b %Y %H:%M:%S %z")) ;; RFC 882 + (description (org-export-data (plist-get info :description) info)) + (lang (plist-get info :language)) + (keywords (plist-get info :keywords)) + (rssext (plist-get info :rss-extension)) + (blogurl (or (plist-get info :html-link-home) + (plist-get info :publishing-directory))) + (image (url-encode-url (plist-get info :rss-image-url))) + (ifile (plist-get info :input-file)) + (publink + (or (plist-get info :rss-feed-url) + (concat (file-name-as-directory blogurl) + (file-name-nondirectory + (file-name-sans-extension ifile)) + "." rssext)))) + (format + "\n<title>%s</title> +<atom:link href=\"%s\" rel=\"self\" type=\"application/rss+xml\" /> +<link>%s</link> +<description><![CDATA[%s]]></description> +<language>%s</language> +<pubDate>%s</pubDate> +<lastBuildDate>%s</lastBuildDate> +<generator>%s</generator> +<webMaster>%s (%s)</webMaster> +<image> +<url>%s</url> +<title>%s</title> +<link>%s</link> +</image> +" + title publink blogurl description lang date date + (concat (format "Emacs %d.%d" + emacs-major-version + emacs-minor-version) + " Org-mode " (org-version)) + email author image title blogurl))) + +(defun org-rss-section (section contents info) + "Transcode SECTION element into RSS format. +CONTENTS is the section contents. INFO is a plist used as +a communication channel." + contents) + +(defun org-rss-timestamp (timestamp contents info) + "Transcode a TIMESTAMP object from Org to RSS. +CONTENTS is nil. INFO is a plist holding contextual +information." + (org-html-encode-plain-text + (org-timestamp-translate timestamp))) + +(defun org-rss-plain-text (contents info) + "Convert plain text into RSS encoded text." + (let (output) + (setq output (org-html-encode-plain-text contents) + output (org-export-activate-smart-quotes + output :html info)))) + +;;; Filters + +(defun org-rss-final-function (contents backend info) + "Prettify the RSS output." + (with-temp-buffer + (xml-mode) + (insert contents) + (indent-region (point-min) (point-max)) + (buffer-substring-no-properties (point-min) (point-max)))) + +;;; Miscellaneous + +(defun org-rss-add-pubdate-property () + "Set the PUBDATE property for top-level headlines." + (let (msg) + (org-map-entries + (lambda () + (let* ((entry (org-element-at-point)) + (level (org-element-property :level entry))) + (when (= level 1) + (unless (org-entry-get (point) "PUBDATE") + (setq msg t) + (org-set-property + "PUBDATE" (format-time-string + (cdr org-time-stamp-formats))))))) + nil nil 'comment 'archive) + (when msg + (message "Property PUBDATE added to top-level entries in %s" + (buffer-file-name)) + (sit-for 2)))) + +(provide 'ox-rss) + +;;; ox-rss.el ends here diff --git a/contrib/lisp/ox-s5.el b/contrib/lisp/ox-s5.el new file mode 100644 index 0000000..8f95010 --- /dev/null +++ b/contrib/lisp/ox-s5.el @@ -0,0 +1,432 @@ +;;; ox-s5.el --- S5 Presentation Back-End for Org Export Engine + +;; Copyright (C) 2011-2014 Rick Frankel + +;; Author: Rick Frankel <emacs at rickster dot com> +;; Keywords: outlines, hypermedia, S5, wp + +;; This file is not part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This library implements an S5 Presentation back-end for the Org +;; generic exporter. + +;; Installation +;; ------------ +;; Get the s5 scripts from +;; http://meyerweb.com/eric/tools/s5/ +;; (Note that the default s5 version is set for using the alpha, 1.2a2. +;; Copy the ui dir to somewhere reachable from your published presentation +;; The default (`org-s5-ui-url') is set to "ui" (e.g., in the +;; same directory as the html file). + +;; Usage +;; ----- +;; Follow the general instructions at the above website. To generate +;; incremental builds, you can set the HTML_CONTAINER_CLASS on an +;; object to "incremental" to make it build. If you want an outline to +;; build, set the :INCREMENTAL property on the parent headline. + +;; To test it, run: +;; +;; M-x org-s5-export-as-html +;; +;; in an Org mode buffer. See ox.el and ox-html.el for more details +;; on how this exporter works. + +;; TODOs +;; ------ +;; The title page is formatted using format-spec. This is error prone +;; when details are missing and may insert empty tags, like <h2></h2>, +;; for missing values. + +(require 'ox-html) +(eval-when-compile (require 'cl)) + +(org-export-define-derived-backend 's5 'html + :menu-entry + '(?s "Export to S5 HTML Presentation" + ((?H "To temporary buffer" org-s5-export-as-html) + (?h "To file" org-s5-export-to-html) + (?o "To file and open" + (lambda (a s v b) + (if a (org-s5-export-to-html t s v b) + (org-open-file (org-s5-export-to-html nil s v b))))))) + :options-alist + '((:html-link-home "HTML_LINK_HOME" nil nil) + (:html-link-up "HTML_LINK_UP" nil nil) + (:s5-postamble "S5_POSTAMBLE" nil org-s5-postamble newline) + (:s5-preamble "S5_PREAMBLE" nil org-s5-preamble newline) + (:html-head-include-default-style "HTML_INCLUDE_DEFAULT_STYLE" nil nil) + (:html-head-include-scripts "HTML_INCLUDE_SCRIPTS" nil nil) + (:s5-version "S5_VERSION" nil org-s5-version) + (:s5-theme-file "S5_THEME_FILE" nil org-s5-theme-file) + (:s5-ui-url "S5_UI_URL" nil org-s5-ui-url) + (:s5-default-view "S5_DEFAULT_VIEW" nil org-s5-default-view) + (:s5-control-visibility "S5_CONTROL_VISIBILITY" nil + org-s5-control-visibility)) + :translate-alist + '((headline . org-s5-headline) + (plain-list . org-s5-plain-list) + (inner-template . org-s5-inner-template) + (template . org-s5-template))) + +(defgroup org-export-s5 nil + "Options for exporting Org mode files to S5 HTML Presentations." + :tag "Org Export S5" + :group 'org-export-html) + +(defcustom org-s5-version "1.2a2" + "Version of s5 being used (for version metadata.) Defaults to +s5 v2 alpha 2. +Can be overridden with S5_VERSION." + :group 'org-export-s5 + :type 'string) + +(defcustom org-s5-theme-file nil +"Url to S5 theme (slides.css) file. Can be overriden with the +S5_THEME_FILE property. If nil, defaults to +`org-s5-ui-url'/default/slides.css. If it starts with anything but +\"http\" or \"/\", it is used as-is. Otherwise the link in generated +relative to `org-s5-ui-url'. +The links for all other required stylesheets and scripts will be +generated relative to `org-s5-ui-url'/default." + :group 'org-export-s5 + :type 'string) + +(defcustom org-s5-ui-url "ui" + "Base url to directory containing S5 \"default\" subdirectory +and the \"s5-notes.html\" file. +Can be overriden with the S5_UI_URL property." + :group 'org-export-s5 + :type 'string) + +(defcustom org-s5-default-view 'slideshow + "Setting for \"defaultView\" meta info." + :group 'org-export-s5 + :type '(choice (const slideshow) (const outline))) + +(defcustom org-s5-control-visibility 'hidden + "Setting for \"controlVis\" meta info." + :group 'org-export-s5 + :type '(choice (const hidden) (const visibile))) + +(defvar org-s5--divs + '((preamble "div" "header") + (content "div" "content") + (postamble "div" "footer")) + "Alist of the three section elements for HTML export. +The car of each entry is one of 'preamble, 'content or 'postamble. +The cdrs of each entry are the ELEMENT_TYPE and ID for each +section of the exported document. + +If you set `org-html-container-element' to \"li\", \"ol\" will be +uses as the content ELEMENT_TYPE, generating an XOXO format +slideshow. + +Note that changing the preamble or postamble will break the +core S5 stylesheets.") + +(defcustom org-s5-postamble "<h1>%a - %t</h1>" + "Preamble inserted into the S5 layout section. +When set to a string, use this string as the postamble. + +When set to a function, apply this function and insert the +returned string. The function takes the property list of export +options as its only argument. + +Setting the S5_POSTAMBLE option -- or the :s5-postamble in publishing +projects -- will take precedence over this variable. + +Note that the default css styling will break if this is set to nil +or an empty string." + :group 'org-export-s5 + :type '(choice (const :tag "No postamble" " ") + (string :tag "Custom formatting string") + (function :tag "Function (must return a string)"))) + +(defcustom org-s5-preamble " " + "Peamble inserted into the S5 layout section. + +When set to a string, use this string as the preamble. + +When set to a function, apply this function and insert the +returned string. The function takes the property list of export +options as its only argument. + +Setting S5_PREAMBLE option -- or the :s5-preamble in publishing +projects -- will take precedence over this variable. + +Note that the default css styling will break if this is set to nil +or an empty string." + :group 'org-export-s5 + :type '(choice (const :tag "No preamble" " ") + (string :tag "Custom formatting string") + (function :tag "Function (must return a string)"))) + +(defcustom org-s5-title-slide-template + "<h1>%t</h1> +<h2>%s</h2> +<h2>%a</h2> +<h3>%e</h3> +<h4>%d</h4>" + "Format template to specify title page section. +See `org-html-postamble-format' for the valid elements which +can be included. + +It will be wrapped in the element defined in the :html-container +property, and defaults to the value of `org-html-container-element', +and have the id \"title-slide\"." + :group 'org-export-s5 + :type 'string) + +(defun org-s5--format-toc-headline (headline info) + "Return an appropriate table of contents entry for HEADLINE. +Note that (currently) the S5 exporter does not support deep links, +so the table of contents is not \"active\". +INFO is a plist used as a communication channel." + (let* ((headline-number (org-export-get-headline-number headline info)) + (section-number + (and (not (org-export-low-level-p headline info)) + (org-export-numbered-headline-p headline info) + (concat (mapconcat 'number-to-string headline-number ".") ". "))) + (tags (and (eq (plist-get info :with-tags) t) + (org-export-get-tags headline info)))) + (concat section-number + (org-export-data + (org-export-get-alt-title headline info) info) + (and tags " ") (org-html--tags tags info)))) + +(defun org-s5-toc (depth info) + (let* ((headlines (org-export-collect-headlines info depth)) + (toc-entries + (mapcar (lambda (headline) + (cons (org-s5--format-toc-headline headline info) + (org-export-get-relative-level headline info))) + (org-export-collect-headlines info depth)))) + (when toc-entries + (concat + (format "<%s id='table-of-contents' class='slide'>\n" + (plist-get info :html-container)) + (format "<h1>%s</h1>\n" + (org-html--translate "Table of Contents" info)) + "<div id=\"text-table-of-contents\">" + (org-html--toc-text toc-entries) + "</div>\n" + (format "</%s>\n" (plist-get info :html-container)))))) + +(defun org-s5--build-head (info) + (let* ((dir (plist-get info :s5-ui-url)) + (theme (or (plist-get info :s5-theme-file) "default/slides.css"))) + (mapconcat + 'identity + (list + "<!-- style sheet links -->" + (mapconcat + (lambda (list) + (format + (concat + "<link rel='stylesheet' href='%s/default/%s' type='text/css'" + " media='%s' id='%s' />") + dir (nth 0 list) (nth 1 list) (nth 2 list))) + (list + '("outline.css" "screen" "outlineStyle") + '("print.css" "print" "slidePrint") + '("opera.css" "projection" "operaFix")) "\n") + (format (concat + "<link rel='stylesheet' href='%s' type='text/css'" + " media='screen' id='slideProj' />") + (if (string-match-p "^\\(http\\|/\\)" theme) theme + (concat dir "/" theme))) + "<!-- S5 JS -->" + (concat + "<script src='" dir + "/default/slides.js' type='text/javascript'></script>")) "\n"))) + +(defun org-s5--build-meta-info (info) + (concat + (org-html--build-meta-info info) + (format "<meta name=\"version\" content=\"S5 %s\" />\n" + (plist-get info :s5-version)) + (format "<meta name='defaultView' content='%s' />\n" + (plist-get info :s5-default-view)) + (format "<meta name='controlVis' content='%s' />" + (plist-get info :s5-control-visibility)))) + +(defun org-s5-headline (headline contents info) + (let ((org-html-toplevel-hlevel 1) + (class (or (org-element-property :HTML_CONTAINER_CLASS headline) "")) + (level (org-export-get-relative-level headline info))) + (when (and (= 1 level) (not (string-match-p "\\<slide\\>" class))) + (org-element-put-property headline :HTML_CONTAINER_CLASS (concat class " slide"))) + (org-html-headline headline contents info))) + +(defun org-s5-plain-list (plain-list contents info) + "Transcode a PLAIN-LIST element from Org to HTML. +CONTENTS is the contents of the list. INFO is a plist holding +contextual information. +If a containing headline has the property :INCREMENTAL, +then the \"incremental\" class will be added to the to the list, +which will make the list into a \"build\"." + (let* ((type (org-element-property :type plain-list)) + (tag (case type + (ordered "ol") + (unordered "ul") + (descriptive "dl")))) + (format "%s\n%s%s" + (format + "<%s class='org-%s%s'>" tag tag + (if (org-export-get-node-property :INCREMENTAL plain-list t) + " incremental" "")) + contents (org-html-end-plain-list type)))) + +(defun org-s5-inner-template (contents info) + "Return body of document string after HTML conversion. +CONTENTS is the transcoded contents string. INFO is a plist +holding export options." + (concat contents "\n")) + +(defun org-s5-template (contents info) + "Return complete document string after HTML conversion. +CONTENTS is the transcoded contents string. INFO is a plist +holding export options." + (let ((info (plist-put + (plist-put + (plist-put info :html-preamble (plist-get info :s5-preamble)) + :html-postamble + (plist-get info :s5-postamble)) + :html-divs + (if (equal "li" (plist-get info :html-container)) + (cons '(content "ol" "content") org-s5--divs) + org-s5--divs)))) + (mapconcat + 'identity + (list + (org-html-doctype info) + (format "<html xmlns=\"http://www.w3.org/1999/xhtml\" lang=\"%s\" xml:lang=\"%s\">" + (plist-get info :language) (plist-get info :language)) + "<head>" + (org-s5--build-meta-info info) + (org-s5--build-head info) + (org-html--build-head info) + (org-html--build-mathjax-config info) + "</head>" + "<body>" + "<div class=\"layout\">" + "<div id=\"controls\"><!-- no edit --></div>" + "<div id=\"currentSlide\"><!-- no edit --></div>" + (org-html--build-pre/postamble 'preamble info) + (org-html--build-pre/postamble 'postamble info) + "</div>" + (format "<%s id=\"%s\" class=\"presentation\">" + (nth 1 (assq 'content org-html-divs)) + (nth 2 (assq 'content org-html-divs))) + ;; title page + (format "<%s id='title-slide' class='slide'>" + (plist-get info :html-container)) + (format-spec org-s5-title-slide-template (org-html-format-spec info)) + (format "</%s>" (plist-get info :html-container)) + ;; table of contents. + (let ((depth (plist-get info :with-toc))) + (when depth (org-s5-toc depth info))) + contents + (format "</%s>" (nth 1 (assq 'content org-html-divs))) + "</body>" + "</html>\n") "\n"))) + +(defun org-s5-export-as-html + (&optional async subtreep visible-only body-only ext-plist) + "Export current buffer to an HTML buffer. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +A non-nil optional argument ASYNC means the process should happen +asynchronously. The resulting buffer should be accessible +through the `org-export-stack' interface. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only write code +between \"<body>\" and \"</body>\" tags. + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +Export is done in a buffer named \"*Org S5 Export*\", which +will be displayed when `org-export-show-temporary-export-buffer' +is non-nil." + (interactive) + (org-export-to-buffer 's5 "*Org S5 Export*" + async subtreep visible-only body-only ext-plist (lambda () (nxml-mode)))) + +(defun org-s5-export-to-html + (&optional async subtreep visible-only body-only ext-plist) + "Export current buffer to a S5 HTML file. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +A non-nil optional argument ASYNC means the process should happen +asynchronously. The resulting file should be accessible through +the `org-export-stack' interface. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only write code +between \"<body>\" and \"</body>\" tags. + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +Return output file's name." + (interactive) + (let* ((extension (concat "." org-html-extension)) + (file (org-export-output-file-name extension subtreep)) + (org-export-coding-system org-html-coding-system)) + (org-export-to-file 's5 file + async subtreep visible-only body-only ext-plist))) + +(defun org-s5-publish-to-html (plist filename pub-dir) + "Publish an org file to S5 HTML Presentation. + +FILENAME is the filename of the Org file to be published. PLIST +is the property list for the given project. PUB-DIR is the +publishing directory. + +Return output file name." + (org-publish-org-to 's5 filename ".html" plist pub-dir)) + +(provide 'ox-s5) + +;;; ox-s5.el ends here diff --git a/contrib/lisp/ox-taskjuggler.el b/contrib/lisp/ox-taskjuggler.el new file mode 100644 index 0000000..d856878 --- /dev/null +++ b/contrib/lisp/ox-taskjuggler.el @@ -0,0 +1,1038 @@ +;;; ox-taskjuggler.el --- TaskJuggler Back-End for Org Export Engine +;; +;; Copyright (C) 2007-2017 Free Software Foundation, Inc. +;; +;; Emacs Lisp Archive Entry +;; Filename: ox-taskjuggler.el +;; Author: Christian Egli +;; Nicolas Goaziou <n dot goaziou at gmail dot com> +;; Maintainer: Christian Egli +;; Keywords: org, taskjuggler, project planning +;; Description: Converts an Org mode buffer into a TaskJuggler project plan + +;; This file is not part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This library implements a TaskJuggler exporter for Org mode. +;; TaskJuggler is a project planing tool that uses a text format to +;; define projects, tasks and resources, so it is a natural fit for +;; Org mode. It can produce all sorts of reports for tasks or +;; resources in either HTML, CSV or PDF. TaskJuggler is implemented +;; in Ruby and should therefore run on any platform. +;; +;; The exporter does not export all the nodes of a document or +;; strictly follow the order of the nodes in the document. +;; +;; Instead the TaskJuggler exporter looks for a tree that defines the +;; tasks and a optionally tree that defines the resources for this +;; project. It then creates a TaskJuggler file based on these trees +;; and the attributes defined in all the nodes. +;; +;; * Installation +;; +;; Put this file into your load-path and the following line into your +;; ~/.emacs: +;; +;; (add-to-list 'org-export-backends 'taskjuggler) +;; +;; or customize `org-export-backends' variable. +;; +;; The interactive functions are the following: +;; +;; M-x `org-taskjuggler-export' +;; M-x `org-taskjuggler-export-and-open' +;; +;; * Tasks +;; +;; Let's illustrate the usage with a small example. Create your tasks +;; as you usually do with org-mode. Assign efforts to each task using +;; properties (it's easiest to do this in the column view). You +;; should end up with something similar to the example by Peter Jones +;; in: +;; +;; http://www.devalot.com/assets/articles/2008/07/project-planning/project-planning.org. +;; +;; Now mark the top node of your tasks with a tag named +;; "taskjuggler_project" (or whatever you customized +;; `org-taskjuggler-project-tag' to). You are now ready to export the +;; project plan with `org-taskjuggler-export-and-open' which will +;; export the project plan and open a Gantt chart in TaskJugglerUI. +;; +;; * Resources +;; +;; Next you can define resources and assign those to work on specific +;; tasks. You can group your resources hierarchically. Tag the top +;; node of the resources with "taskjuggler_resource" (or whatever you +;; customized `org-taskjuggler-resource-tag' to). You can optionally +;; assign an identifier (named "resource_id") to the resources (using +;; the standard org properties commands) or you can let the exporter +;; generate identifiers automatically (the exporter picks the first +;; word of the headline as the identifier as long as it is unique, see +;; the documentation of `org-taskjuggler--build-unique-id'). Using that +;; identifier you can then allocate resources to tasks. This is again +;; done with the "allocate" property on the tasks. Do this in column +;; view or when on the task type +;; +;; C-c C-x p allocate RET <resource_id> RET +;; +;; Once the allocations are done you can again export to TaskJuggler +;; and check in the Resource Allocation Graph which person is working +;; on what task at what time. +;; +;; * Export of properties +;; +;; The exporter also takes TODO state information into consideration, +;; i.e. if a task is marked as done it will have the corresponding +;; attribute in TaskJuggler ("complete 100"). Also it will export any +;; property on a task resource or resource node which is known to +;; TaskJuggler, such as limits, vacation, shift, booking, efficiency, +;; journalentry, rate for resources or account, start, note, duration, +;; end, journalentry, milestone, reference, responsible, scheduling, +;; etc for tasks. +;; +;; * Dependencies +;; +;; The exporter will handle dependencies that are defined in the tasks +;; either with the ORDERED attribute (see TODO dependencies in the Org +;; mode manual) or with the BLOCKER attribute (see org-depend.el) or +;; alternatively with a depends attribute. Both the BLOCKER and the +;; depends attribute can be either "previous-sibling" or a reference +;; to an identifier (named "task_id") which is defined for another +;; task in the project. BLOCKER and the depends attribute can define +;; multiple dependencies separated by either space or comma. You can +;; also specify optional attributes on the dependency by simply +;; appending it. The following examples should illustrate this: +;; +;; * Training material +;; :PROPERTIES: +;; :task_id: training_material +;; :ORDERED: t +;; :END: +;; ** Markup Guidelines +;; :PROPERTIES: +;; :Effort: 2d +;; :END: +;; ** Workflow Guidelines +;; :PROPERTIES: +;; :Effort: 2d +;; :END: +;; * Presentation +;; :PROPERTIES: +;; :Effort: 2d +;; :BLOCKER: training_material { gapduration 1d } some_other_task +;; :END: +;; +;;;; * TODO +;; - Look at org-file-properties, org-global-properties and +;; org-global-properties-fixed +;; - What about property inheritance and org-property-inherit-p? +;; - Use TYPE_TODO as an way to assign resources +;; - Add support for org-export-with-planning +;; +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'ox) + + + +;;; User Variables + +(defgroup org-export-taskjuggler nil + "Options specific for TaskJuggler export back-end." + :tag "Org Export TaskJuggler" + :group 'org-export) + +(defcustom org-taskjuggler-extension ".tjp" + "Extension of TaskJuggler files." + :group 'org-export-taskjuggler + :type 'string) + +(defcustom org-taskjuggler-project-tag "taskjuggler_project" + "Tag marking project's tasks. +This tag is used to find the tree containing all the tasks for +the project." + :group 'org-export-taskjuggler + :type 'string) + +(defcustom org-taskjuggler-resource-tag "taskjuggler_resource" + "Tag marking project's resources. +This tag is used to find the tree containing all the resources +for the project." + :group 'org-export-taskjuggler + :type 'string) + +(defcustom org-taskjuggler-report-tag "taskjuggler_report" + "Tag marking project's reports. +This tag is used to find the tree containing all the reports for +the project." + :group 'org-export-taskjuggler + :type 'string) + +(defcustom org-taskjuggler-target-version 3.0 + "Which version of TaskJuggler the exporter is targeting. +By default a project plan is exported which conforms to version +3.x of TaskJuggler. For a project plan that is compatible with +versions of TaskJuggler older than 3.0 set this to 2.4. + +If you change this variable be sure to also change +`org-taskjuggler-default-reports' as the format of reports has +changed considerably between version 2.x and 3.x of TaskJuggler" + :group 'org-export-taskjuggler + :type 'number) + +(defcustom org-taskjuggler-default-project-version "1.0" + "Default version string for the project. +This value can also be set with the \":VERSION:\" property +associated to the headline defining the project." + :group 'org-export-taskjuggler + :type 'string) + +(defcustom org-taskjuggler-default-project-duration 280 + "Default project duration. +The value will be used if no start and end date have been defined +in the root node of the task tree, i.e. the tree that has been +marked with `org-taskjuggler-project-tag'" + :group 'org-export-taskjuggler + :type 'integer) + +(defcustom org-taskjuggler-default-reports + '("textreport report \"Plan\" { + formats html + header '== %title ==' + + center -8<- + [#Plan Plan] | [#Resource_Allocation Resource Allocation] + ---- + === Plan === + <[report id=\"plan\"]> + ---- + === Resource Allocation === + <[report id=\"resourceGraph\"]> + ->8- +} + +# A traditional Gantt chart with a project overview. +taskreport plan \"\" { + headline \"Project Plan\" + columns bsi, name, start, end, effort, chart + loadunit shortauto + hideresource 1 +} + +# A graph showing resource allocation. It identifies whether each +# resource is under- or over-allocated for. +resourcereport resourceGraph \"\" { + headline \"Resource Allocation Graph\" + columns no, name, effort, weekly + loadunit shortauto + hidetask ~(isleaf() & isleaf_()) + sorttasks plan.start.up +}") + "Default reports for the project. +These are sensible default reports to give a good out-of-the-box +result when exporting without defining any reports. \"%title\" +anywhere in the reports will be replaced with the document title. +If you want to define your own reports you can change them here +or simply define the default reports so that they include an +external report definition as follows: + +include reports.tji + +These default are made to work with tj3. If you are targeting +TaskJuggler 2.4 (see `org-taskjuggler-target-version') please +change these defaults to something like the following: + +taskreport \"Gantt Chart\" { + headline \"Project Gantt Chart\" + columns hierarchindex, name, start, end, effort, duration, completed, chart + timeformat \"%Y-%m-%d\" + hideresource 1 + loadunit shortauto +} + +resourcereport \"Resource Graph\" { + headline \"Resource Allocation Graph\" + columns no, name, utilization, freeload, chart + loadunit shortauto + sorttasks startup + hidetask ~isleaf() +}" + :group 'org-export-taskjuggler + :type '(repeat (string :tag "Report"))) + +(defcustom org-taskjuggler-default-global-header "" + "Default global header for the project. +This goes before project declaration, and might be useful for +early macros." + :group 'org-export-taskjuggler + :type '(string :tag "Preamble")) + +(defcustom org-taskjuggler-default-global-properties + "shift s40 \"Part time shift\" { + workinghours wed, thu, fri off +} +" + "Default global properties for the project. + +Here you typically define global properties such as shifts, +accounts, rates, vacation, macros and flags. Any property that +is allowed within the TaskJuggler file can be inserted. You +could for example include another TaskJuggler file. + +The global properties are inserted after the project declaration +but before any resource and task declarations." + :group 'org-export-taskjuggler + :type '(string :tag "Preamble")) + +(defcustom org-taskjuggler-valid-task-attributes + '(account start note duration endbuffer endcredit end + flags journalentry length limits maxend maxstart minend + minstart period reference responsible scheduling + startbuffer startcredit statusnote chargeset charge) + "Valid attributes for Taskjuggler tasks. +If one of these appears as a property for a headline, it will be +exported with the corresponding task. + +Note that multiline properties are not supported, so attributes +like note or journalentry have to be on a single line." + :group 'org-export-taskjuggler) + +(defcustom org-taskjuggler-valid-project-attributes + '(timingresolution timezone alertlevels currency currencyformat + dailyworkinghours extend includejournalentry now numberformat + outputdir scenario shorttimeformat timeformat trackingscenario + weekstartsmonday weekstartssunday workinghours + yearlyworkingdays) + "Valid attributes for Taskjuggler project. +If one of these appears as a property for a headline that is a +project definition, it will be exported with the corresponding +task. Attribute 'timingresolution' should be the first in the +list." + :group 'org-export-taskjuggler) + +(defcustom org-taskjuggler-valid-resource-attributes + '(limits vacation shift booking efficiency journalentry rate + workinghours flags) + "Valid attributes for Taskjuggler resources. +If one of these appears as a property for a headline, it will be +exported with the corresponding resource." + :group 'org-export-taskjuggler) + +(defcustom org-taskjuggler-valid-report-attributes + '(headline columns definitions timeformat hideresource hidetask + loadunit sorttasks formats period) + "Valid attributes for Taskjuggler reports. +If one of these appears as a property for a headline, it will be +exported with the corresponding report." + :group 'org-export-taskjuggler) + +(defcustom org-taskjuggler-process-command + "tj3 --silent --no-color --output-dir %o %f" + "Command to process a Taskjuggler file. +The command will be given to the shell as a command to process a +Taskjuggler file. \"%f\" in the command will be replaced by the +full file name, \"%o\" by the reports directory (see +`org-taskjuggler-reports-directory'). + +If you are targeting Taskjuggler 2.4 (see +`org-taskjuggler-target-version') this setting is ignored." + :group 'org-export-taskjuggler) + +(defcustom org-taskjuggler-reports-directory "reports" + "Default directory to generate the Taskjuggler reports in. +The command `org-taskjuggler-process-command' generates the +reports and associated files such as CSS inside this directory. + +If the directory is not an absolute path it is relative to the +directory of the exported file. The directory is created if it +doesn't exist. + +If you are targeting Taskjuggler 2.4 (see +`org-taskjuggler-target-version') this setting is ignored." + :group 'org-export-taskjuggler) + +(defcustom org-taskjuggler-keep-project-as-task t + "Non-nil keeps the project headline as an umbrella task for all tasks. +Setting this to nil will allow maintaining completely separated +task buckets, while still sharing the same resources pool." + :group 'org-export-taskjuggler + :type 'boolean) + + + +;;; Hooks + +(defvar org-taskjuggler-final-hook nil + "Hook run after a TaskJuggler files has been saved. +This hook is run with the name of the file as argument.") + + + +;;; Back-End Definition + +(org-export-define-backend 'taskjuggler + '((template . org-taskjuggler-project-plan)) + :menu-entry + '(?J "Export to TaskJuggler" + ((?j "As TJP file" (lambda (a s v b) (org-taskjuggler-export a s v))) + (?p "As TJP file and process" + (lambda (a s v b) + (if a (org-taskjuggler-export a s v) + (org-taskjuggler-export-and-process s v)))) + (?o "As TJP file, process and open" + (lambda (a s v b) + (if a (org-taskjuggler-export a s v) + (org-taskjuggler-export-process-and-open s v)))))) + ;; This property will be used to store unique ids in communication + ;; channel. Ids will be retrieved with `org-taskjuggler-get-id'. + :options-alist '((:taskjuggler-unique-ids nil nil nil))) + + + +;;; Unique IDs + +(defun org-taskjuggler-assign-task-ids (tasks info) + "Assign a unique ID to each task in TASKS. +TASKS is a list of headlines. INFO is a plist used as a +communication channel. Return value is an alist between +headlines and their associated ID. IDs are hierarchical, which +means they only need to be unique among the task siblings." + (let* (alist + build-id ; For byte-compiler. + (build-id + (lambda (tasks local-ids) + (org-element-map tasks 'headline + (lambda (task) + (let ((id (org-taskjuggler--build-unique-id task local-ids))) + (push id local-ids) + (push (cons task id) alist) + (funcall build-id (org-element-contents task) nil))) + info nil 'headline)))) + (funcall build-id tasks nil) + alist)) + +(defun org-taskjuggler-assign-resource-ids (resources info) + "Assign a unique ID to each resource within RESOURCES. +RESOURCES is a list of headlines. INFO is a plist used as a +communication channel. Return value is an alist between +headlines and their associated ID." + (let (ids) + (org-element-map resources 'headline + (lambda (resource) + (let ((id (org-taskjuggler--build-unique-id resource ids))) + (push id ids) + (cons resource id))) + info))) + + + +;;; Accessors + +(defun org-taskjuggler-get-project (info) + "Return project in parse tree. +INFO is a plist used as a communication channel. First headline +in buffer with `org-taskjuggler-project-tag' defines the project. +If no such task is defined, pick the first headline in buffer. +If there is no headline at all, return nil." + (let ((tree (plist-get info :parse-tree))) + (or (org-element-map tree 'headline + (lambda (hl) + (and (member org-taskjuggler-project-tag + (org-export-get-tags hl info)) + hl)) + info t) + (org-element-map tree 'headline 'identity info t)))) + +(defun org-taskjuggler-get-id (item info) + "Return id for task or resource ITEM. +ITEM is a headline. INFO is a plist used as a communication +channel. Return value is a string." + (cdr (assq item (plist-get info :taskjuggler-unique-ids)))) + +(defun org-taskjuggler-get-name (item) + "Return name for task or resource ITEM. +ITEM is a headline. Return value is a string." + ;; Quote double quotes in name. + (replace-regexp-in-string + "\"" "\\\"" (org-element-property :raw-value item) t t)) + +(defun org-taskjuggler-get-start (item) + "Return start date for task or resource ITEM. +ITEM is a headline. Return value is a string or nil if ITEM +doesn't have any start date defined." + (let ((scheduled (org-element-property :scheduled item))) + (or + (and scheduled (org-timestamp-format scheduled "%Y-%02m-%02d")) + (and (memq 'start org-taskjuggler-valid-task-attributes) + (org-element-property :START item))))) + +(defun org-taskjuggler-get-end (item) + "Return end date for task or resource ITEM. +ITEM is a headline. Return value is a string or nil if ITEM +doesn't have any end date defined." + (let ((deadline (org-element-property :deadline item))) + (and deadline (org-timestamp-format deadline "%Y-%02m-%02d")))) + + + +;;; Internal Functions + +(defun org-taskjuggler--indent-string (s) + "Indent string S by 2 spaces. +Return new string. If S is the empty string, return it." + (if (equal "" s) s (replace-regexp-in-string "^ *\\S-" " \\&" s))) + +(defun org-taskjuggler--build-attributes (item attributes) + "Return attributes string for ITEM. +ITEM is a project, task, resource or report headline. ATTRIBUTES +is a list of symbols representing valid attributes for ITEM." + (mapconcat + (lambda (attribute) + (let ((value (org-element-property + (intern (upcase (format ":%s" attribute))) + item))) + (and value (format "%s %s\n" attribute value)))) + (remq nil attributes) "")) + +(defun org-taskjuggler--build-unique-id (item unique-ids) + "Return a unique id for a given task or a resource. +ITEM is an `headline' type element representing the task or +resource. Its id is derived from its name and made unique +against UNIQUE-IDS. If the (downcased) first token of the +headline is not unique try to add more (downcased) tokens of the +headline or finally add more underscore characters (\"_\")." + (let ((id (org-string-nw-p (org-element-property :TASK_ID item)))) + ;; If an id is specified, use it, as long as it's unique. + (if (and id (not (member id unique-ids))) id + (let* ((parts (org-split-string (org-element-property :raw-value item))) + (id (org-taskjuggler--clean-id (downcase (pop parts))))) + ;; Try to add more parts of the headline to make it unique. + (while (and (car parts) (member id unique-ids)) + (setq id (concat id "_" + (org-taskjuggler--clean-id (downcase (pop parts)))))) + ;; If it's still not unique, add "_". + (while (member id unique-ids) + (setq id (concat id "_"))) + id)))) + +(defun org-taskjuggler--clean-id (id) + "Clean and return ID to make it acceptable for TaskJuggler. +ID is a string." + ;; Replace non-ascii by "_". + (replace-regexp-in-string + "[^a-zA-Z0-9_]" "_" + ;; Make sure id doesn't start with a number. + (replace-regexp-in-string "^\\([0-9]\\)" "_\\1" id))) + + + +;;; Dependencies + +(defun org-taskjuggler-resolve-dependencies (task info) + "Return a list of all tasks TASK depends on. +TASK is a headline. INFO is a plist used as a communication +channel." + (let ((deps-ids + ;; Get all dependencies specified in BLOCKER and DEPENDS task + ;; properties. Clean options from them. + (let ((deps (concat (org-element-property :BLOCKER task) + (org-element-property :DEPENDS task)))) + (and deps + (org-split-string (replace-regexp-in-string "{.*?}" "" deps) + "[ ,]* +")))) + depends) + (when deps-ids + ;; Find tasks with :task_id: property matching id in DEPS-IDS. + ;; Add them to DEPENDS. + (let* ((project (org-taskjuggler-get-project info)) + (tasks (if org-taskjuggler-keep-project-as-task project + (org-element-contents project)))) + (setq depends + (org-element-map tasks 'headline + (lambda (task) + (let ((task-id (or (org-element-property :TASK_ID task) + (org-element-property :ID task)))) + (and task-id (member task-id deps-ids) task))) + info))) + ;; Check BLOCKER and DEPENDS properties. If "previous-sibling" + ;; belongs to DEPS-ID, add it to DEPENDS. + (when (and (member-ignore-case "previous-sibling" deps-ids) + (not (org-export-first-sibling-p task info))) + (let ((prev (org-export-get-previous-element task info))) + (and (not (memq prev depends)) (push prev depends))))) + ;; Check ORDERED status of parent. + (let ((parent (org-export-get-parent task))) + (when (and parent + (org-element-property :ORDERED parent) + (not (org-export-first-sibling-p task info))) + (push (org-export-get-previous-element task info) depends))) + ;; Return dependencies. + depends)) + +(defun org-taskjuggler-format-dependencies (dependencies task info) + "Format DEPENDENCIES to match TaskJuggler syntax. +DEPENDENCIES is list of dependencies for TASK, as returned by +`org-taskjuggler-resolve-depedencies'. TASK is a headline. +INFO is a plist used as a communication channel. Return value +doesn't include leading \"depends\"." + (let* ((dep-str (concat (org-element-property :BLOCKER task) + " " + (org-element-property :DEPENDS task))) + (get-path + (lambda (dep) + ;; Return path to DEP relatively to TASK. + (let ((parent (org-export-get-parent task)) + (exclamations 1) + (option + (let ((id (org-element-property :TASK_ID dep))) + (and id + (string-match (concat id " +\\({.*?}\\)") dep-str) + (match-string-no-properties 1 dep-str)))) + path) + ;; Compute number of exclamation marks by looking for the + ;; common ancestor between TASK and DEP. + (while (not (org-element-map parent 'headline + (lambda (hl) (eq hl dep)))) + (incf exclamations) + (setq parent (org-export-get-parent parent))) + ;; Build path from DEP to PARENT. + (while (not (eq parent dep)) + (push (org-taskjuggler-get-id dep info) path) + (setq dep (org-export-get-parent dep))) + ;; Return full path. Add dependency options, if any. + (concat (make-string exclamations ?!) + (mapconcat 'identity path ".") + (and option (concat " " option))))))) + ;; Return dependencies string, without the leading "depends". + (mapconcat (lambda (dep) (funcall get-path dep)) dependencies ", "))) + + + +;;; Translator Functions + +(defun org-taskjuggler-project-plan (contents info) + "Build TaskJuggler project plan. +CONTENTS is ignored. INFO is a plist holding export options. +Return complete project plan as a string in TaskJuggler syntax." + (let* ((tree (plist-get info :parse-tree)) + (project (or (org-taskjuggler-get-project info) + (error "No project specified")))) + (concat + ;; 1. Insert header. + (org-element-normalize-string org-taskjuggler-default-global-header) + ;; 2. Insert project. + (org-taskjuggler--build-project project info) + ;; 3. Insert global properties. + (org-element-normalize-string org-taskjuggler-default-global-properties) + ;; 4. Insert resources. Provide a default one if none is + ;; specified. + (let ((main-resources + ;; Collect contents from various trees marked with + ;; `org-taskjuggler-resource-tag'. Only gather top level + ;; resources. + (apply 'append + (org-element-map tree 'headline + (lambda (hl) + (and (member org-taskjuggler-resource-tag + (org-export-get-tags hl info)) + (org-element-map (org-element-contents hl) 'headline + 'identity info nil 'headline))) + info nil 'headline)))) + ;; Assign a unique ID to each resource. Store it under + ;; `:taskjuggler-unique-ids' property in INFO. + (setq info + (plist-put info :taskjuggler-unique-ids + (org-taskjuggler-assign-resource-ids + main-resources info))) + (concat + (if main-resources + (mapconcat + (lambda (resource) (org-taskjuggler--build-resource resource info)) + main-resources "") + (format "resource %s \"%s\" {\n}\n" (user-login-name) user-full-name)) + ;; 5. Insert tasks. + (let ((main-tasks + ;; If `org-taskjuggler-keep-project-as-task' is + ;; non-nil, there is only one task. Otherwise, every + ;; direct children of PROJECT is a top level task. + (if org-taskjuggler-keep-project-as-task (list project) + (or (org-element-map (org-element-contents project) 'headline + 'identity info nil 'headline) + (error "No task specified"))))) + ;; Assign a unique ID to each task. Add it to + ;; `:taskjuggler-unique-ids' property in INFO. + (setq info + (plist-put info :taskjuggler-unique-ids + (append + (org-taskjuggler-assign-task-ids main-tasks info) + (plist-get info :taskjuggler-unique-ids)))) + ;; If no resource is allocated among tasks, allocate one to + ;; the first task. + (unless (org-element-map main-tasks 'headline + (lambda (task) (org-element-property :ALLOCATE task)) + info t) + (org-element-put-property + (car main-tasks) :ALLOCATE + (or (org-taskjuggler-get-id (car main-resources) info) + (user-login-name)))) + (mapconcat + (lambda (task) (org-taskjuggler--build-task task info)) + main-tasks "")) + ;; 6. Insert reports. If no report is defined, insert default + ;; reports. + (let ((main-reports + ;; Collect contents from various trees marked with + ;; `org-taskjuggler-report-tag'. Only gather top level + ;; reports. + (apply 'append + (org-element-map tree 'headline + (lambda (hl) + (and (member org-taskjuggler-report-tag + (org-export-get-tags hl info)) + (org-element-map (org-element-contents hl) + 'headline 'identity info nil 'headline))) + info nil 'headline)))) + (if main-reports + (mapconcat + (lambda (report) (org-taskjuggler--build-report report info)) + main-reports "") + ;; insert title in default reports + (let* ((title (org-export-data (plist-get info :title) info)) + (report-title (if (string= title "") + (org-taskjuggler-get-name project) + title))) + (mapconcat + 'org-element-normalize-string + (mapcar + (function + (lambda (report) + (replace-regexp-in-string "%title" report-title report t t))) + org-taskjuggler-default-reports) ""))))))))) + +(defun org-taskjuggler--build-project (project info) + "Return a project declaration. +PROJECT is a headline. INFO is a plist used as a communication +channel. If no start date is specified, start today. If no end +date is specified, end `org-taskjuggler-default-project-duration' +days from now." + (concat + ;; Opening project. + (format "project %s \"%s\" \"%s\" %s %s {\n" + (org-taskjuggler-get-id project info) + (org-taskjuggler-get-name project) + ;; Version is obtained through :TASKJUGGLER_VERSION: + ;; property or `org-taskjuggler-default-project-version'. + (or (org-element-property :VERSION project) + org-taskjuggler-default-project-version) + (or (org-taskjuggler-get-start project) + (format-time-string "%Y-%m-%d")) + (let ((end (org-taskjuggler-get-end project))) + (or (and end (format "- %s" end)) + (format "+%sd" + org-taskjuggler-default-project-duration)))) + ;; Add attributes. + (org-taskjuggler--indent-string + (org-taskjuggler--build-attributes + project org-taskjuggler-valid-project-attributes)) + ;; Closing project. + "}\n")) + +(defun org-taskjuggler--build-resource (resource info) + "Return a resource declaration. + +RESOURCE is a headline. INFO is a plist used as a communication +channel. + +All valid attributes from RESOURCE are inserted. If RESOURCE +defines a property \"resource_id\" it will be used as the id for +this resource. Otherwise it will use the ID property. If +neither is defined a unique id will be associated to it." + (concat + ;; Opening resource. + (format "resource %s \"%s\" {\n" + (org-taskjuggler--clean-id + (or (org-element-property :RESOURCE_ID resource) + (org-element-property :ID resource) + (org-taskjuggler-get-id resource info))) + (org-taskjuggler-get-name resource)) + ;; Add attributes. + (org-taskjuggler--indent-string + (org-taskjuggler--build-attributes + resource org-taskjuggler-valid-resource-attributes)) + ;; Add inner resources. + (org-taskjuggler--indent-string + (mapconcat + 'identity + (org-element-map (org-element-contents resource) 'headline + (lambda (hl) (org-taskjuggler--build-resource hl info)) + info nil 'headline) + "")) + ;; Closing resource. + "}\n")) + +(defun org-taskjuggler--build-report (report info) + "Return a report declaration. +REPORT is a headline. INFO is a plist used as a communication +channel." + (concat + ;; Opening report. + (format "%s \"%s\" {\n" + (or (org-element-property :REPORT_KIND report) "taskreport") + (org-taskjuggler-get-name report)) + ;; Add attributes. + (org-taskjuggler--indent-string + (org-taskjuggler--build-attributes + report org-taskjuggler-valid-report-attributes)) + ;; Add inner reports. + (org-taskjuggler--indent-string + (mapconcat + 'identity + (org-element-map (org-element-contents report) 'headline + (lambda (hl) (org-taskjuggler--build-report hl info)) + info nil 'headline) + "")) + ;; Closing report. + "}\n")) + +(defun org-taskjuggler--build-task (task info) + "Return a task declaration. + +TASK is a headline. INFO is a plist used as a communication +channel. + +All valid attributes from TASK are inserted. If TASK defines +a property \"task_id\" it will be used as the id for this task. +Otherwise it will use the ID property. If neither is defined +a unique id will be associated to it." + (let* ((allocate (org-element-property :ALLOCATE task)) + (complete + (if (eq (org-element-property :todo-type task) 'done) "100" + (org-element-property :COMPLETE task))) + (depends (org-taskjuggler-resolve-dependencies task info)) + (effort (let ((property + (intern (concat ":" (upcase org-effort-property))))) + (org-element-property property task))) + (milestone + (or (org-element-property :MILESTONE task) + (not (or (org-element-map (org-element-contents task) 'headline + 'identity info t) ; Has task any child? + effort + (org-element-property :LENGTH task) + (org-element-property :DURATION task) + (and (org-taskjuggler-get-start task) + (org-taskjuggler-get-end task)) + (org-element-property :PERIOD task))))) + (priority + (let ((pri (org-element-property :priority task))) + (and pri + (max 1 (/ (* 1000 (- org-lowest-priority pri)) + (- org-lowest-priority org-highest-priority))))))) + (concat + ;; Opening task. + (format "task %s \"%s\" {\n" + (org-taskjuggler-get-id task info) + (org-taskjuggler-get-name task)) + ;; Add default attributes. + (and depends + (format " depends %s\n" + (org-taskjuggler-format-dependencies depends task info))) + (and allocate + (format " purge %s\n allocate %s\n" + ;; Compatibility for previous TaskJuggler versions. + (if (>= org-taskjuggler-target-version 3.0) "allocate" + "allocations") + allocate)) + (and complete (format " complete %s\n" complete)) + (and effort + (format " effort %s\n" + (let* ((minutes (org-duration-string-to-minutes effort)) + (hours (/ minutes 60.0))) + (format "%.1fh" hours)))) + (and priority (format " priority %s\n" priority)) + (and milestone " milestone\n") + ;; Add other valid attributes. + (org-taskjuggler--indent-string + (org-taskjuggler--build-attributes + task org-taskjuggler-valid-task-attributes)) + ;; Add inner tasks. + (org-taskjuggler--indent-string + (mapconcat 'identity + (org-element-map (org-element-contents task) 'headline + (lambda (hl) (org-taskjuggler--build-task hl info)) + info nil 'headline) + "")) + ;; Closing task. + "}\n"))) + + + +;;; Interactive Functions + +;;;###autoload +(defun org-taskjuggler-export (&optional async subtreep visible-only) + "Export current buffer to a TaskJuggler file. + +The exporter looks for a tree with tag that matches +`org-taskjuggler-project-tag' and takes this as the tasks for +this project. The first node of this tree defines the project +properties such as project name and project period. + +If there is a tree with tag that matches +`org-taskjuggler-resource-tag' this tree is taken as resources +for the project. If no resources are specified, a default +resource is created and allocated to the project. + +Also the TaskJuggler project will be created with default reports +as defined in `org-taskjuggler-default-reports'. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +A non-nil optional argument ASYNC means the process should happen +asynchronously. The resulting file should be accessible through +the `org-export-stack' interface. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +Return output file's name." + (interactive) + (let ((outfile + (org-export-output-file-name org-taskjuggler-extension subtreep))) + (org-export-to-file 'taskjuggler outfile + async subtreep visible-only nil nil + (lambda (file) + (run-hook-with-args 'org-taskjuggler-final-hook file) nil)))) + +;;;###autoload +(defun org-taskjuggler-export-and-process (&optional subtreep visible-only) + "Export current buffer to a TaskJuggler file and process it. + +The exporter looks for a tree with tag that matches +`org-taskjuggler-project-tag' and takes this as the tasks for +this project. The first node of this tree defines the project +properties such as project name and project period. + +If there is a tree with tag that matches +`org-taskjuggler-resource-tag' this tree is taken as resources +for the project. If no resources are specified, a default +resource is created and allocated to the project. + +Also the TaskJuggler project will be created with default reports +as defined in `org-taskjuggler-default-reports'. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +Return a list of reports." + (interactive) + (let ((file (org-taskjuggler-export nil subtreep visible-only))) + (org-taskjuggler-compile file))) + +;;;###autoload +(defun org-taskjuggler-export-process-and-open (&optional subtreep visible-only) + "Export current buffer to a TaskJuggler file, process and open it. + +Export and process the file using +`org-taskjuggler-export-and-process' and open the generated +reports with a browser. + +If you are targeting TaskJuggler 2.4 (see +`org-taskjuggler-target-version') the processing and display of +the reports is done using the TaskJuggler GUI." + (interactive) + (if (< org-taskjuggler-target-version 3.0) + (let* ((process-name "TaskJugglerUI") + (command + (concat process-name " " + (org-taskjuggler-export nil subtreep visible-only)))) + (start-process-shell-command process-name nil command)) + (dolist (report (org-taskjuggler-export-and-process subtreep visible-only)) + (org-open-file report)))) + +(defun org-taskjuggler-compile (file) + "Compile a TaskJuggler file. + +FILE is the name of the file being compiled. Processing is done +through the command given in `org-taskjuggler-process-command'. + +Return a list of reports." + (let* ((full-name (file-truename file)) + (out-dir + (expand-file-name + org-taskjuggler-reports-directory (file-name-directory file))) + errors) + (message (format "Processing TaskJuggler file %s..." file)) + (save-window-excursion + (let ((outbuf (get-buffer-create "*Org Taskjuggler Output*"))) + (unless (file-directory-p out-dir) + (make-directory out-dir t)) + (with-current-buffer outbuf (erase-buffer)) + (shell-command + (replace-regexp-in-string + "%f" (shell-quote-argument full-name) + (replace-regexp-in-string + "%o" (shell-quote-argument out-dir) + org-taskjuggler-process-command t t) t t) outbuf) + ;; Collect standard errors from output buffer. + (setq errors (org-taskjuggler--collect-errors outbuf))) + (if (not errors) + (message "Process completed.") + (error (format "TaskJuggler failed with errors: %s" errors)))) + (file-expand-wildcards (format "%s/*.html" out-dir)))) + +(defun org-taskjuggler--collect-errors (buffer) + "Collect some kind of errors from \"tj3\" command output. + +BUFFER is the buffer containing output. + +Return collected error types as a string, or nil if there was +none." + (with-current-buffer buffer + (save-excursion + (goto-char (point-min)) + (let ((case-fold-search t) + (errors "")) + (while (re-search-forward "^.+:[0-9]+: \\(.*\\)$" nil t) + (setq errors (concat errors " " (match-string 1)))) + (and (org-string-nw-p errors) (org-trim errors)))))) + + +(provide 'ox-taskjuggler) + +;; Local variables: +;; sentence-end-double-space: t +;; End: + +;;; ox-taskjuggler.el ends here |