diff options
Diffstat (limited to '.emacs.d/org-7.4/contrib/lisp')
40 files changed, 13513 insertions, 0 deletions
diff --git a/.emacs.d/org-7.4/contrib/lisp/.DS_Store b/.emacs.d/org-7.4/contrib/lisp/.DS_Store Binary files differnew file mode 100644 index 0000000..5008ddf --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/.DS_Store diff --git a/.emacs.d/org-7.4/contrib/lisp/htmlize.el b/.emacs.d/org-7.4/contrib/lisp/htmlize.el new file mode 100644 index 0000000..5f4cb5b --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/htmlize.el @@ -0,0 +1,1769 @@ +;; htmlize.el -- Convert buffer text and decorations to HTML. + +;; Copyright (C) 1997,1998,1999,2000,2001,2002,2003,2005,2006,2009 Hrvoje Niksic + +;; Author: Hrvoje Niksic <hniksic@xemacs.org> +;; Keywords: hypermedia, extensions + +;; 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 this, 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 to other 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. + +;; I tried to make the package elisp-compatible with multiple Emacsen, +;; specifically aiming for XEmacs 19.14+ and GNU Emacs 19.34+. Please +;; let me know if it doesn't work on some of those, and I'll try to +;; fix it. I relied heavily on the presence of CL extensions, +;; especially for cross-emacs compatibility; please don't try to +;; remove that particular dependency. When byte-compiling under GNU +;; Emacs, you're likely to get some warnings; just ignore them. + +;; The latest version should be available at: +;; +;; <http://fly.srk.fer.hr/~hniksic/emacs/htmlize.el> +;; +;; 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 multitudes of people who have sent reports and +;; contributed comments, suggestions, and fixes. They include Ron +;; Gut, Bob Weiner, Toni Drabik, Peter Breton, 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 + (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) + (when (and (eq emacs-major-version 19) + (not (string-match "XEmacs" emacs-version))) + ;; Older versions of GNU Emacs fail to autoload cl-extra even when + ;; `cl' is loaded. + (load "cl-extra"))) + +(defconst htmlize-version "1.36") + +;; Incantations to make custom stuff work without customize, e.g. on +;; XEmacs 19.14 or GNU Emacs 19.34. +(eval-and-compile + (condition-case () + (require 'custom) + (error nil)) + (if (and (featurep 'custom) (fboundp 'custom-declare-variable)) + nil ; we've got what we needed + ;; No custom or obsolete custom, define surrogates. Define all + ;; three macros, so we don't hose another library that expects + ;; e.g. `defface' to work after (fboundp 'defcustom) succeeds. + (defmacro defgroup (&rest ignored) nil) + (defmacro defcustom (var value doc &rest ignored) + `(defvar ,var ,value ,doc)) + (defmacro defface (face value doc &rest stuff) + `(make-face ,face)))) + +(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-generate-hyperlinks t + "*Non-nil means generate the hyperlinks for URLs and mail addresses. +This is on by default; set it to nil if you don't want htmlize to +insert hyperlinks in the resulting HTML. (In which case you can still +do your own hyperlinkification from htmlize-after-hook.)" + :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. (Under Mule +that is done by ensuring the correct \"file coding system\" for the +buffer.) If you don't understand what that means, this option is +probably not for you." + :type '(choice (const :tag "Unset" nil) + string) + :group 'htmlize) + +(defcustom htmlize-convert-nonascii-to-entities (featurep 'mule) + "*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 \"©\". + +By default, entity conversion is turned on for Mule-enabled Emacsen and +turned off otherwise. This is because Mule knows the charset of +non-ASCII characters in the buffer. A non-Mule Emacs cannot tell +whether a character with code 0xA9 represents Latin 1 copyright symbol, +Latin 2 \"S with caron\", or something else altogether. Setting this to +t without Mule means asserting that 128-255 characters always mean Latin +1. + +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 `x-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)) + +(eval-and-compile + ;; save-current-buffer, with-current-buffer, and with-temp-buffer + ;; are not available in 19.34 and in older XEmacsen. Strictly + ;; speaking, we should stick to our own namespace and define and use + ;; htmlize-save-current-buffer, etc. But non-standard special forms + ;; are a pain because they're not properly fontified or indented and + ;; because they look weird and ugly. So I'll just go ahead and + ;; define the real ones if they're not available. If someone + ;; convinces me that this breaks something, I'll switch to the + ;; "htmlize-" namespace. + (unless (fboundp 'save-current-buffer) + (defmacro save-current-buffer (&rest forms) + `(let ((__scb_current (current-buffer))) + (unwind-protect + (progn ,@forms) + (set-buffer __scb_current))))) + (unless (fboundp 'with-current-buffer) + (defmacro with-current-buffer (buffer &rest forms) + `(save-current-buffer (set-buffer ,buffer) ,@forms))) + (unless (fboundp 'with-temp-buffer) + (defmacro with-temp-buffer (&rest forms) + (let ((temp-buffer (gensym "tb-"))) + `(let ((,temp-buffer + (get-buffer-create (generate-new-buffer-name " *temp*")))) + (unwind-protect + (with-current-buffer ,temp-buffer + ,@forms) + (and (buffer-live-p ,temp-buffer) + (kill-buffer ,temp-buffer)))))))) + +;; We need a function that efficiently finds the next change of a +;; property (usually `face'), preferably regardless of whether the +;; change occurred because of a text property or an extent/overlay. +;; As it turns out, it is not easy to do that compatibly. +;; +;; Under XEmacs, `next-single-property-change' does that. Under GNU +;; Emacs beginning with version 21, `next-single-char-property-change' +;; is available and does the same. GNU Emacs 20 had +;; `next-char-property-change', which we can use. GNU Emacs 19 didn't +;; provide any means for simultaneously examining overlays and text +;; properties, so when using Emacs 19.34, we punt and fall back to +;; `next-single-property-change', thus ignoring overlays altogether. + +(cond + (htmlize-running-xemacs + ;; XEmacs: good. + (defun htmlize-next-change (pos prop &optional limit) + (next-single-property-change pos prop nil (or limit (point-max))))) + ((fboundp 'next-single-char-property-change) + ;; GNU Emacs 21: good. + (defun htmlize-next-change (pos prop &optional limit) + (next-single-char-property-change pos prop nil limit))) + ((fboundp 'next-char-property-change) + ;; GNU Emacs 20: bad, but fixable. + (defun htmlize-next-change (pos prop &optional limit) + (let ((done nil) + (current-value (get-char-property pos prop)) + newpos next-value) + ;; Loop over positions returned by next-char-property-change + ;; until the value of PROP changes or we've hit EOB. + (while (not done) + (setq newpos (next-char-property-change pos limit) + next-value (get-char-property newpos prop)) + (cond ((eq newpos pos) + ;; Possibly at EOB? Whatever, just don't infloop. + (setq done t)) + ((eq next-value current-value) + ;; PROP hasn't changed -- keep looping. + ) + (t + (setq done t))) + (setq pos newpos)) + pos))) + (t + ;; GNU Emacs 19.34: hopeless, cannot properly support overlays. + (defun htmlize-next-change (pos prop &optional limit) + (unless limit + (setq limit (point-max))) + (let ((res (next-single-property-change pos prop))) + (if (or (null res) + (> res limit)) + limit + res))))) + +;;; 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 do. + ;(aref table ?\") """ + ) + table)) + +;; A cache of HTML representation of non-ASCII characters. Depending +;; on availability of `encode-char' and 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))) + ((and (fboundp 'encode-char) + ;; Must check if encode-char works for CHAR; + ;; it fails for Arabic and possibly elsewhere. + (encode-char char 'ucs)) + (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 ""))) + +(defconst htmlize-ellipsis "...") +(put-text-property 0 (length htmlize-ellipsis) 'htmlize-ellipsis t htmlize-ellipsis) + +(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 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)) + (if (not (listp buffer-invisibility-spec)) + ;; If buffer-invisibility-spec is not a list, then all + ;; characters with non-nil `invisible' property are visible. + (setq show (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) + (setq match (member* invisible buffer-invisibility-spec + :key (lambda (i) + (if (symbolp i) i (car i))))) + (setq match (block nil + (dolist (elem invisible) + (let ((m (member* + elem buffer-invisibility-spec + :key (lambda (i) + (if (symbolp i) i (car i)))))) + (when m (return m)))) + nil))) + (setq show (cond ((null match) t) + ((and (cdr-safe (car match)) + ;; Conflate successive ellipses. + (not (eq show htmlize-ellipsis))) + htmlize-ellipsis) + (t nil))))) + (cond ((eq show t) + (push (buffer-substring-no-properties pos next-change) visible-list)) + ((stringp show) + (push show visible-list))) + (setq pos next-change)) + (if (= (length visible-list) 1) + ;; If VISIBLE-LIST consists of only one element, return it + ;; without concatenation. This avoids additional consing in + ;; regions without any invisible text. + (car visible-list) + (apply #'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. + (push (aref htmlize-tab-spaces tab-size) 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. + (apply #'concat (nreverse chunks))))) + +(defun htmlize-despam-address (string) + "Replace every occurrence of '@' in STRING with @. +`htmlize-make-hyperlinks' uses this to spam-protect mailto links +without modifying their meaning." + ;; Suggested by Ville Skytta. + (while (string-match "@" string) + (setq string (replace-match "@" nil t string))) + string) + +(defun htmlize-make-hyperlinks () + "Make hyperlinks in HTML." + ;; Function originally submitted by Ville Skytta. Rewritten by + ;; Hrvoje Niksic, then modified by Ville Skytta and Hrvoje Niksic. + (goto-char (point-min)) + (while (re-search-forward + "<\\(\\(mailto:\\)?\\([-=+_.a-zA-Z0-9]+@[-_.a-zA-Z0-9]+\\)\\)>" + nil t) + (let ((address (match-string 3)) + (link-text (match-string 1))) + (delete-region (match-beginning 0) (match-end 0)) + (insert "<<a href=\"mailto:" + (htmlize-despam-address address) + "\">" + (htmlize-despam-address link-text) + "</a>>"))) + (goto-char (point-min)) + (while (re-search-forward "<\\(\\(URL:\\)?\\([a-zA-Z]+://[^;]+\\)\\)>" + nil t) + (let ((url (match-string 3)) + (link-text (match-string 1))) + (delete-region (match-beginning 0) (match-end 0)) + (insert "<<a href=\"" url "\">" link-text "</a>>")))) + +;; Tests for htmlize-make-hyperlinks: + +;; <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-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. + +(if (fboundp 'locate-file) + (defalias 'htmlize-locate-file 'locate-file) + (defun htmlize-locate-file (file path) + (dolist (dir path nil) + (when (file-exists-p (expand-file-name file dir)) + (return (expand-file-name file dir)))))) + +(defvar htmlize-x-library-search-path + '("/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 (htmlize-locate-file + "rgb.txt" + htmlize-x-library-search-path))) + (hash nil)) + (when rgb-file + (with-temp-buffer + (insert-file-contents rgb-file) + (setq hash (make-hash-table :test 'equal)) + (while (not (eobp)) + (cond ((looking-at "^\\s-*\\([!#]\\|$\\)") + ;; Skip comments and empty lines. + ) + ((looking-at + "[ \t]*\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\(.*\\)") + (setf (gethash (downcase (match-string 4)) hash) + (format "#%02x%02x%02x" + (string-to-number (match-string 1)) + (string-to-number (match-string 2)) + (string-to-number (match-string 3))))) + (t + (error + "Unrecognized line in %s: %s" + rgb-file + (buffer-substring (point) (progn (end-of-line) (point)))))) + (forward-line 1)))) + hash)) + +;; Compile the RGB map when loaded. On systems where rgb.txt is +;; missing, the value of the variable will be nil, and rgb.txt will +;; not be used. +(defvar htmlize-color-rgb-hash (htmlize-get-color-rgb-hash)) + +;;; Face handling. + +(defun htmlize-face-specifies-property (face prop) + ;; Return t if face specifies PROP, as opposed to it being inherited + ;; from the default face. The problem with e.g. + ;; `face-foreground-instance' is that it returns an instance for + ;; EVERY face because every face inherits from the default face. + ;; However, we'd like htmlize-face-{fore,back}ground to return nil + ;; when called with a face that doesn't specify its own foreground + ;; or background. + (or (eq face 'default) + (assq 'global (specifier-spec-list (face-property face prop))))) + +(defun htmlize-face-color-internal (face fg) + ;; Used only under GNU Emacs. Return the color of FACE, but don't + ;; return "unspecified-fg" or "unspecified-bg". If the face is + ;; `default' and the color is unspecified, look up the color in + ;; frame parameters. + (let* ((function (if fg #'face-foreground #'face-background)) + color) + (if (>= emacs-major-version 22) + ;; For GNU Emacs 22+ set INHERIT to get the inherited values. + (setq color (funcall function face nil t)) + (setq color (funcall function face)) + ;; For GNU Emacs 21 (which has `face-attribute'): if the color + ;; is nil, recursively check for the face's parent. + (when (and (null color) + (fboundp 'face-attribute) + (face-attribute face :inherit) + (not (eq (face-attribute face :inherit) 'unspecified))) + (setq color (htmlize-face-color-internal + (face-attribute face :inherit) fg)))) + (when (and (eq face 'default) (null color)) + (setq color (cdr (assq (if fg 'foreground-color 'background-color) + (frame-parameters))))) + (when (or (eq color 'unspecified) + (equal color "unspecified-fg") + (equal color "unspecified-bg")) + (setq color nil)) + (when (and (eq face 'default) + (null color)) + ;; Assuming black on white doesn't seem right, but I can't think + ;; of anything better to do. + (setq color (if fg "black" "white"))) + color)) + +(defun htmlize-face-foreground (face) + ;; Return the name of the foreground color of FACE. If FACE does + ;; not specify a foreground color, return nil. + (cond (htmlize-running-xemacs + ;; XEmacs. + (and (htmlize-face-specifies-property face 'foreground) + (color-instance-name (face-foreground-instance face)))) + (t + ;; GNU Emacs. + (htmlize-face-color-internal face t)))) + +(defun htmlize-face-background (face) + ;; Return the name of the background color of FACE. If FACE does + ;; not specify a background color, return nil. + (cond (htmlize-running-xemacs + ;; XEmacs. + (and (htmlize-face-specifies-property face 'background) + (color-instance-name (face-background-instance face)))) + (t + ;; GNU Emacs. + (htmlize-face-color-internal face nil)))) + +;; Convert COLOR to the #RRGGBB string. If COLOR is already in that +;; format, it's left unchanged. + +(defun htmlize-color-to-rgb (color) + (let ((rgb-string nil)) + (cond ((null color) + ;; Ignore nil COLOR because it means that the face is not + ;; specifying any color. Hence (htmlize-color-to-rgb nil) + ;; returns nil. + ) + ((string-match "\\`#" color) + ;; The color is already in #rrggbb format. + (setq rgb-string color)) + ((and htmlize-use-rgb-txt + htmlize-color-rgb-hash) + ;; Use of rgb.txt is requested, and it's available on the + ;; system. Use it. + (setq rgb-string (gethash (downcase color) htmlize-color-rgb-hash))) + (t + ;; We're getting the RGB components from Emacs. + (let ((rgb + ;; Here I cannot conditionalize on (fboundp ...) + ;; because ps-print under some versions of GNU Emacs + ;; defines its own dummy version of + ;; `color-instance-rgb-components'. + (if htmlize-running-xemacs + (mapcar (lambda (arg) + (/ arg 256)) + (color-instance-rgb-components + (make-color-instance color))) + (mapcar (lambda (arg) + (/ arg 256)) + (x-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 (ignore-errors (face-attribute f :inherit)) ;????? + until (or (not f) (eq f 'unspecified)) + for h = (ignore-errors (face-attribute f :height)) ;??????? + collect (if (eq h 'unspecified) nil h)))) + (reduce 'htmlize-merge-size (cons nil size-list)))) + +(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))))) + (cond (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. + ;; #### This probably doesn't work under MS Windows and/or + ;; GTK devices. I'll need help with those. + (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)))) + ((fboundp 'face-attribute) + ;; GNU Emacs 21 and further. + (dolist (attr '(:weight :slant :underline :overline :strike-through)) + (let ((value (if (>= emacs-major-version 22) + ;; Use the INHERIT arg in GNU Emacs 22. + (face-attribute face attr nil t) + ;; Otherwise, fake it. + (let ((face face)) + (while (and (eq (face-attribute face attr) + 'unspecified) + (not (eq (face-attribute face :inherit) + 'unspecified))) + (setq face (face-attribute face :inherit))) + (face-attribute face attr))))) + (when (and value (not (eq value 'unspecified))) + (htmlize-face-emacs21-attr fstruct attr value)))) + (let ((size (htmlize-face-size face))) + (unless (eql size 1.0) ; ignore non-spec + (setf (htmlize-fstruct-size fstruct) size)))) + (t + ;; Older GNU Emacs. Some of these functions are only + ;; available under Emacs 20+, hence the guards. + (when (fboundp 'face-bold-p) + (setf (htmlize-fstruct-boldp fstruct) (face-bold-p face))) + (when (fboundp 'face-italic-p) + (setf (htmlize-fstruct-italicp fstruct) (face-italic-p face))) + (setf (htmlize-fstruct-underlinep fstruct) + (face-underline-p face)))) + ;; Generate the css-name property. Emacs places no restrictions + ;; on the names of symbols that represent faces -- any characters + ;; may be in the name, even ^@. We try hard to beat the face name + ;; into shape, both esthetically and according to CSS1 specs. + (setf (htmlize-fstruct-css-name fstruct) + (let ((name (downcase (symbol-name face)))) + (when (string-match "\\`font-lock-" name) + ;; Change font-lock-FOO-face to 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. + (setq name (concat htmlize-css-name-prefix name)) + name)) + fstruct)) + +(defmacro htmlize-copy-attr-if-set (attr-list dest source) + ;; Expand the code of the type + ;; (and (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 `(and (,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-face-list-p (face-prop) + "Return non-nil if FACE-PROP is a list of faces, nil otherwise." + ;; If not for attrlists, this would return (listp face-prop). This + ;; way we have to be more careful because attrlist is also a list! + (cond + ((eq face-prop nil) + ;; FACE-PROP being nil means empty list (no face), so return t. + t) + ((symbolp face-prop) + ;; A symbol other than nil means that it's only one face, so return + ;; nil. + nil) + ((not (consp face-prop)) + ;; Huh? Not a symbol or cons -- treat it as a single element. + nil) + (t + ;; We know that FACE-PROP is a cons: check whether it looks like an + ;; ATTRLIST. + (let* ((car (car face-prop)) + (attrlist-p (and (symbolp car) + (or (eq car 'foreground-color) + (eq car 'background-color) + (eq (aref (symbol-name car) 0) ?:))))) + ;; If FACE-PROP is not an ATTRLIST, it means it's a list of + ;; faces. + (not attrlist-p))))) + +(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))) + ;; FACE-PROP can be a face/attrlist or a list thereof. + (setq faces (if (htmlize-face-list-p face-prop) + (nunion (mapcar #'htmlize-unstringify-face face-prop) + faces :test 'equal) + (adjoin (htmlize-unstringify-face 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))) + ;; FACE-PROP can be a face/attrlist or a list thereof. + (setq faces (if (htmlize-face-list-p face-prop) + (nunion (mapcar #'htmlize-unstringify-face face-prop) + faces :test 'equal) + (adjoin (htmlize-unstringify-face 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 (if (htmlize-face-list-p face-prop) + (nreverse (mapcar #'htmlize-unstringify-face + face-prop)) + (list (htmlize-unstringify-face 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)) + (setq list (if (htmlize-face-list-p face-prop) + (nconc (nreverse (mapcar + #'htmlize-unstringify-face + face-prop)) + list) + (cons (htmlize-unstringify-face 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 two several fundamentally +;; different ways, one with the use of CSS and nested <span> tags, and +;; the other with the use of the old <font> tags. Rather than adding +;; a bunch of ifs to many places, we take a semi-OO approach. +;; `htmlize-buffer-1' calls a number of "methods", which indirect to +;; the functions that depend on `htmlize-output-type'. The currently +;; used methods are `doctype', `insert-head', `body-tag', and +;; `insert-text'. 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. +;; +;; Currently defined output types are `css' and `font'. + +(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 + ;; According to DTDs published by the W3C, it is illegal to embed + ;; <font> in <pre>. This makes sense in general, but is bad for + ;; htmlize's intended usage of <font> to specify the document color. + + ;; To make generated HTML legal, htmlize's `font' mode used to + ;; specify the SGML declaration of "HTML Pro" DTD here. HTML Pro + ;; aka Silmaril DTD was a project whose goal was to produce a GPL'ed + ;; DTD that would encompass all the incompatible HTML extensions + ;; procured by Netscape, MSIE, and other players in the field. + ;; Apparently the project got abandoned, the last available version + ;; being "Draft 0 Revision 11" from January 1997, as documented at + ;; <http://imbolc.ucc.ie/~pflynn/articles/htmlpro.html>. + + ;; Since by now HTML Pro is remembered by none but the most die-hard + ;; early-web-days nostalgics and used by not even them, there is no + ;; use in specifying it. So we return the standard HTML 4.0 + ;; declaration, which makes generated HTML technically illegal. If + ;; you have a problem with that, use the `css' engine designed to + ;; create fully conforming HTML. + + "<!DOCTYPE html PUBLIC \"-//W3C//DTD HTML 4.01//EN\">" + + ;; Now-abandoned HTML Pro declaration. + ;"<!DOCTYPE HTML PUBLIC \"+//Silmaril//DTD HTML Pro v0r11 19970101//EN\">" + ) + +(defun htmlize-default-body-tag (face-map) + nil ; no doc-string + "<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-insert-text (text fstruct-list buffer) + ;; Insert TEXT colored with FACES into BUFFER. 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)) + (princ text buffer) + (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-insert-text (text 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)) + (princ text buffer) + (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-insert-text (text 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) + (princ text buffer) + (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) + (let* ((buffer-faces (htmlize-faces-in-buffer)) + (face-map (htmlize-make-face-map (adjoin 'default buffer-faces))) + ;; Generate the new buffer. It's important that it inherits + ;; default-directory from the current buffer. + (htmlbuf (generate-new-buffer (if (buffer-file-name) + (htmlize-make-file-name + (file-name-nondirectory + (buffer-file-name))) + "*html*"))) + ;; Having a dummy value in the plist allows writing simply + ;; (plist-put places foo bar). + (places '(nil nil)) + (title (if (buffer-file-name) + (file-name-nondirectory (buffer-file-name)) + (buffer-name)))) + ;; 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 ") + (plist-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>") + (plist-put places 'head-end (point-marker)) + (insert "\n ") + (plist-put places 'body-start (point-marker)) + (insert (htmlize-method body-tag face-map) + "\n ") + (plist-put places 'content-start (point-marker)) + (insert "<pre>\n")) + (let ((insert-text-method + ;; 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 'insert-text)) + ;; Declare variables used in loop body outside the loop + ;; because it's faster to establish `let' bindings only + ;; once. + next-change text face-list fstruct-list trailing-ellipsis) + ;; This loop traverses and reads the source buffer, appending + ;; the resulting HTML to HTMLBUF with `princ'. This method is + ;; fast because: 1) it doesn't require examining the text + ;; properties char by char (htmlize-next-change is used to + ;; move between runs with the same face), and 2) it doesn't + ;; require buffer switches, which are slow in Emacs. + (goto-char (point-min)) + (while (not (eobp)) + (setq next-change (htmlize-next-change (point) 'face)) + ;; 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))) + ;; Extract buffer text, sans the invisible parts. Then + ;; untabify it and escape the HTML metacharacters. + (setq text (htmlize-buffer-substring-no-invisible + (point) next-change)) + (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-protect-string text)) + ;; Don't bother writing anything if there's no text (this + ;; happens in invisible regions). + (when (> (length text) 0) + ;; Insert the text, along with the necessary markup to + ;; represent faces in FSTRUCT-LIST. + (funcall insert-text-method text fstruct-list htmlbuf)) + (goto-char next-change))) + + ;; Insert the epilog and post-process the buffer. + (with-current-buffer htmlbuf + (insert "</pre>") + (plist-put places 'content-end (point-marker)) + (insert "\n </body>") + (plist-put places 'body-end (point-marker)) + (insert "\n</html>\n") + (when htmlize-generate-hyperlinks + (htmlize-make-hyperlinks)) + (htmlize-defang-local-variables) + (when htmlize-replace-form-feeds + ;; Change each "\n^L" to "<hr />". + (goto-char (point-min)) + (let ((source + ;; ^L has already been escaped, so search for that. + (htmlize-protect-string "\n\^L")) + (replacement + (if (stringp htmlize-replace-form-feeds) + htmlize-replace-form-feeds + "</pre><hr /><pre>"))) + (while (search-forward source nil t) + (replace-match replacement t t)))) + (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) places) + (run-hooks 'htmlize-after-hook) + (buffer-enable-undo)) + htmlbuf))) + +;; 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) + +;;; htmlize.el ends here diff --git a/.emacs.d/org-7.4/contrib/lisp/org-annotate-file.el b/.emacs.d/org-7.4/contrib/lisp/org-annotate-file.el new file mode 100644 index 0000000..9ea9015 --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-annotate-file.el @@ -0,0 +1,130 @@ +;;; org-annotate-file.el --- Annotate a file with org syntax + +;; Copyright (C) 2008 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. + +(require 'org) + +(defvar org-annotate-file-storage-file "~/.org-annotate-file.org" + "File in which to keep annotations.") + +(defvar org-annotate-file-add-search nil + "If non-nil then add a link as a second level to the actual +location in the file") + +(defvar org-annotate-file-always-open t + "non-nil means always expand the full tree when you visit +`org-annotate-file-storage-file'.") + +(defun org-annotate-file-elipsify-desc (string &optional after) + "Strip starting and ending whitespace and replace any chars +that appear after the value in `after' with '...'" + (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)) + +(defun org-annotate-file () + "Put a section for the current file into your annotation file" + (interactive) + (unless (buffer-file-name) + (error "This buffer has no associated file.")) + (org-annotate-file-show-section)) + +(defun org-annotate-file-show-section (&optional buffer) + "Visit the buffer named `org-annotate-file-storage-file' and +show the relevant section" + (let* ((filename (abbreviate-file-name (or buffer (buffer-file-name)))) + (line (buffer-substring-no-properties (point-at-bol) (point-at-eol))) + (link (org-make-link-string (concat "file:" filename) filename)) + (search-link (org-make-link-string + (concat "file:" filename "::" line) + (org-annotate-file-elipsify-desc line)))) + (with-current-buffer (find-file org-annotate-file-storage-file) + (unless (org-mode-p) + (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) + (goto-char (point-min)) + (call-interactively 'org-insert-heading) + (insert link)) + +(defun org-annotate-file-add-second-level (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/.emacs.d/org-7.4/contrib/lisp/org-bookmark.el b/.emacs.d/org-7.4/contrib/lisp/org-bookmark.el new file mode 100644 index 0000000..06d2c60 --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-bookmark.el @@ -0,0 +1,88 @@ +;;; org-bookmark.el - Support for links to bookmark +;; Copyright (C) 2008 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. + +;; 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; 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-add-link-type "bookmark" 'org-bookmark-open) +(add-hook 'org-store-link-functions '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 (org-make-link "bookmark:" bookmark) + :description bookmark)))) + +(provide 'org-bookmark) + +;;; org-bookmark.el ends here diff --git a/.emacs.d/org-7.4/contrib/lisp/org-checklist.el b/.emacs.d/org-7.4/contrib/lisp/org-checklist.el new file mode 100644 index 0000000..50df757 --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-checklist.el @@ -0,0 +1,143 @@ +;;; org-checklist.el --- org functions for checklist handling + +;; Copyright (C) 2008 James TD Smith + +;; Author: James TD Smith (@ ahktenzero (. mohorovi cc)) +;; Version: 1.0 +;; Keywords: org, checklists +;; +;; 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; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; 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 state org-done-keywords) + (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/.emacs.d/org-7.4/contrib/lisp/org-choose.el b/.emacs.d/org-7.4/contrib/lisp/org-choose.el new file mode 100644 index 0000000..6f7f120 --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-choose.el @@ -0,0 +1,539 @@ +;;;_ org-choose.el --- decision management for org-mode + +;;;_. Headers +;;;_ , License +;; Copyright (C) 2009 Tom Breton (Tehom) + +;; 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) + )) + + +;;;_. Footers +;;;_ , Provides + +(provide 'org-choose) + +;;;_ * Local emacs vars. +;;;_ + Local variables: +;;;_ + End: + +;;;_ , End +;;; org-choose.el ends here diff --git a/.emacs.d/org-7.4/contrib/lisp/org-collector.el b/.emacs.d/org-7.4/contrib/lisp/org-collector.el new file mode 100644 index 0000000..1d4f042 --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-collector.el @@ -0,0 +1,235 @@ +;;; org-collector --- collect properties into tables + +;; Copyright (C) 2008 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. + +;; 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, 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: + +;; 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-read-prop (prop) + "Convert the string property PROP to a number if appropriate. +If prop looks like a list (meaning it starts with a '(') then +read it as lisp expression, otherwise return it unmodified as a +string. + +Results of calling: +\(org-read-prop \"12\") -> 12 +\(org-read-prop \"(1 2 3)\") -> (1 2 3) +\(org-read-prop \"+0\") -> 0 +\(org-read-prop \"aaa\") -> \"aaa\"" + (if (and (stringp prop) (not (equal prop ""))) + (let ((out (string-to-number prop))) + (if (equal out 0) + (cond + ((or + (equal "(" (substring prop 0 1)) + (equal "'" (substring prop 0 1))) + + (condition-case nil + (read prop) + (error prop))) + ((string-match "^\\(+0\\|-0\\|0\\)$" prop) + 0) + (t + (set-text-properties 0 (length prop) nil prop) + prop)) + out)) + prop)) + +(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)) + (conds (plist-get params :conds)) + (match (plist-get params :match)) + (scope (plist-get params :scope)) + (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)))) + (org-narrow-to-subtree) + (setq table (org-propview-to-table (org-propview-collect cols conds match scope))) + (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-collect (cols &optional conds match scope) + (interactive) + ;; collect the properties from every header + (let* ((header-props + (let ((org-trust-scanner-tags t)) + (org-map-entries (quote (cons (cons "ITEM" (org-get-heading t)) + (org-entry-properties))) + match scope))) + ;; read property values + (header-props (mapcar (lambda (props) + (mapcar (lambda (pair) (cons (car pair) (org-read-prop (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 + (mapcar (lambda (el) (format "%S" el)) cols) ;; output headers + '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) + ;; (message (format "cols:%S" cols)) + (orgtbl-to-orgtbl + (mapcar + (lambda (row) + (if (equal row 'hline) + 'hline + (mapcar (lambda (el) (format "%S" el)) row))) + (delq nil results)) '())) + +(provide 'org-collector) +;;; org-collector ends here diff --git a/.emacs.d/org-7.4/contrib/lisp/org-contribdir.el b/.emacs.d/org-7.4/contrib/lisp/org-contribdir.el new file mode 100644 index 0000000..92c50a0 --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-contribdir.el @@ -0,0 +1,38 @@ +;;; org-contribdir.el --- Mark the location of the contrib directory +;; Copyright (C) 2009 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. +;; +;; 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, 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; 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/.emacs.d/org-7.4/contrib/lisp/org-depend.el b/.emacs.d/org-7.4/contrib/lisp/org-depend.el new file mode 100644 index 0000000..089a6a0 --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-depend.el @@ -0,0 +1,279 @@ +;;; org-depend.el --- TODO dependencies for Org-mode +;; Copyright (C) 2008 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. + +;; 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; 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 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) + +(defcustom org-depend-tag-blocked t + "Whether to indicate blocked TODO items by a special tag." + :group 'org + :type 'boolean) + +(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)))) + +(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." + + ;; 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) + (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 + ((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/.emacs.d/org-7.4/contrib/lisp/org-drill.el b/.emacs.d/org-7.4/contrib/lisp/org-drill.el new file mode 100644 index 0000000..6b5ff06 --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-drill.el @@ -0,0 +1,1144 @@ +;;; org-drill.el - Self-testing with org-learn +;;; +;;; Author: Paul Sexton <eeeickythump@gmail.com> +;;; Version: 1.4 +;;; Repository at http://bitbucket.org/eeeickythump/org-drill/ +;;; +;;; +;;; Synopsis +;;; ======== +;;; +;;; Uses the spaced repetition algorithm in `org-learn' 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 fed back to `org-learn' 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 'org) +(require 'org-learn) + + +(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. By default this is +2. 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-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) + + +(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) + + +(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-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) + + +(setplist 'org-drill-cloze-overlay-defaults + '(display "[...]" + face org-drill-hidden-cloze-face + window t)) + + +(defvar org-drill-cloze-regexp + ;; ver 1 "[^][]\\(\\[[^][][^]]*\\]\\)" + ;; ver 2 "\\(\\[.*?\\]\\|^[^[[:cntrl:]]*?\\]\\|\\[.*?$\\)" + ;; ver 3! "\\(\\[.*?\\]\\|\\[.*?[[:cntrl:]]+.*?\\]\\)" + "\\(\\[[[:cntrl:][:graph:][:space:]]*?\\)\\(\\||.+?\\)\\(\\]\\)") + +(defvar org-drill-cloze-keywords + `((,org-drill-cloze-regexp + (1 'org-drill-visible-cloze-face nil) + (2 'org-drill-visible-cloze-hint-face t) + (3 'org-drill-visible-cloze-face nil) + ))) + + +(defcustom org-drill-card-type-alist + '((nil . org-drill-present-simple-card) + ("simple" . org-drill-present-simple-card) + ("twosided" . org-drill-present-two-sided-card) + ("multisided" . org-drill-present-multi-sided-card) + ("multicloze" . org-drill-present-multicloze) + ("spanish_verb" . org-drill-present-spanish-verb)) + "Alist associating card types with presentation functions. Each entry in the +alist takes the form (CARDTYPE . FUNCTION), where CARDTYPE is a string +or nil, and FUNCTION is a function which takes no arguments and returns a +boolean value." + :group 'org-drill + :type '(alist :key-type (choice string (const nil)) :value-type function)) + + +(defcustom org-drill-spaced-repetition-algorithm + 'sm5 + "Which SuperMemo spaced repetition algorithm to use for scheduling items. +Available choices are SM2 and SM5." + :group 'org-drill + :type '(choice (const 'sm2) (const 'sm5))) + +(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, and scales up with the interval. The code for calculating +random noise is adapted from Mnemosyne." + :group 'org-drill + :type 'boolean) + +(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) + + +(defvar *org-drill-session-qualities* nil) +(defvar *org-drill-start-time* 0) +(defvar *org-drill-new-entries* nil) +(defvar *org-drill-mature-entries* nil) +(defvar *org-drill-failed-entries* nil) +(defvar *org-drill-again-entries* nil) +(defvar *org-drill-done-entries* nil) +(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?") + + + +;;;; Utilities ================================================================ + + +(defun free-marker (m) + (set-marker m nil)) + + +(defmacro pop-random (place) + (let ((elt (gensym))) + `(if (null ,place) + nil + (let ((,elt (nth (random (length ,place)) ,place))) + (setq ,place (remove ,elt ,place)) + ,elt)))) + + +(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 time-to-inactive-org-timestamp (time) + (format-time-string + (concat "[" (substring (cdr org-time-stamp-formats) 1 -1) "]") + time)) + + + +(defmacro with-hidden-cloze-text (&rest body) + `(progn + (org-drill-hide-clozed-text) + (unwind-protect + (progn + ,@body) + (org-drill-unhide-clozed-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 () + "Is the current entry a 'drill item'?" + (or (org-entry-get (point) "LEARN_DATA") + ;;(assoc "LEARN_DATA" (org-entry-properties nil)) + (member org-drill-question-tag (org-get-local-tags)))) + + +(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 hold 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 (minusp ; scheduled for today/in future + (- (time-to-days (current-time)) + (time-to-days item-time)))))))))) + + +(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 () + (let ((quality (org-entry-get (point) "DRILL_LAST_QUALITY"))) + (if quality + (string-to-number quality) + nil))) + + +;;; SM2 Algorithm ============================================================= + + +(defun determine-next-interval-sm2 (last-interval n ef quality of-matrix) + "Arguments: +- LAST-INTERVAL -- the number of days since the item was last reviewed. +- N -- the number of times the item has been successfully reviewed +- EF -- the 'easiness factor' +- QUALITY -- 0 to 5 +- OF-MATRIX -- a matrix of values, used by SM5 but not by SM2. + +Returns a list: (INTERVAL N EF OFMATRIX), where: +- INTERVAL is the number of days until the item should next be reviewed +- N 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 of-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 (ceiling (* last-interval next-ef)))))) + (list (round + (if org-drill-add-random-noise-to-intervals-p + (+ last-interval (* (- interval last-interval) + (org-drill-random-dispersal-factor))) + interval)) + (1+ n) next-ef of-matrix)))) + + +;;; SM5 Algorithm ============================================================= + +;;; From http://www.supermemo.com/english/ol/sm5.htm +(defun org-drill-random-dispersal-factor () + (let ((a 0.047) + (b 0.092) + (p (- (random* 1.0) 0.5))) + (flet ((sign (n) + (cond ((zerop n) 0) + ((plusp n) 1) + (t -1)))) + (/ (+ 100 (* (* (/ -1 b) (log (- 1 (* (/ b a ) (abs p))))) + (sign p))) + 100)))) + + +(defun inter-repetition-interval-sm5 (last-interval n ef &optional of-matrix) + (let ((of (get-optimal-factor n ef of-matrix))) + (if (= 1 n) + of + (* of last-interval)))) + + +(defun determine-next-interval-sm5 (last-interval n ef quality of-matrix) + (assert (> n 0)) + (assert (and (>= quality 0) (<= quality 5))) + (let ((next-ef (modify-e-factor ef quality)) + (interval nil)) + (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) + + (cond + ;; "Failed" -- reset repetitions to 0, + ((<= quality org-drill-failure-quality) + (list -1 1 ef 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 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 (+ last-interval + (* (- interval last-interval) + (org-drill-random-dispersal-factor))))) + (list (round interval) (1+ n) ef of-matrix))))) + + +;;; Essentially copied from `org-learn.el', but modified to +;;; optionally call the SM2 function above. +(defun org-drill-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 + (case org-drill-spaced-repetition-algorithm + (sm5 (determine-next-interval-sm5 (nth 0 learn-data) + (nth 1 learn-data) + (nth 2 learn-data) + quality + (nth 3 learn-data))) + (sm2 (determine-next-interval-sm2 (nth 0 learn-data) + (nth 1 learn-data) + (nth 2 learn-data) + quality + (nth 3 learn-data))))) + (org-entry-put (point) "LEARN_DATA" (prin1-to-string learn-data)) + (cond + ((= 0 (nth 0 learn-data)) + (org-schedule t)) + ((minusp (first learn-data)) + (org-schedule nil (current-time))) + (t + (org-schedule nil (time-add (current-time) + (days-to-time (nth 0 learn-data)))))))) + + +(defun org-drill-reschedule () + "Returns quality rating (0-5), or nil if the user quit." + (let ((ch nil)) + (while (not (memq ch '(?q ?e ?0 ?1 ?2 ?3 ?4 ?5))) + (setq ch (read-char-exclusive + (if (eq ch ??) + "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. +4 - After a little bit of thought you remembered. +5 - You remembered the item really easily. + +How well did you do? (0-5, ?=help, e=edit, t=tags, q=quit)" + "How well did you do? (0-5, ?=help, e=edit, q=quit)"))) + (if (eql ch ?t) + (org-set-tags-command))) + (cond + ((and (>= ch ?0) (<= ch ?5)) + (let ((quality (- ch ?0)) + (failures (org-entry-get (point) "DRILL_FAILURE_COUNT"))) + (save-excursion + (org-drill-smart-reschedule quality)) + (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 ?e) + '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 (= (org-current-level) (1+ drill-entry-level)) + (setq drill-heading (org-get-heading t)) + (unless (member drill-heading heading-list) + (hide-subtree)) + (push (point) drill-sections))) + "" 'tree)) + (reverse drill-sections))) + + + +(defun org-drill-presentation-prompt (&rest fmt-and-args) + (let* ((item-start-time (current-time)) + (ch nil) + (last-second 0) + (prompt + (if fmt-and-args + (apply 'format + (first fmt-and-args) + (rest fmt-and-args)) + (concat "Press key for answer, " + "e=edit, t=tags, s=skip, q=quit.")))) + (setq prompt + (format "%s %s %s %s %s" + (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 (length *org-drill-mature-entries*)) + '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 ?t)) + (while (not (input-pending-p)) + (message (concat (format-time-string + "%M:%S " (time-subtract + (current-time) item-start-time)) + prompt)) + (sit-for 1)) + (setq ch (read-char-exclusive)) + (if (eql ch ?t) + (org-set-tags-command))) + (case ch + (?q nil) + (?e 'edit) + (?s '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-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 + (unless (org-pos-in-regexp (match-beginning 0) + org-bracket-link-regexp 1) + (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)))) + (overlay-put ovl 'category + 'org-drill-cloze-overlay-defaults) + (when (find ?| (match-string 0)) + (overlay-put ovl + 'display + (format "[...%s]" + (substring-no-properties + (match-string 0) + (1+ (position ?| (match-string 0))) + (1- (length (match-string 0))))))))) + + +(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))))) + + + +;;; 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-cloze-text + (org-drill-hide-all-subheadings-except nil) + (org-display-inline-images t) + (org-cycle-hide-drawers 'all) + (prog1 (org-drill-presentation-prompt) + (org-show-subtree)))) + + +(defun org-drill-present-two-sided-card () + (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-display-inline-images t) + (org-cycle-hide-drawers 'all) + (prog1 + (org-drill-presentation-prompt) + (org-show-subtree))))) + + + +(defun org-drill-present-multi-sided-card () + (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-display-inline-images t) + (org-cycle-hide-drawers 'all) + (prog1 + (org-drill-presentation-prompt) + (org-show-subtree))))) + + +(defun org-drill-present-multicloze () + (let ((item-end nil) + (match-count 0) + (body-start (or (cdr (org-get-property-block)) + (point)))) + (org-drill-hide-all-subheadings-except nil) + (save-excursion + (outline-next-heading) + (setq item-end (point))) + (save-excursion + (goto-char body-start) + (while (re-search-forward org-drill-cloze-regexp item-end t) + (incf match-count))) + (when (plusp match-count) + (save-excursion + (goto-char body-start) + (re-search-forward org-drill-cloze-regexp + item-end t (1+ (random match-count))) + (org-drill-hide-matched-cloze-text))) + (org-display-inline-images t) + (org-cycle-hide-drawers 'all) + (prog1 (org-drill-presentation-prompt) + (org-show-subtree) + (org-drill-unhide-clozed-text)))) + + +(defun org-drill-present-spanish-verb () + (let ((prompt nil) + (reveal-headings nil)) + (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 prompt) + (org-drill-hide-all-subheadings-except reveal-headings))))) + + + +(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. + +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")) + (cont nil)) + (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)))) + (cond + (presentation-fn + (setq cont (funcall presentation-fn))) + (t + (error "Unknown card type: '%s'" card-type)))) + + (cond + ((not cont) + (message "Quit") + nil) + ((eql cont 'edit) + 'edit) + ((eql cont 'skip) + 'skip) + (t + (save-excursion + (org-drill-reschedule))))))) + + +;; (defun org-drill-entries (entries) +;; "Returns nil, t, or a list of markers representing entries that were +;; 'failed' and need to be presented again before the session ends." +;; (let ((again-entries nil)) +;; (setq *org-drill-done-entry-count* 0 +;; *org-drill-pending-entry-count* (length entries)) +;; (if (and org-drill-maximum-items-per-session +;; (> (length entries) +;; org-drill-maximum-items-per-session)) +;; (setq entries (subseq entries 0 +;; org-drill-maximum-items-per-session))) +;; (block org-drill-entries +;; (dolist (m entries) +;; (save-restriction +;; (switch-to-buffer (marker-buffer m)) +;; (goto-char (marker-position m)) +;; (setq result (org-drill-entry)) +;; (cond +;; ((null result) +;; (message "Quit") +;; (return-from org-drill-entries nil)) +;; ((eql result 'edit) +;; (setq end-pos (point-marker)) +;; (return-from org-drill-entries nil)) +;; (t +;; (cond +;; ((< result 3) +;; (push m again-entries)) +;; (t +;; (decf *org-drill-pending-entry-count*) +;; (incf *org-drill-done-entry-count*))) +;; (when (and org-drill-maximum-duration +;; (> (- (float-time (current-time)) *org-drill-start-time*) +;; (* org-drill-maximum-duration 60))) +;; (message "This drill session has reached its maximum duration.") +;; (return-from org-drill-entries nil)))))) +;; (or again-entries +;; t)))) + + +(defun org-drill-entries-pending-p () + (or *org-drill-again-entries* + (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-mature-entries* + *org-drill-again-entries*)))) + + +(defun org-drill-pending-entry-count () + (+ (length *org-drill-new-entries*) + (length *org-drill-failed-entries*) + (length *org-drill-mature-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 + *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 + (>= (length *org-drill-done-entries*) + org-drill-maximum-items-per-session))) + + +(defun org-drill-pop-next-pending-entry () + (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 newly added items, and items which + ;; are not new and were not failed when they were last + ;; reviewed. + ((and (or *org-drill-new-entries* + *org-drill-mature-entries*) + (not (org-drill-maximum-item-count-reached-p)) + (not (org-drill-maximum-duration-reached-p))) + (if (< (random (+ (length *org-drill-new-entries*) + (length *org-drill-mature-entries*))) + (length *org-drill-new-entries*)) + (pop-random *org-drill-new-entries*) + ;; else + (pop-random *org-drill-mature-entries*))) + ;; After all the above are done, last priority is items + ;; that were failed earlier THIS SESSION. + (*org-drill-again-entries* + (pop-random *org-drill-again-entries*)) + (t + nil))) + + +(defun org-drill-entries () + "Returns nil, t, or a list of markers representing entries that were +'failed' and need to be presented again before the session ends." + (block org-drill-entries + (while (org-drill-entries-pending-p) + (setq m (org-drill-pop-next-pending-entry)) + (unless m + (error "Unexpectedly ran out of pending drill items")) + (save-excursion + (set-buffer (marker-buffer m)) + (goto-char m) + (setq result (org-drill-entry)) + (cond + ((null result) + (message "Quit") + (return-from org-drill-entries nil)) + ((eql result 'edit) + (setq end-pos (point-marker)) + (return-from org-drill-entries nil)) + ((eql result 'skip) + nil) ; skip this item + (t + (cond + ((<= result org-drill-failure-quality) + (push m *org-drill-again-entries*)) + (t + (push m *org-drill-done-entries*))))))))) + + + +(defun org-drill-final-report () + (read-char-exclusive + (format + "%d items reviewed +%d items awaiting review (%s, %s, %s) +Session duration %s + +Recall of reviewed items: + Excellent (5): %3d%% | Near miss (2): %3d%% + Good (4): %3d%% | Failure (1): %3d%% + Hard (3): %3d%% | Total failure (0): %3d%% + +Session finished. Press a key to continue..." + (length *org-drill-done-entries*) + (org-drill-pending-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 old" + (length *org-drill-mature-entries*)) + 'face `(:foreground ,org-drill-mature-count-color)) + (propertize + (format "%d new" + (length *org-drill-new-entries*)) + 'face `(:foreground ,org-drill-new-count-color)) + (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*))) + ))) + + + +(defun org-drill (&optional scope) + "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 using the `org-learn' library. + +Org-drill proceeds by: + +- Finding all topics (headings) in SCOPE which have either been + used and rescheduled by org-learn before (i.e. the LEARN_DATA + property is set), 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 is passed to `org-map-entries', and can be any of: + +nil The current buffer, respecting the restriction if any. + This is the default. +tree The subtree started with the entry at point +file 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 + (file1 file2 ...) + If this is a list, all files in the list will be scanned." + + (interactive) + (let ((entries nil) + (failed-entries nil) + (result nil) + (results nil) + (end-pos nil) + (cnt 0)) + (block org-drill + (setq *org-drill-done-entries* nil + *org-drill-new-entries* nil + *org-drill-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))) + (unwind-protect + (save-excursion + (let ((org-trust-scanner-tags t)) + (org-map-entries + (lambda () + (when (zerop (% (incf cnt) 50)) + (message "Processing drill items: %4d%s" + (+ (length *org-drill-new-entries*) + (length *org-drill-mature-entries*) + (length *org-drill-failed-entries*)) + (make-string (ceiling cnt 50) ?.))) + (when (org-drill-entry-due-p) + (cond + ((org-drill-entry-new-p) + (push (point-marker) *org-drill-new-entries*)) + ((and (org-drill-entry-last-quality) + (<= (org-drill-entry-last-quality) + org-drill-failure-quality)) + (push (point-marker) *org-drill-failed-entries*)) + (t + (push (point-marker) *org-drill-mature-entries*))))) + (concat "+" org-drill-question-tag) scope)) + ;; Failed first, then random mix of old + new + (setq entries (append (shuffle-list *org-drill-failed-entries*) + (shuffle-list (append *org-drill-mature-entries* + *org-drill-new-entries*)))) + (cond + ((and (null *org-drill-new-entries*) + (null *org-drill-failed-entries*) + (null *org-drill-mature-entries*)) + (message "I did not find any pending drill items.")) + (t + (org-drill-entries) + (message "Drill session finished!")))) + ;; (cond + ;; ((null entries) + ;; (message "I did not find any pending drill items.")) + ;; (t + ;; (let ((again t)) + ;; (while again + ;; (when (listp again) + ;; (setq entries (shuffle-list again))) + ;; (setq again (org-drill-entries entries)) + ;; (cond + ;; ((null again) + ;; (return-from org-drill nil)) + ;; ((eql t again) + ;; (setq again nil)))) + ;; (message "Drill session finished!") + ;; )))) + (progn + (dolist (m (append *org-drill-new-entries* + *org-drill-failed-entries* + *org-drill-again-entries* + *org-drill-mature-entries*)) + (free-marker m))))) + (cond + (end-pos + (switch-to-buffer (marker-buffer end-pos)) + (goto-char (marker-position end-pos)) + (message "Edit topic.")) + (t + (org-drill-final-report))))) + + +(defun org-drill-cram (&optional scope) + "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) + (let ((*org-drill-cram-mode* t)) + (org-drill scope))) + + + +(add-hook 'org-mode-hook + (lambda () + (if org-drill-use-visible-cloze-face-p + (font-lock-add-keywords + 'org-mode + org-drill-cloze-keywords + t)))) + + + +(provide 'org-drill) diff --git a/.emacs.d/org-7.4/contrib/lisp/org-elisp-symbol.el b/.emacs.d/org-7.4/contrib/lisp/org-elisp-symbol.el new file mode 100644 index 0000000..b826467 --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-elisp-symbol.el @@ -0,0 +1,159 @@ +;;; org-elisp-symbol.el --- Org links to emacs-lisp symbols +;; +;; Copyright 2007, 2008, 2009 Bastien Guerry +;; +;; Author: bzg AT altern DOT org +;; Version: 0.2 +;; Keywords: org, remember, lisp +;; URL: http://www.cognition.ens.fr/~guerry/u/org-elisp-symbol.el +;; +;; 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; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +;; +;;; 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-add-link-type "elisp-symbol" 'org-elisp-symbol-open) +(add-hook 'org-store-link-functions '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") + ((eq def "defvar") "Variable") + ((eq def "defmacro") "Macro") + (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/.emacs.d/org-7.4/contrib/lisp/org-eval-light.el b/.emacs.d/org-7.4/contrib/lisp/org-eval-light.el new file mode 100644 index 0000000..c571ea0 --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-eval-light.el @@ -0,0 +1,200 @@ +;;; org-eval-light.el --- Display result of evaluating code in various languages (light) + +;; Copyright (C) 2008 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. + +;; 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, 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; 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
\ No newline at end of file diff --git a/.emacs.d/org-7.4/contrib/lisp/org-eval.el b/.emacs.d/org-7.4/contrib/lisp/org-eval.el new file mode 100644 index 0000000..0dd3ade --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-eval.el @@ -0,0 +1,220 @@ +;;; org-eval.el --- Display result of evaluating code in various languages +;; Copyright (C) 2008 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. +;; +;; 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, 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; 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 + :version "22.1") + +(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/.emacs.d/org-7.4/contrib/lisp/org-exp-bibtex.el b/.emacs.d/org-7.4/contrib/lisp/org-exp-bibtex.el new file mode 100644 index 0000000..ab6a6b0 --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-exp-bibtex.el @@ -0,0 +1,155 @@ +;;; org-exp-bibtex.el --- Export bibtex fragments + +;; Copyright (C) 2009 Taru Karttunen + +;; Author: Taru Karttunen <taruti@taruti.net > + +;; 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 both LaTeX and html +;; exports. It uses the bibtex2html software from +;; http://www.lri.fr/~filliatr/bibtex2html/ +;; +;; The usage is as follows: +;; #+BIBLIOGRAPHY: bibfilebasename stylename optional-options +;; e.g. given foo.bib and using style plain: +;; #+BIBLIOGRAPHY: foo 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} 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 + +(require 'org) +(require 'org-exp) +(defun org-export-bibtex-preprocess () + "Export all BibTeX." + (interactive) + (save-window-excursion + (setq oebp-cite-plist '()) + + ;; Convert #+BIBLIOGRAPHY: name style + (goto-char (point-min)) + (while (re-search-forward "^#\\+BIBLIOGRAPHY:[ \t]+\\(\\S-+\\)[ \t]+\\(\\S-+\\)\\([^\r\n]*\\)" nil t) + (let ((file (match-string 1)) + (style (match-string 2)) + (opt (org-exp-bibtex-options-to-plist (match-string 3)))) + (replace-match + (cond + (htmlp ;; We are exporting to HTML + (let (extra-args cite-list end-hook tmp-files) + (dolist (elt opt) + (when (equal "option" (car elt)) + (setq extra-args (cons (cdr elt) extra-args)))) + + + (when (assoc "limit" opt) ;; Limit is true - collect references + (org-exp-bibtex-docites (lambda () + (dolist (c (org-split-string (match-string 1) ",")) + (add-to-list 'cite-list c)))) +;; (message "cites: %s" cite-list) + (let ((tmp (make-temp-file "org-exp-bibtex"))) + (with-temp-file tmp (dolist (i cite-list) (insert (concat i "\n")))) + (setq tmp-files (cons tmp tmp-files)) + (setq extra-args (append extra-args `("-citefile" ,tmp))))) + + (when (not (eq 0 (apply 'call-process (append '("bibtex2html" nil nil nil) + `("-a" "--nodoc" "--style" ,style "--no-header") + extra-args + (list (concat file ".bib")))))) + (error "Executing bibtex2html failed")) + + (dolist (f tmp-files) (delete-file f))) + + (with-temp-buffer + (save-match-data + (insert-file-contents (concat file ".html")) + (goto-char (point-min)) + (while (re-search-forward "a name=\"\\(\\w+\\)\">\\(\\w+\\)" nil t) + (setq oebp-cite-plist (cons (cons (match-string 1) (match-string 2)) oebp-cite-plist))) + (goto-char (point-min)) + (while (re-search-forward "<hr>" nil t) + (replace-match "<hr/>" t t)) + (concat "\n#+BEGIN_HTML\n<div id=\"bibliography\">\n" (buffer-string) "\n</div>\n#+END_HTML\n")))) + (latexp ;; Latex export + (concat "\n#+LATEX: \\bibliographystyle{" style "}" + "\n#+LATEX: \\bibliography{" file "}\n"))) t t))) + + + ;; Convert cites to links in html + (when htmlp + ;; Split citation commands with multiple keys + (org-exp-bibtex-docites + (lambda () + (let ((keys (save-match-data (org-split-string (match-string 1) ",")))) + (when (> (length keys) 1) + (replace-match (mapconcat (lambda (k) (format "\\cite{%s}" k)) keys "") + t t))))) + ;; Replace the citation commands with links + (org-exp-bibtex-docites + (lambda () (let* ((cn (match-string 1)) + (cv (assoc cn oebp-cite-plist))) +;; (message "L: %s" (concat "\[_{}[[" cn "][" (if cv (cdr cv) cn) "]]\]")) + (replace-match (concat "\[_{}[[#" cn "][" (if cv (cdr cv) cn) "]]\]")) t t)))) + + +)) + +(defun org-exp-bibtex-docites (fun) + (save-excursion + (save-match-data + (goto-char (point-min)) + (when htmlp + (while (re-search-forward "\\\\cite{\\([^}\n]+\\)}" nil t) + (apply fun nil)))))) + + +(defun org-exp-bibtex-options-to-plist (options) + (save-match-data + (flet ((f (o) (let ((s (split-string o ":"))) (cons (nth 0 s) (nth 1 s))))) + (mapcar 'f (split-string options nil t))))) + + + + +(add-hook 'org-export-preprocess-hook 'org-export-bibtex-preprocess) + +(provide 'org-exp-bibtex) + +;;; org-exp-bibtex.el ends here diff --git a/.emacs.d/org-7.4/contrib/lisp/org-expiry.el b/.emacs.d/org-7.4/contrib/lisp/org-expiry.el new file mode 100644 index 0000000..4a49399 --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-expiry.el @@ -0,0 +1,346 @@ +;;; org-expiry.el --- expiry mechanism for Org entries +;; +;; Copyright 2007 2008 Bastien Guerry +;; +;; Author: bzg AT altern DOT org +;; Version: 0.2 +;; Keywords: org expiry +;; URL: http://www.cognition.ens.fr/~guerry/u/org-expiry.el +;; +;; 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; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +;; +;;; 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-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 (org-mode-p) + (org-mode) + (if (interactive-p) + (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 (org-mode-p) + (org-mode) + (if (interactive-p) + (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-expiry-date'." + (let* ((ex-prop org-expiry-expiry-property-name) + (cr-prop org-expiry-created-property-name) + (ct (current-time)) + (cr (org-read-date nil t (or (org-entry-get (point) cr-prop t) "+0d"))) + (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 (interactive-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 (interactive-p) + (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) + (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 (apply 'encode-time (org-parse-time-string d)) + (current-time))) + (setq d-hour (format-time-string "%H:%M" d-time)) + (save-excursion + (org-entry-put + (point) org-expiry-created-property-name + ;; 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)))))))) + +(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 (apply 'encode-time (org-parse-time-string d)) + (current-time))) + (setq d-hour (format-time-string "%H:%M" d-time)) + (save-excursion + (org-entry-put + (point) org-expiry-expiry-property-name + (if today (format-time-string (cdr org-time-stamp-formats)) + (concat "<" (org-read-date + nil nil nil nil d-time d-hour) ">")))))) + +;;; 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 (interactive-p) + (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 (interactive-p) + (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/.emacs.d/org-7.4/contrib/lisp/org-export-generic.el b/.emacs.d/org-7.4/contrib/lisp/org-export-generic.el new file mode 100644 index 0000000..f8e8c4a --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-export-generic.el @@ -0,0 +1,1385 @@ +;; org-export-generic.el --- Export frameworg with custom backends + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; Author: Wes Hardaker <hardaker at users dot sourceforge dot net> +;; Keywords: outlines, hypermedia, calendar, wp, export +;; Homepage: http://orgmode.org +;; Version: 6.25trans +;; Acks: Much of this code was stolen form the ascii export from Carsten +;; +;; This file is not yet 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/>. +;; +;; ---------------------------------------------------------------------- +;; +;; OVERVIEW +;; +;; org-export-generic is basically a simple translation system that +;; knows how to parse at least most of a .org buffer and then add +;; various formatting prefixes before and after each section type. It +;; does this by examining a property list stored in org-generic-alist. +;; You can dynamically add propety lists of your own using the +;; org-set-generic-type function: +;; +;; (org-set-generic-type +;; "really-basic-text" +;; '(:file-suffix ".txt" +;; :key-binding ?R +;; +;; :title-format "=== %s ===\n" +;; :body-header-section-numbers t +;; :body-header-section-number-format "%s) " +;; :body-section-header-prefix "\n" +;; :body-section-header-suffix "\n" +;; :body-line-format " %s\n" +;; :body-line-wrap 75 +;; )) +;; +;; Note: Upper case key-bindings are reserved for your use. Lower +;; case key bindings may conflict with future export-generic +;; publications. +;; +;; Then run org-export (ctrl-c ctrl-e) and select generic or run +;; org-export-generic. You'll then be prompted with a list of export +;; types to choose from which will include your new type assigned to +;; the key "r". +;; +;; ---------------------------------------------------------------------- +;; +;; TODO (non-ordered) +;; * handle function references +;; * handle other types of multi-complex-listy-things to do +;; ideas: (t ?- "%s" ?-) +;; * handle indent specifiers better +;; ideas: (4 ?\ "%s") +;; * need flag to remove indents from body text +;; * handle links +;; * handle internationalization strings better +;; * date/author/etc needs improvment (internationalization too) +;; * allow specifying of section ordering +;; ideas: :ordering ("header" "toc" "body" "footer") +;; ^ matches current hard coded ordering +;; * err, actually *do* a footer +;; * deal with usage of org globals +;; *** should we even consider them, or let the per-section specifiers do it +;; *** answer: remove; mostly removed now +;; * deal with interactive support for picking a export specifier label +;; * char specifiers that need extra length because of formatting +;; idea: (?- 4) for 4-longer +;; * centering specifier +;; idea: ('center " -- %s -- ") +;; * remove more of the unneeded export-to-ascii copy code +;; * tags +;; *** supported now, but need separate format per tag +;; *** allow different open/closing prefixes +;; * properties +;; * drawers +;; * oh my +;; * optmization (many plist extracts should be in let vars) +;; * define defcustom spec for the specifier list +;; * fonts: at least monospace is not handled at all here. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +(require 'org-exp) +(require 'assoc) + +(defgroup org-export-generic nil + "Options specific for ASCII export of Org-mode files." + :tag "Org Export ASCII" + :group 'org-export) + +(defcustom org-export-generic-links-to-notes t + "Non-nil means convert links to notes before the next headline. +When nil, the link will be exported in place. If the line becomes long +in this way, it will be wrapped." + :group 'org-export-generic + :type 'boolean) + + +(defvar org-generic-current-indentation nil) ; For communication + +(defvar org-generic-alist + '( + ;; + ;; generic DEMO exporter + ;; + ;; (this tries to use every specifier for demo purposes) + ;; + ("demo" + :file-suffix ".txt" + :key-binding ?d + + :header-prefix "<header>\n" + :header-suffix "</header>\n" + + :author-export t + :tags-export t + + :drawers-export t + + + :title-prefix ?= + :title-format "<h1>%s</h1>\n" + :title-suffix ?= + + :date-export t + :date-prefix "<date>" + :date-format "<br /><b>Date:</b> <i>%s</i><br />" + :date-suffix "</date>\n\n" + + :toc-export t + :toc-header-prefix "<tocname>\n" + :toc-header-format "__%s__\n" + :toc-header-suffix "</tocname>\n" + + :toc-prefix "<toc>\n" + :toc-suffix "</toc>\n" + + :toc-section-numbers t + :toc-section-number-format "\#(%s) " + :toc-format "--%s--" + :toc-format-with-todo "!!%s!!\n" + :toc-indent-char ?\ + :toc-indent-depth 4 + + :toc-tags-export t + :toc-tags-prefix " <tags>" + :toc-tags-format "*%s*" + :toc-tags-suffix "</tags>\n" + :toc-tags-none-string "\n" + + :body-header-section-numbers 3 ; t = all, nil = none + + ; lists indicate different things per level + ; list contents or straight value can either be a + ; ?x char reference for printing strings that match the header len + ; "" string to print directly + :body-section-header-prefix ("<h1>" "<h2>" "<h3>" + "<h4>" "<h5>" "<h6>") + :body-section-header-format "%s" + :body-section-header-suffix ("</h1>\n" "</h2>\n" "</h3>\n" + "</h4>\n" "</h5>\n" "</h6>\n") + + :timestamps-export t + :priorities-export t + :todo-keywords-export t + + :body-tags-export t + :body-tags-prefix " <tags>" + :body-tags-suffix "</tags>\n" + + ; section prefixes/suffixes can be direct strings or lists as well + :body-section-prefix "<secprefix>\n" + :body-section-suffix "</secsuffix>\n" +; :body-section-prefix ("<sec1>\n" "<sec2>\n" "<sec3>\n") +; :body-section-suffix ("</sec1>\n" "</sec2>\n" "</sec3>\n") + + + ; if preformated text should be included (eg, : prefixed) + :body-line-export-preformated t + :body-line-fixed-prefix "<pre>\n" + :body-line-fixed-suffix "\n</pre>\n" + :body-line-fixed-format "%s\n" + + + :body-list-prefix "<list>\n" + :body-list-suffix "</list>\n" + :body-list-format "<li>%s</li>\n" + + :body-number-list-prefix "<ol>\n" + :body-number-list-suffix "</ol>\n" + :body-number-list-format "<li>%s</li>\n" + :body-number-list-leave-number t + + :body-list-checkbox-todo "<checkbox type=\"todo\">" + :body-list-checkbox-todo-end "</checkbox (todo)>" + :body-list-checkbox-done "<checkbox type=\"done\">" + :body-list-checkbox-done-end "</checkbox (done)>" + :body-list-checkbox-half "<checkbox type=\"half\">" + :body-list-checkbox-half-end "</checkbox (half)>" + + + + + ; other body lines + :body-line-format "%s" + :body-line-wrap 60 ; wrap at 60 chars + + ; print above and below all body parts + :body-text-prefix "<p>\n" + :body-text-suffix "</p>\n" + + ) + + ;; + ;; ascii exporter + ;; + ;; (close to the original ascii specifier) + ;; + ("ascii" + :file-suffix ".txt" + :key-binding ?a + + :header-prefix "" + :header-suffix "" + + :title-prefix ?= + :title-format "%s\n" + :title-suffix ?= + + :date-export t + :date-prefix "" + :date-format "Date: %s\n" + :date-suffix "" + + :toc-header-prefix "" + :toc-header-format "%s\n" + :toc-header-suffix ?= + + :toc-export t + :toc-section-numbers t + :toc-section-number-format "%s " + :toc-format "%s\n" + :toc-format-with-todo "%s (*)\n" + :toc-indent-char ?\ + :toc-indent-depth 4 + + :body-header-section-numbers 3 + :body-section-prefix "\n" + +; :body-section-header-prefix "\n" +; :body-section-header-format "%s\n" +; :body-section-header-suffix (?\$ ?\# ?^ ?\~ ?\= ?\-) + + :body-section-header-prefix ("" "" "" "* " " + " " - ") + :body-section-header-format "%s\n" + :body-section-header-suffix (?~ ?= ?- "\n" "\n" "\n") + +; :body-section-marker-prefix "" +; :body-section-marker-chars (?\$ ?\# ?^ ?\~ ?\= ?\-) +; :body-section-marker-suffix "\n" + + :body-line-export-preformated t + :body-line-format "%s\n" + :body-line-wrap 75 + +; :body-text-prefix "<t>\n" +; :body-text-suffix "</t>\n" + + + :body-bullet-list-prefix (?* ?+ ?-) +; :body-bullet-list-suffix (?* ?+ ?-) + ) + + ;; + ;; wikipedia + ;; + ("wikipedia" + :file-suffix ".txt" + :key-binding ?w + + :header-prefix "" + :header-suffix "" + + :title-format "= %s =\n" + + :date-export nil + + :toc-export nil + + :body-header-section-numbers nil + :body-section-prefix "\n" + + :body-section-header-prefix ("= " "== " "=== " + "==== " "===== " "====== ") + :body-section-header-suffix (" =\n\n" " ==\n\n" " ===\n\n" + " ====\n\n" " =====\n\n" " ======\n\n") + + :body-line-export-preformated t ;; yes/no/maybe??? + :body-line-format "%s\n" + :body-line-wrap 75 + + :body-line-fixed-format " %s\n" + + :body-list-format "* %s\n" + :body-number-list-format "# %s\n" + + :body-bullet-list-prefix ("* " "** " "*** " "**** " "***** ") + ) + + ;; + ;; minimal html exporter + ;; + ("html" + ;; simple html output + :file-suffix ".html" + :key-binding ?h + + :header-prefix "<body>" + + :title-format "<h1>%s</h1>\n\n" + + :date-export t + :date-format "<br /><b>Date:</b> <i>%s</i><br />\n\n" + + :toc-export nil + + :body-header-section-numbers 3 + + :body-section-header-prefix ("<h1>" "<h2>" "<h3>" + "<h4>" "<h5>" "<h6>") + :body-section-header-format "%s" + :body-section-header-suffix ("</h1>\n" "</h2>\n" "</h3>\n" + "</h4>\n" "</h5>\n" "</h6>\n") + + :body-section-prefix "<secprefix>\n" + :body-section-suffix "</secsuffix>\n" +; :body-section-prefix ("<sec1>\n" "<sec2>\n" "<sec3>\n") +; :body-section-suffix ("</sec1>\n" "</sec2>\n" "</sec3>\n") + + :body-line-export-preformated t + :body-line-format "%s\n" + + :body-text-prefix "<p>\n" + :body-text-suffix "</p>\n" + + :body-bullet-list-prefix (?* ?+ ?-) +; :body-bullet-list-suffix (?* ?+ ?-) + ) + + ;; + ;; internet-draft .xml for xml2rfc exporter + ;; + ("ietfid" + ;; this tries to use every specifier for demo purposes + :file-suffix ".xml" + :key-binding ?i + + :title-prefix "<?xml version=\"1.0\"\?> +<!DOCTYPE rfc SYSTEM \"rfc2629.dtd\" [ +<!ENTITY rfcs PUBLIC '' 'blah'> +<?rfc strict=\"yes\" ?> +<?rfc toc=\"yes\" ?> +<?rfc tocdepth=\"4\" ?> +<?rfc symrefs=\"yes\" ?> +<?rfc compact=\"yes\" ?> +<?rfc subcompact=\"no\" ?> +<rfc category=\"std\" ipr=\"pre5378Trust200902\" docName=\"FILLME.txt\"> + <front> +" + :title-format "<title abbrev=\"ABBREV HERE\">\n%s\n</title>\n" + :title-suffix "<author initials=\"A.A\" surname=\"LASTNAME\" fullname=\"FULL NAME\"> + <organization>Comany, Inc..</organization> + <address> + <postal> + <street></street> + <city></city> + <region></region> + <code></code> + <country></country> + </postal> + <phone></phone> + <email></email> + </address> + </author> + <date month=\"FILLMONTH\" year=\"FILLYEAR\"/> + <area>Operations and Management</area> + <workgroup>FIXME</workgroup> +<abstract>\n" + :date-export nil + + :toc-export nil + + :body-header-section-numbers nil + + :body-section-header-format "<section title=\"%s\">\n" + :body-section-suffix "</section>\n" + + ; if preformated text should be included (eg, : prefixed) + :body-line-export-preformated t + :body-line-fixed-prefix "<figure>\n<artwork>\n" + :body-line-fixed-suffix "\n</artwork>\n</figure>\n" + + ; other body lines + :body-line-format "%s" + :body-line-wrap 75 + + ; print above and below all body parts + :body-text-prefix "<t>\n" + :body-text-suffix "</t>\n" + + :body-list-prefix "<list style=\"symbols\">\n" + :body-list-suffix "</list>\n" + :body-list-format "<t>%s</t>\n" + + ) + ) + "A assoc list of property lists to specify export definitions" +) + +(setq org-generic-export-type "demo") + +(defvar org-export-generic-section-type "") +(defvar org-export-generic-section-suffix "") + +;;;###autoload +(defun org-set-generic-type (type definition) + "Adds a TYPE and DEFINITION to the existing list of defined generic +export definitions." + (aput 'org-generic-alist type definition)) + +;;; helper functions for org-set-generic-type +(defvar org-export-generic-keywords nil) +(defmacro* def-org-export-generic-keyword (keyword + &key documentation + type) + "Define KEYWORD as a legitimate element for inclusion in +the body of an org-set-generic-type definition." + `(progn + (pushnew ,keyword org-export-generic-keywords) + ;; TODO: push the documentation and type information + ;; somewhere where it will do us some good. + )) + +(def-org-export-generic-keyword :body-newline-paragraph + :documentation "Bound either to NIL or to a pattern to be +inserted in the output for every blank line in the input. + The intention is to handle formats where text is flowed, and +newlines are interpreted as significant \(e.g., as indicating +preformatted text\). A common non-nil value for this keyword +is \"\\n\". Should typically be combined with a value for +:body-line-format that does NOT end with a newline." + :type string) + +;;; fontification keywords +(def-org-export-generic-keyword :bold-format) +(def-org-export-generic-keyword :italic-format) +(def-org-export-generic-keyword :underline-format) +(def-org-export-generic-keyword :strikethrough-format) +(def-org-export-generic-keyword :code-format) +(def-org-export-generic-keyword :verbatim-format) + + + + +(defun org-export-generic-remember-section (type suffix &optional prefix) + (setq org-export-generic-section-type type) + (setq org-export-generic-section-suffix suffix) + (if prefix + (insert prefix)) +) + +(defun org-export-generic-check-section (type &optional prefix suffix) + "checks to see if type is already in use, or we're switching parts +If we're switching, then insert a potentially previously remembered +suffix, and insert the current prefix immediately and then save the +suffix a later change time." + + (when (not (equal type org-export-generic-section-type)) + (if org-export-generic-section-suffix + (insert org-export-generic-section-suffix)) + (setq org-export-generic-section-type type) + (setq org-export-generic-section-suffix suffix) + (if prefix + (insert prefix)))) + +;;;###autoload +(defun org-export-generic (arg) + "Export the outline as generic output. +If there is an active region, export only the region. +The prefix ARG specifies how many levels of the outline should become +underlined headlines. The default is 3." + (interactive "P") + (setq-default org-todo-line-regexp org-todo-line-regexp) + (let* ((opt-plist (org-combine-plists (org-default-export-plist) + (org-infile-export-plist))) + (region-p (org-region-active-p)) + (rbeg (and region-p (region-beginning))) + (rend (and region-p (region-end))) + (subtree-p + (when region-p + (save-excursion + (goto-char rbeg) + (and (org-at-heading-p) + (>= (org-end-of-subtree t t) rend))))) + (level-offset (if subtree-p + (save-excursion + (goto-char rbeg) + (+ (funcall outline-level) + (if org-odd-levels-only 1 0))) + 0)) + (opt-plist (setq org-export-opt-plist + (if subtree-p + (org-export-add-subtree-options opt-plist rbeg) + opt-plist))) + + helpstart + (bogus (mapc (lambda (x) + (setq helpstart + (concat helpstart "\[" + (char-to-string + (plist-get (cdr x) :key-binding)) + "] " (car x) "\n"))) + org-generic-alist)) + + (help (concat helpstart " + +\[ ] the current setting of the org-generic-export-type variable +")) + + (cmds + + (append + (mapcar (lambda (x) + (list + (plist-get (cdr x) :key-binding) + (car x))) + org-generic-alist) + (list (list ? "default")))) + + r1 r2 ass + + ;; read in the type to use + (export-plist + (progn + (save-excursion + (save-window-excursion + (delete-other-windows) + (with-output-to-temp-buffer "*Org Export/Generic Styles Help*" + (princ help)) + (org-fit-window-to-buffer (get-buffer-window + "*Org Export/Generic Styles Help*")) + (message "Select command: ") + (setq r1 (read-char-exclusive)))) + (setq r2 (if (< r1 27) (+ r1 96) r1)) + (unless (setq ass (cadr (assq r2 cmds))) + (error "No command associated with key %c" r1)) + + (cdr (assoc + (if (equal ass "default") org-generic-export-type ass) + org-generic-alist)))) + + (custom-times org-display-custom-times) + (org-generic-current-indentation '(0 . 0)) + (level 0) (old-level 0) line txt lastwastext + (umax nil) + (umax-toc nil) + (case-fold-search nil) + (bfname (buffer-file-name (or (buffer-base-buffer) (current-buffer)))) + (filesuffix (or (plist-get export-plist :file-suffix) ".foo")) + (filename (concat (file-name-as-directory + (org-export-directory :ascii opt-plist)) + (file-name-sans-extension + (or (and subtree-p + (org-entry-get (region-beginning) + "EXPORT_FILE_NAME" t)) + (file-name-nondirectory bfname))) + filesuffix)) + (filename (if (equal (file-truename filename) + (file-truename bfname)) + (concat filename filesuffix) + filename)) + (buffer (find-file-noselect filename)) + (org-levels-open (make-vector org-level-max nil)) + (odd org-odd-levels-only) + (date (plist-get opt-plist :date)) + (author (plist-get opt-plist :author)) + (title (or (and subtree-p (org-export-get-title-from-subtree)) + (plist-get opt-plist :title) + (and (not + (plist-get opt-plist :skip-before-1st-heading)) + (org-export-grab-title-from-buffer)) + (file-name-sans-extension + (file-name-nondirectory bfname)))) + (email (plist-get opt-plist :email)) + (language (plist-get opt-plist :language)) + (quote-re0 (concat "^[ \t]*" org-quote-string "\\>")) +; (quote-re (concat "^\\(\\*+\\)\\([ \t]*" org-quote-string "\\>\\)")) + (todo nil) + (lang-words nil) + (region + (buffer-substring + (if (org-region-active-p) (region-beginning) (point-min)) + (if (org-region-active-p) (region-end) (point-max)))) + (lines (org-split-string + (org-export-preprocess-string + region + :for-ascii t + :skip-before-1st-heading + (plist-get opt-plist :skip-before-1st-heading) + :drawers (plist-get export-plist :drawers-export) + :tags (plist-get export-plist :tags-export) + :priority (plist-get export-plist :priority-export) + :footnotes (plist-get export-plist :footnotes-export) + :timestamps (plist-get export-plist :timestamps-export) + :todo-keywords (plist-get export-plist :todo-keywords-export) + :verbatim-multiline t + :select-tags (plist-get export-plist :select-tags-export) + :exclude-tags (plist-get export-plist :exclude-tags-export) + :emph-multiline t + :archived-trees + (plist-get export-plist :archived-trees-export) + :add-text (plist-get opt-plist :text)) + "\n")) + ;; export-generic plist variables + (withtags (plist-get export-plist :tags-export)) + (tagsintoc (plist-get export-plist :toc-tags-export)) + (tocnotagsstr (or (plist-get export-plist :toc-tags-none-string) "")) + (tocdepth (plist-get export-plist :toc-indent-depth)) + (tocindentchar (plist-get export-plist :toc-indent-char)) + (tocsecnums (plist-get export-plist :toc-section-numbers)) + (tocsecnumform (plist-get export-plist :toc-section-number-format)) + (tocformat (plist-get export-plist :toc-format)) + (tocformtodo (plist-get export-plist :toc-format-with-todo)) + (tocprefix (plist-get export-plist :toc-prefix)) + (tocsuffix (plist-get export-plist :toc-suffix)) + (bodyfixedpre (plist-get export-plist :body-line-fixed-prefix)) + (bodyfixedsuf (plist-get export-plist :body-line-fixed-suffix)) + (bodyfixedform (or (plist-get export-plist :body-line-fixed-format) + "%s")) + (listprefix (plist-get export-plist :body-list-prefix)) + (listsuffix (plist-get export-plist :body-list-suffix)) + (listformat (or (plist-get export-plist :body-list-format) "%s\n")) + (numlistleavenum + (plist-get export-plist :body-number-list-leave-number)) + (numlistprefix (plist-get export-plist :body-number-list-prefix)) + (numlistsuffix (plist-get export-plist :body-number-list-suffix)) + (numlistformat + (or (plist-get export-plist :body-number-list-format) "%s\n")) + (listchecktodo + (or (plist-get export-plist :body-list-checkbox-todo) "\\1")) + (listcheckdone + (or (plist-get export-plist :body-list-checkbox-done) "\\1")) + (listcheckhalf + (or (plist-get export-plist :body-list-checkbox-half) "\\1")) + (listchecktodoend + (or (plist-get export-plist :body-list-checkbox-todo-end) "")) + (listcheckdoneend + (or (plist-get export-plist :body-list-checkbox-done-end) "")) + (listcheckhalfend + (or (plist-get export-plist :body-list-checkbox-half-end) "")) + (bodynewline-paragraph (plist-get export-plist :body-newline-paragraph)) + (bodytextpre (plist-get export-plist :body-text-prefix)) + (bodytextsuf (plist-get export-plist :body-text-suffix)) + (bodylinewrap (plist-get export-plist :body-line-wrap)) + (bodylineform (or (plist-get export-plist :body-line-format) "%s")) + (blockquotestart (or (plist-get export-plist :blockquote-start) "\n\n\t")) + (blockquoteend (or (plist-get export-plist :blockquote-end) "\n\n")) + + ;; dynamic variables used heinously in fontification + ;; not referenced locally... + (format-boldify (plist-get export-plist :bold-format)) + (format-italicize (plist-get export-plist :italic-format)) + (format-underline (plist-get export-plist :underline-format)) + (format-strikethrough (plist-get export-plist :strikethrough-format)) + (format-code (plist-get export-plist :code-format)) + (format-verbatim (plist-get export-plist :verbatim-format)) + + + + thetoc toctags have-headings first-heading-pos + table-open table-buffer link-buffer link desc desc0 rpl wrap) + + (let ((inhibit-read-only t)) + (org-unmodified + (remove-text-properties (point-min) (point-max) + '(:org-license-to-kill t)))) + + (setq org-min-level (org-get-min-level lines level-offset)) + (setq org-last-level org-min-level) + (org-init-section-numbers) + + (find-file-noselect filename) + + (setq lang-words (or (assoc language org-export-language-setup) + (assoc "en" org-export-language-setup))) + (switch-to-buffer-other-window buffer) + (erase-buffer) + (fundamental-mode) + ;; create local variables for all options, to make sure all called + ;; functions get the correct information + (mapc (lambda (x) + (set (make-local-variable (nth 2 x)) + (plist-get opt-plist (car x)))) + org-export-plist-vars) + (org-set-local 'org-odd-levels-only odd) + (setq umax (if arg (prefix-numeric-value arg) + org-export-headline-levels)) + (setq umax-toc umax) + + ;; File header + (if title + (insert + (org-export-generic-header title export-plist + :title-prefix + :title-format + :title-suffix))) + + (if (and (or author email) + (plist-get export-plist :author-export)) + (insert (concat (nth 1 lang-words) ": " (or author "") + (if email (concat " <" email ">") "") + "\n"))) + + (cond + ((and date (string-match "%" date)) + (setq date (format-time-string date))) + (date) + (t (setq date (format-time-string "%Y-%m-%d %T %Z")))) + + (if (and date (plist-get export-plist :date-export)) + (insert + (org-export-generic-header date export-plist + :date-prefix + :date-format + :date-suffix))) + + ;; export the table of contents first + (if (plist-get export-plist :toc-export) + (progn + (push + (org-export-generic-header (nth 3 lang-words) export-plist + :toc-header-prefix + :toc-header-format + :toc-header-suffix) + thetoc) + + (if tocprefix + (push tocprefix thetoc)) + + (mapc '(lambda (line) + (if (string-match org-todo-line-regexp line) + ;; This is a headline + (progn + (setq have-headings t) + (setq level (- (match-end 1) (match-beginning 1) + level-offset) + level (org-tr-level level) + txt (match-string 3 line) + todo + (or (and org-export-mark-todo-in-toc + (match-beginning 2) + (not (member (match-string 2 line) + org-done-keywords))) + ; TODO, not DONE + (and org-export-mark-todo-in-toc + (= level umax-toc) + (org-search-todo-below + line lines level)))) + (setq txt (org-html-expand-for-generic txt)) + + (while (string-match org-bracket-link-regexp txt) + (setq txt + (replace-match + (match-string (if (match-end 2) 3 1) txt) + t t txt))) + + (if (and (not tagsintoc) + (string-match + (org-re "[ \t]+:[[:alnum:]_@:]+:[ \t]*$") + txt)) + (setq txt (replace-match "" t t txt)) + ; include tags but formated + (if (string-match + (org-re "[ \t]+:\\([[:alnum:]_@:]+\\):[ \t]*$") + txt) + (progn + (setq + toctags + (org-export-generic-header + (match-string 1 txt) + export-plist :toc-tags-prefix + :toc-tags-format :toc-tags-suffix)) + (string-match + (org-re "[ \t]+:[[:alnum:]_@:]+:[ \t]*$") + txt) + (setq txt (replace-match "" t t txt))) + (setq toctags tocnotagsstr))) + + (if (string-match quote-re0 txt) + (setq txt (replace-match "" t t txt))) + + (if (<= level umax-toc) + (progn + (push + (concat + + (make-string + (* (max 0 (- level org-min-level)) tocdepth) + tocindentchar) + + (if tocsecnums + (format tocsecnumform + (org-section-number level)) + "") + + (format + (if todo tocformtodo tocformat) + txt) + + toctags) + + thetoc) + (setq org-last-level level)) + )))) + lines) + (if tocsuffix + (push tocsuffix thetoc)) + (setq thetoc (if have-headings (nreverse thetoc) nil)))) + + (org-init-section-numbers) + (org-export-generic-check-section "top") + (while (setq line (pop lines)) + (when (and link-buffer (string-match "^\\*+ " line)) + (org-export-generic-push-links (nreverse link-buffer)) + (setq link-buffer nil)) + (setq wrap nil) + ;; Remove the quoted HTML tags. + ;; XXX + (setq line (org-html-expand-for-generic line)) + ;; Replace links with the description when possible + ;; XXX + (while (string-match org-bracket-link-regexp line) + (setq link (match-string 1 line) + desc0 (match-string 3 line) + desc (or desc0 (match-string 1 line))) + (if (and (> (length link) 8) + (equal (substring link 0 8) "coderef:")) + (setq line (replace-match + (format (org-export-get-coderef-format (substring link 8) desc) + (cdr (assoc + (substring link 8) + org-export-code-refs))) + t t line)) + (setq rpl (concat "[" + (or (match-string 3 line) (match-string 1 line)) + "]")) + (when (and desc0 (not (equal desc0 link))) + (if org-export-generic-links-to-notes + (push (cons desc0 link) link-buffer) + (setq rpl (concat rpl " (" link ")") + wrap (+ (length line) (- (length (match-string 0 line))) + (length desc))))) + (setq line (replace-match rpl t t line)))) + (when custom-times + (setq line (org-translate-time line))) + (cond + ((string-match "^\\(\\*+\\)[ \t]+\\(.*\\)" line) + ;; + ;; a Headline + ;; + (org-export-generic-check-section "headline") + + (setq first-heading-pos (or first-heading-pos (point))) + (setq level (org-tr-level (- (match-end 1) (match-beginning 1) + level-offset)) + txt (match-string 2 line)) + (org-generic-level-start level old-level txt umax export-plist lines) + (setq old-level level)) + + ((and org-export-with-tables + (string-match "^\\([ \t]*\\)\\(|\\|\\+-+\\+\\)" line)) + ;; + ;; a Table + ;; + (org-export-generic-check-section "table") + + (if (not table-open) + ;; New table starts + (setq table-open t table-buffer nil)) + ;; Accumulate table lines + (setq table-buffer (cons line table-buffer)) + (when (or (not lines) + (not (string-match "^\\([ \t]*\\)\\(|\\|\\+-+\\+\\)" + (car lines)))) + (setq table-open nil + table-buffer (nreverse table-buffer)) + (insert (mapconcat + (lambda (x) + (org-fix-indentation x org-generic-current-indentation)) + (org-format-table-generic table-buffer) + "\n") "\n"))) + + ((string-match "^\\([ \t]*\\)\\(:\\( \\|$\\)\\)" line) + ;; + ;; pre-formatted text + ;; + (setq line (replace-match "\\1" nil nil line)) + + (org-export-generic-check-section "preformat" bodyfixedpre bodyfixedsuf) + + (insert (format bodyfixedform line))) + + ((or (string-match "^\\([ \t]*\\)\\([\-\+][ \t]*\\)" line) + ;; if the bullet list item is an asterisk, the leading space is /mandatory/ + ;; [2010/02/02:rpg] + (string-match "^\\([ \t]+\\)\\(\\*[ \t]*\\)" line)) + ;; + ;; plain list item + ;; TODO: nested lists + ;; + ;; first add a line break between any previous paragraph or line item and this + ;; one + (when bodynewline-paragraph + (insert bodynewline-paragraph)) + + ;; I believe this gets rid of leading whitespace. + (setq line (replace-match "" nil nil line)) + + ;; won't this insert the suffix /before/ the last line of the list? + ;; also isn't it spoofed by bulleted lists that have a line skip between the list items + ;; unless 'org-empty-line-terminates-plain-lists' is true? + (org-export-generic-check-section "liststart" listprefix listsuffix) + + ;; deal with checkboxes + (cond + ((string-match "^\\(\\[ \\]\\)[ \t]*" line) + (setq line (concat (replace-match listchecktodo nil nil line) + listchecktodoend))) + ((string-match "^\\(\\[X\\]\\)[ \t]*" line) + (setq line (concat (replace-match listcheckdone nil nil line) + listcheckdoneend))) + ((string-match "^\\(\\[/\\]\\)[ \t]*" line) + (setq line (concat (replace-match listcheckhalf nil nil line) + listcheckhalfend))) + ) + + (insert (format listformat (org-export-generic-fontify line)))) + ((string-match "^\\([ \t]+\\)\\([0-9]+\\.[ \t]*\\)" line) + ;; + ;; numbered list item + ;; + ;; TODO: nested lists + ;; + (setq line (replace-match (if numlistleavenum "\\2" "") nil nil line)) + + (org-export-generic-check-section "numliststart" + numlistprefix numlistsuffix) + + ;; deal with checkboxes + ;; TODO: whoops; leaving the numbers is a problem for ^ matching + (cond + ((string-match "\\(\\[ \\]\\)[ \t]*" line) + (setq line (concat (replace-match listchecktodo nil nil line) + listchecktodoend))) + ((string-match "\\(\\[X\\]\\)[ \t]*" line) + (setq line (concat (replace-match listcheckdone nil nil line) + listcheckdoneend))) + ((string-match "\\(\\[/\\]\\)[ \t]*" line) + (setq line (concat (replace-match listcheckhalf nil nil line) + listcheckhalfend))) + ) + + (insert (format numlistformat (org-export-generic-fontify line)))) + + ((equal line "ORG-BLOCKQUOTE-START") + (setq line blockquotestart)) + ((equal line "ORG-BLOCKQUOTE-END") + (setq line blockquoteend)) + ((string-match "^\\s-*$" line) + ;; blank line + (if bodynewline-paragraph + (insert bodynewline-paragraph))) + (t + ;; + ;; body + ;; + (org-export-generic-check-section "body" bodytextpre bodytextsuf) + + (setq line + (org-export-generic-fontify line)) + + ;; XXX: properties? list? + (if (string-match "^\\([ \t]*\\)\\([-+*][ \t]+\\)\\(.*?\\)\\( ::\\)" line) + (setq line (replace-match "\\1\\3:" t nil line))) + + (setq line (org-fix-indentation line org-generic-current-indentation)) + + ;; Remove forced line breaks + (if (string-match "\\\\\\\\[ \t]*$" line) + (setq line (replace-match "" t t line))) + + (if bodylinewrap + ;; XXX: was dependent on wrap var which was calculated by??? + (if (> (length line) bodylinewrap) + (setq line + (org-export-generic-wrap line bodylinewrap)) + (setq line line))) + (insert (format bodylineform line))))) + + ;; if we're at a level > 0; insert the closing body level stuff + (let ((counter 0)) + (while (> (- level counter) 0) + (insert + (org-export-generic-format export-plist :body-section-suffix 0 + (- level counter))) + (setq counter (1+ counter)))) + + (org-export-generic-check-section "bottom") + + (org-export-generic-push-links (nreverse link-buffer)) + + (normal-mode) + + ;; insert the table of contents + (when thetoc + (goto-char (point-min)) + (if (re-search-forward "^[ \t]*\\[TABLE-OF-CONTENTS\\][ \t]*$" nil t) + (progn + (goto-char (match-beginning 0)) + (replace-match "")) + (goto-char first-heading-pos)) + (mapc 'insert thetoc) + (or (looking-at "[ \t]*\n[ \t]*\n") + (insert "\n\n"))) + + ;; Convert whitespace place holders + (goto-char (point-min)) + (let (beg end) + (while (setq beg (next-single-property-change (point) 'org-whitespace)) + (setq end (next-single-property-change beg 'org-whitespace)) + (goto-char beg) + (delete-region beg end) + (insert (make-string (- end beg) ?\ )))) + + (save-buffer) + + ;; remove display and invisible chars + (let (beg end) + (goto-char (point-min)) + (while (setq beg (next-single-property-change (point) 'display)) + (setq end (next-single-property-change beg 'display)) + (delete-region beg end) + (goto-char beg) + (insert "=>")) + (goto-char (point-min)) + (while (setq beg (next-single-property-change (point) 'org-cwidth)) + (setq end (next-single-property-change beg 'org-cwidth)) + (delete-region beg end) + (goto-char beg))) + (goto-char (point-min)))) + + +(defun org-export-generic-format (export-plist prop &optional len n reverse) + "converts a property specification to a string given types of properties + +The EXPORT-PLIST should be defined as the lookup plist. +The PROP should be the property name to search for in it. +LEN is set to the length of multi-characters strings to generate (or 0) +N is the tree depth +REVERSE means to reverse the list if the plist match is a list + " + (let* ((prefixtype (plist-get export-plist prop)) + subtype) + (cond + ((null prefixtype) "") + ((and len (char-or-string-p prefixtype) (not (stringp prefixtype))) + ;; sequence of chars + (concat (make-string len prefixtype) "\n")) + ((stringp prefixtype) + prefixtype) + ((and n (listp prefixtype)) + (if reverse + (setq prefixtype (reverse prefixtype))) + (setq subtype (if (> n (length prefixtype)) + (car (last prefixtype)) + (nth (1- n) prefixtype))) + (if (stringp subtype) + subtype + (concat (make-string len subtype) "\n"))) + (t "")) + )) + +(defun org-export-generic-header (header export-plist + prefixprop formatprop postfixprop + &optional n reverse) + "convert a header to an output string given formatting property names" + (let* ((formatspec (plist-get export-plist formatprop)) + (len (length header))) + (concat + (org-export-generic-format export-plist prefixprop len n reverse) + (format (or formatspec "%s") header) + (org-export-generic-format export-plist postfixprop len n reverse)) + )) + +(defun org-export-generic-preprocess (parameters) + "Do extra work for ASCII export" + ;; Put quotes around verbatim text + (goto-char (point-min)) + (while (re-search-forward org-verbatim-re nil t) + (goto-char (match-end 2)) + (backward-delete-char 1) (insert "'") + (goto-char (match-beginning 2)) + (delete-char 1) (insert "`") + (goto-char (match-end 2))) + ;; Remove target markers + (goto-char (point-min)) + (while (re-search-forward "<<<?\\([^<>]*\\)>>>?\\([ \t]*\\)" nil t) + (replace-match "\\1\\2"))) + +(defun org-html-expand-for-generic (line) + "Handle quoted HTML for ASCII export." + (if org-export-html-expand + (while (string-match "@<[^<>\n]*>" line) + ;; We just remove the tags for now. + (setq line (replace-match "" nil nil line)))) + line) + +(defun org-export-generic-wrap (line where) + "Wrap LINE at or before WHERE." + (let* ((ind (org-get-indentation line)) + (indstr (make-string ind ?\ )) + (len (length line)) + (result "") + pos didfirst) + (while (> len where) + (catch 'found + (loop for i from where downto (/ where 2) do + (and (equal (aref line i) ?\ ) + (setq pos i) + (throw 'found t)))) + (if pos + (progn + (setq result + (concat result + (if didfirst indstr "") + (substring line 0 pos) + "\n")) + (setq didfirst t) + (setq line (substring line (1+ pos))) + (setq len (length line))) + (setq result (concat result line)) + (setq len 0))) + (concat result indstr line))) + +(defun org-export-generic-push-links (link-buffer) + "Push out links in the buffer." + (when link-buffer + ;; We still have links to push out. + (insert "\n") + (let ((ind "")) + (save-match-data + (if (save-excursion + (re-search-backward + "^\\(\\([ \t]*\\)\\|\\(\\*+ \\)\\)[^ \t\n]" nil t)) + (setq ind (or (match-string 2) + (make-string (length (match-string 3)) ?\ ))))) + (mapc (lambda (x) (insert ind "[" (car x) "]: " (cdr x) "\n")) + link-buffer)) + (insert "\n"))) + +(defun org-generic-level-start (level old-level title umax export-plist + &optional lines) + "Insert a new level in a generic export." + (let ((n (- level umax 1)) + (ind 0) + (diff (- level old-level)) (counter 0) + (secnums (plist-get export-plist :body-header-section-numbers)) + (secnumformat + (plist-get export-plist :body-header-section-number-format)) + char tagstring) + (unless org-export-with-tags + (if (string-match (org-re "[ \t]+\\(:[[:alnum:]_@:]+:\\)[ \t]*$") title) + (setq title (replace-match "" t t title)))) + + (cond + ;; going deeper + ((> level old-level) + (while (< (+ old-level counter) (1- level)) + (insert + (org-export-generic-format export-plist :body-section-prefix 0 + (+ old-level counter))) + (setq counter (1+ counter)) + )) + ;; going up + ((< level old-level) + (while (> (- old-level counter) (1- level)) + (insert + (org-export-generic-format export-plist :body-section-suffix 0 + (- old-level counter))) + (setq counter (1+ counter)) + )) + ;; same level + ((= level old-level) + (insert + (org-export-generic-format export-plist :body-section-suffix 0 level)) + ) + ) + (insert + (org-export-generic-format export-plist :body-section-prefix 0 level)) + + (if (and org-export-with-section-numbers + secnums + (or (not (numberp secnums)) + (< level secnums))) + (setq title + (concat (format (or secnumformat "%s ") + (org-section-number level)) title))) + + ;; handle tags and formatting + (if (string-match + (org-re "[ \t]+:\\([[:alnum:]_@:]+\\):[ \t]*$") title) + (progn + (if (plist-get export-plist :body-tags-export) + (setq tagstring (org-export-generic-header (match-string 1 title) + export-plist + :body-tags-prefix + :body-tags-format + :body-tags-suffix))) + (string-match (org-re "[ \t]+:[[:alnum:]_@:]+:[ \t]*$") title) + (setq title (replace-match "" t t title))) + (setq tagstring (plist-get export-plist :body-tags-none-string))) + + (insert + (org-export-generic-header title export-plist + :body-section-header-prefix + :body-section-header-format + :body-section-header-suffix + level)) + (if tagstring + (insert tagstring)) + + (setq org-generic-current-indentation '(0 . 0)))) + +(defun org-insert-centered (s &optional underline) + "Insert the string S centered and underline it with character UNDERLINE." + (let ((ind (max (/ (- fill-column (string-width s)) 2) 0))) + (insert (make-string ind ?\ ) s "\n") + (if underline + (insert (make-string ind ?\ ) + (make-string (string-width s) underline) + "\n")))) + +(defvar org-table-colgroup-info nil) +(defun org-format-table-generic (lines) + "Format a table for ascii export." + (if (stringp lines) + (setq lines (org-split-string lines "\n"))) + (if (not (string-match "^[ \t]*|" (car lines))) + ;; Table made by table.el - test for spanning + lines + + ;; A normal org table + ;; Get rid of hlines at beginning and end + (if (string-match "^[ \t]*|-" (car lines)) (setq lines (cdr lines))) + (setq lines (nreverse lines)) + (if (string-match "^[ \t]*|-" (car lines)) (setq lines (cdr lines))) + (setq lines (nreverse lines)) + (when org-export-table-remove-special-lines + ;; Check if the table has a marking column. If yes remove the + ;; column and the special lines + (setq lines (org-table-clean-before-export lines))) + ;; Get rid of the vertical lines except for grouping + (let ((vl (org-colgroup-info-to-vline-list org-table-colgroup-info)) + rtn line vl1 start) + (while (setq line (pop lines)) + (if (string-match org-table-hline-regexp line) + (and (string-match "|\\(.*\\)|" line) + (setq line (replace-match " \\1" t nil line))) + (setq start 0 vl1 vl) + (while (string-match "|" line start) + (setq start (match-end 0)) + (or (pop vl1) (setq line (replace-match " " t t line))))) + (push line rtn)) + (nreverse rtn)))) + +(defun org-colgroup-info-to-vline-list (info) + (let (vl new last) + (while info + (setq last new new (pop info)) + (if (or (memq last '(:end :startend)) + (memq new '(:start :startend))) + (push t vl) + (push nil vl))) + (setq vl (nreverse vl)) + (and vl (setcar vl nil)) + vl)) + + +;;; FIXME: this should probably turn into a defconstant later [2010/05/20:rpg] +(defvar org-export-generic-emphasis-alist + '(("*" format-boldify nil) + ("/" format-italicize nil) + ("_" format-underline nil) + ("+" format-strikethrough nil) + ("=" format-code t) + ("~" format-verbatim t)) + "Alist of org format -> formatting variables for fontification. +Each element of the list is a list of three elements. +The first element is the character used as a marker for fontification. +The second element is a variable name, set in org-export-generic. That +variable will be dereferenced to obtain a formatting string to wrap +fontified text with. +The third element decides whether to protect converted text from other +conversions.") + +;;; Cargo-culted from the latex translation. I couldn't figure out how +;;; to keep the structure since the generic export operates on lines, rather +;;; than on a buffer as in the latex export, meaning that none of the +;;; search forward code could be kept. This led me to rewrite the +;;; whole thing recursively. A huge lose for efficiency (potentially), +;;; but I couldn't figure out how to make the looping work. +;;; Worse, it's /doubly/ recursive, because this function calls +;;; org-export-generic-emph-format, which can call it recursively... +;;; [2010/05/20:rpg] +(defun org-export-generic-fontify (string) + "Convert fontification according to generic rules." + (if (string-match org-emph-re string) + ;; The match goes one char after the *string*, except at the end of a line + (let ((emph (assoc (match-string 3 string) + org-export-generic-emphasis-alist)) + (beg (match-beginning 0)) + (end (match-end 0))) + (unless emph + (message "`org-export-generic-emphasis-alist' has no entry for formatting triggered by \"%s\"" + (match-string 3 string))) + ;; now we need to determine whether we have strikethrough or + ;; a list, which is a bit nasty + (if (and (equal (match-string 3 string) "+") + (save-match-data + (string-match "\\`-+\\'" (match-string 4 string)))) + ;; a list --- skip this match and recurse on the point after the + ;; first emph char... + (concat (substring string 0 (1+ (match-beginning 3))) + (org-export-generic-fontify (substring string (match-beginning 3)))) + (concat (substring string 0 beg) ;; part before the match + (match-string 1 string) + (org-export-generic-emph-format (second emph) + (match-string 4 string) + (third emph)) + (or (match-string 5 string) "") + (org-export-generic-fontify (substring string end))))) + string)) + +(defun org-export-generic-emph-format (format-varname string protect) + "Return a string that results from applying the markup indicated by +FORMAT-VARNAME to STRING." + (let ((format (symbol-value format-varname))) + (let ((string-to-emphasize + (if protect + string + (org-export-generic-fontify string)))) + (if format + (format format string-to-emphasize) + string-to-emphasize)))) + +(provide 'org-generic) +(provide 'org-export-generic) + +;;; org-export-generic.el ends here diff --git a/.emacs.d/org-7.4/contrib/lisp/org-git-link.el b/.emacs.d/org-7.4/contrib/lisp/org-git-link.el new file mode 100644 index 0000000..195bf9b --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-git-link.el @@ -0,0 +1,219 @@ +;;; org-git-link.el --- Provide org links to specific file version + +;; Copyright (C) 2009 Reimar Finken + +;; Author: Reimar Finken <reimar.finken@gmx.de> +;; Keywords: files, calendar, hypermedia + +;; 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-add-link-type "gitbare" 'org-gitbare-open) + +(defun org-gitbare-open (str) + (let* ((strlist (org-git-split-string str)) + (gitdir (first strlist)) + (object (second 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-add-link-type "git" 'org-git-open) + +(defun org-git-open (str) + (let* ((strlist (org-git-split-string str)) + (filepath (first strlist)) + (commit (second strlist)) + (dirlist (org-git-find-gitdir (file-truename filepath))) + (gitdir (first dirlist)) + (relpath (second dirlist))) + (org-git-open-file-internal gitdir (concat commit ":" relpath)))) + + +;; 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 (file-name-directory path)) + (relpath (file-name-nondirectory path))) + (catch 'toplevel + (while (not (file-exists-p (expand-file-name ".git" dir))) + (let ((dirlist (org-git-split-dirpath dir))) + (when (string= (second dirlist) "") ; at top level + (throw 'toplevel nil)) + (setq dir (first dirlist) + relpath (concat (file-name-as-directory (second dirlist)) relpath)))) + (list (expand-file-name ".git" dir) relpath)))) + + +(if (featurep 'xemacs) + (defalias 'org-git-gitrepos-p 'org-git-find-gitdir) + (defalias 'org-git-gitrepos-p 'org-git-find-gitdir + "Return non-nil if path is in git repository")) + +;; splitting the link string + +;; Both link open functions are called with a string of +;; consisting of two parts separated by a double colon (::). +(defun org-git-split-string (str) + "Given a string of the form \"str1::str2\", return a list of + two substrings \'(\"str1\" \"str2\"). If the double colon is mising, take str2 to be the empty string." + (let ((strlist (split-string str "::"))) + (cond ((= 1 (length strlist)) + (list (car strlist) "")) + ((= 2 (length strlist)) + strlist) + (t (error "org-git-split-string: only one :: 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) + "Create git link part to file at specific time" + (interactive "FFile: ") + (let* ((gitdir (first (org-git-find-gitdir (file-truename file)))) + (branchname (org-git-get-current-branch gitdir)) + (timestring (format-time-string "%Y-%m-%d" (current-time)))) + (org-make-link "git:" file "::" (org-git-create-searchstring branchname timestring)))) + +(defun org-git-store-link () + "Store git link to current file." + (when (buffer-file-name) + (let ((file (abbreviate-file-name (buffer-file-name)))) + (when (org-git-gitrepos-p file) + (org-store-link-props + :type "git" + :link (org-git-create-git-link file)))))) + +(add-hook 'org-store-link-functions 'org-git-store-link) + +(defun org-git-insert-link-interactively (file searchstring &optional description) + (interactive "FFile: \nsSearch string: \nsDescription: ") + (insert (org-make-link-string (org-make-link "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 " (save-excursion (set-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/.emacs.d/org-7.4/contrib/lisp/org-interactive-query.el b/.emacs.d/org-7.4/contrib/lisp/org-interactive-query.el new file mode 100644 index 0000000..1051e7c --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-interactive-query.el @@ -0,0 +1,310 @@ +;;; org-interactive-query.el --- Interactive modification of agenda query +;; +;; Copyright 2007 Free Software Foundation, Inc. +;; +;; Author: Christopher League <league at contrapunctus dot net> +;; Version: 1.0 +;; Keywords: org, wp +;; +;; 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; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +;; +;;; 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) + (org-set-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)
\ No newline at end of file diff --git a/.emacs.d/org-7.4/contrib/lisp/org-invoice.el b/.emacs.d/org-7.4/contrib/lisp/org-invoice.el new file mode 100644 index 0000000..7e2dad2 --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-invoice.el @@ -0,0 +1,399 @@ +;;; org-invoice.el --- Help manage client invoices in OrgMode +;; +;; Copyright (C) 2008 pmade inc. (Peter Jones pjones@pmade.com) +;; +;; 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 (assoc 'date info)) + (setq level (cdr (assoc '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 (assoc 'date info))) + (work (cdr (assoc 'work info))) + (price (cdr (assoc 'price info))) + (long-date (cdr (assoc 'long-date info))) + (level (cdr (assoc 'level info))) + (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 (assoc 'total-work (car bucket)) + (+ work (cdr (assoc 'total-work (car bucket))))) + (setcdr (assoc 'price (car bucket)) + (+ price (cdr (assoc 'price (car bucket))))) + (nconc bucket (list info)))))) + (nreverse new))) + +(defun org-invoice-info-to-table (info) + "Create a single org table row from the given info alist." + (let ((title (cdr (assoc 'title info))) + (total (cdr (assoc 'total-work info))) + (work (cdr (assoc 'work info))) + (price (cdr (assoc 'price info))) + (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-hh:mm-string total))) + (setq work (and work (org-minutes-to-hh:mm-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-hh:mm-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 (move-marker (make-marker) (point))) + 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/.emacs.d/org-7.4/contrib/lisp/org-jira.el b/.emacs.d/org-7.4/contrib/lisp/org-jira.el new file mode 100644 index 0000000..d224c8f --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-jira.el @@ -0,0 +1,65 @@ +;;; org-jira.el --- add a jira:ticket protocol to Org +(defconst org-jira-version "0.1") +;; Copyright (c)2008 Jonathan Arkell. (by)(nc)(sa) Some rights reserved. +;; Author: Jonathan Arkell <jonnay@jonnay.net> + +;; This file is not part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation version 2. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; For a copy of the GNU General Public License, search the Internet, +;; or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA + +;;; Commentary: +;; This adds a jira protocol to org mode. + +;;; Commands: +;; +;; Below are complete command list: +;; +;; +;;; Customizable Options: +;; +;; Below are customizable option list: +;; + +;; I had initially planned on adding bi-directional linking, so you +;; could store links from a jira ticket. I also wanted to import +;; tickets assigned to you as a task. However, I am no longer working +;; with JIRA, so this is now abandonware. + +;;; Installation: +;; Put org-jira.el somewhere in your load-path. +;; (Use M-x show-variable RET load-path to see what your load path is.) +;; Add this to your emacs init file, preferably after you load org mode. +;(require 'org-jira) + +;;; TODO: +;; - bi-directional links +;; - deeper importing, like tasks...? + +;;; CHANGELOG: +;; v 0.2 - ran through checkdoc +;; - Abandoned. +;; v 0.1 - Initial release + +(require 'jira) + +(org-add-link-type "jira" 'org-jira-open) + +(defun org-jira-open (path) + "Open a Jira Link from PATH." + (jira-show-issue path)) + + +(provide 'org-jira) + +;;; org-jira.el ends here diff --git a/.emacs.d/org-7.4/contrib/lisp/org-learn.el b/.emacs.d/org-7.4/contrib/lisp/org-learn.el new file mode 100644 index 0000000..1078001 --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-learn.el @@ -0,0 +1,180 @@ +;;; org-learn.el --- Implements SuperMemo's incremental learning algorithm + +;; Copyright (C) 2009 +;; 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 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: + +;; 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) + +;; arch-tag: a46bb0e5-e4fb-4004-a9b8-63933c55af33 + +;;; org-learn.el ends here diff --git a/.emacs.d/org-7.4/contrib/lisp/org-mac-iCal.el b/.emacs.d/org-7.4/contrib/lisp/org-mac-iCal.el new file mode 100644 index 0000000..2510aa7 --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-mac-iCal.el @@ -0,0 +1,249 @@ +;;; org-mac-iCal.el --- Imports events from iCal.app to the Emacs diary + +;; Copyright (C) 2009 Christopher Suckling + +;; Author: Christopher Suckling <suckling at gmail dot com> + +;; 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;; Version: 0.1057.104 +;; Keywords: outlines, calendar + +;;; 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\\.[56]" 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) + + (switch-to-buffer 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 0) + (setq monthEntry 0)) + (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"))) + (when (or + (and + (= yearEntry year) + (or (< monthEntry (- month (/ org-mac-iCal-range 2))) (> monthEntry (+ month (/ org-mac-iCal-range 2))))) + (< yearEntry (- year 1)) + (> yearEntry (+ year 1)) + (and + (= yearEntry (- year 1)) (/= monthEntry 12)) + (and + (= yearEntry (+ year 1)) (/= monthEntry 1))) + (delete-region startEntry endEntry)))) + (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/.emacs.d/org-7.4/contrib/lisp/org-mac-link-grabber.el b/.emacs.d/org-7.4/contrib/lisp/org-mac-link-grabber.el new file mode 100644 index 0000000..8ec428b --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-mac-link-grabber.el @@ -0,0 +1,465 @@ +;;; org-mac-link-grabber.el --- Grab links and url from various mac +;;; application and insert them as links into org-mode documents +;; +;; Copyright (c) 2010 Free Software Foundation, Inc. +;; +;; Author: Anthony Lander <anthony.lander@gmail.com> +;; Version: 1.0.1 +;; Keywords: org, mac, hyperlink +;; +;; 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; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +;; +;;; 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 requires, +;; org-mac-message.el written by John Weigley 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 +;; +;; +;; Installation: +;; +;; add (require 'org-mac-link-grabber) 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") 'omlg-grab-link))) +;; +;; +;; Usage: +;; +;; Type C-c g (or whatever key you defined, as above), or type M-x +;; omlg-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-grabber. Changes take effect +;; immediately. +;; +;; +;;; Code: + +(require 'org) +(require 'org-mac-message) + +(defgroup org-mac-link-grabber nil + "Options concerning grabbing links from external Mac +applications and inserting them in org documents" + :tag "Org Mac link grabber" + :group 'org-link) + +(defcustom org-mac-grab-Finder-app-p t + "Enable menu option [F]inder to grab links from the Finder" + :tag "Grab Finder.app links" + :group 'org-mac-link-grabber + :type 'boolean) + +(defcustom org-mac-grab-Mail-app-p t + "Enable menu option [m]ail to grab links from Mail.app" + :tag "Grab Mail.app links" + :group 'org-mac-link-grabber + :type 'boolean) + +(defcustom org-mac-grab-Addressbook-app-p t + "Enable menu option [a]ddressbook to grab links from AddressBook.app" + :tag "Grab AddressBook.app links" + :group 'org-mac-link-grabber + :type 'boolean) + +(defcustom org-mac-grab-Safari-app-p t + "Enable menu option [s]afari to grab links from Safari.app" + :tag "Grab Safari.app links" + :group 'org-mac-link-grabber + :type 'boolean) + +(defcustom org-mac-grab-Firefox-app-p t + "Enable menu option [f]irefox to grab links from Firefox.app" + :tag "Grab Firefox.app links" + :group 'org-mac-link-grabber + :type 'boolean) + +(defcustom org-mac-grab-Firefox+Vimperator-p nil + "Enable menu option [v]imperator to grab links from Firefox.app running the Vimperator plugin" + :tag "Grab Vimperator/Firefox.app links" + :group 'org-mac-link-grabber + :type 'boolean) + +(defcustom org-mac-grab-Chrome-app-p t + "Enable menu option [f]irefox to grab links from Google Chrome.app" + :tag "Grab Google Chrome.app links" + :group 'org-mac-link-grabber + :type 'boolean) + +(defcustom org-mac-grab-Together-app-p nil + "Enable menu option [t]ogether to grab links from Together.app" + :tag "Grab Together.app links" + :group 'org-mac-link-grabber + :type 'boolean) + + +(defun omlg-grab-link () + "Prompt the user for an application to grab a link from, then 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) + ("a" "ddressbook" org-mac-addressbook-insert-selected ,org-mac-grab-Addressbook-app-p) + ("s" "afari" org-mac-safari-insert-frontmost-url ,org-mac-grab-Safari-app-p) + ("f" "irefox" org-mac-firefox-insert-frontmost-url ,org-mac-grab-Firefox-app-p) + ("v" "imperator" org-mac-vimperator-insert-frontmost-url ,org-mac-grab-Firefox+Vimperator-p) + ("c" "hrome" org-mac-chrome-insert-frontmost-url ,org-mac-grab-Chrome-app-p) + ("t" "ogether" org-mac-together-insert-selected ,org-mac-grab-Together-app-p))) + (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))) + +(defalias 'omgl-grab-link 'omlg-grab-link + "Renamed, and this alias will be obsolete next revision.") + +(defun org-mac-paste-applescript-links (as-link-list) + "Paste in a list of links from an applescript handler. The + links are of the form <link>::split::<name>" + (let* ((link-list + (mapcar + (lambda (x) (if (string-match "\\`\"\\(.*\\)\"\\'" x) (setq x (match-string 1 x))) x) + (split-string as-link-list "[\r\n]+"))) + 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 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 \"c\" using command down\n" + " end tell\n" + " delay 0.15\n" + " set theUrl to the clipboard\n" + " set the clipboard to oldClipboard\n" + " set theResult to (get theUrl) & \"::split::\" & (get name of window 1)\n" + "end tell\n" + "activate application (frontmostApplication as text)\n" + "set links to {}\n" + "copy theResult to the end of links\n" + "return links as string\n")))) + (car (split-string result "[\r\n]+" t)))) + +(defun org-mac-firefox-get-frontmost-url () + (interactive) + (message "Applescript: Getting Firefox url...") + (let* ((url-and-title (as-mac-firefox-get-frontmost-url)) + (split-link (split-string url-and-title "::split::")) + (URL (car split-link)) + (description (cadr split-link)) + (org-link)) + (when (not (string= URL "")) + (setq org-link (org-make-link-string URL description))) + (kill-new org-link) + org-link)) + +(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 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...") + (let* ((url-and-title (as-mac-vimperator-get-frontmost-url)) + (split-link (split-string url-and-title "::split::")) + (URL (car split-link)) + (description (cadr split-link)) + (org-link)) + (when (not (string= URL "")) + (setq org-link (org-make-link-string URL description))) + (kill-new org-link) + org-link)) + +(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 are +;; Firefox because Chrome doesn't publish an Applescript dictionary + +(defun as-mac-chrome-get-frontmost-url () + (let ((result (do-applescript + (concat + "set oldClipboard to the clipboard\n" + "set frontmostApplication to path to frontmost application\n" + "tell application \"Google Chrome\"\n" + " activate\n" + " delay 0.15\n" + " tell application \"System Events\"\n" + " keystroke \"l\" using command down\n" + " keystroke \"c\" using command down\n" + " end tell\n" + " delay 0.15\n" + " set theUrl to the clipboard\n" + " set the clipboard to oldClipboard\n" + " set theResult to (get theUrl) & \"::split::\" & (get name of window 1)\n" + "end tell\n" + "activate application (frontmostApplication as text)\n" + "set links to {}\n" + "copy theResult to the end of links\n" + "return links as string\n")))) + (car (split-string result "[\r\n]+" t)))) + +(defun org-mac-chrome-get-frontmost-url () + (interactive) + (message "Applescript: Getting Chrome url...") + (let* ((url-and-title (as-mac-chrome-get-frontmost-url)) + (split-link (split-string url-and-title "::split::")) + (URL (car split-link)) + (description (cadr split-link)) + (org-link)) + (when (not (string= URL "")) + (setq org-link (org-make-link-string URL description))) + (kill-new org-link) + org-link)) + +(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 as-mac-safari-get-frontmost-url () + (let ((result (do-applescript + (concat + "tell application \"Safari\"\n" + " set theUrl to URL of document 1\n" + " set theName to the name of the document 1\n" + " return theUrl & \"::split::\" & theName & \"\n\"\n" + "end tell\n")))) + (car (split-string result "[\r\n]+" t)))) + +(defun org-mac-safari-get-frontmost-url () + (interactive) + (message "Applescript: Getting Safari url...") + (let* ((url-and-title (as-mac-safari-get-frontmost-url)) + (split-link (split-string url-and-title "::split::")) + (URL (car split-link)) + (description (cadr split-link)) + (org-link)) + (when (not (string= URL "")) + (setq org-link (org-make-link-string URL description))) + (kill-new org-link) + org-link)) + +(defun org-mac-safari-insert-frontmost-url () + (interactive) + (insert (org-mac-safari-get-frontmost-url))) + + +;; +;; +;; Handle links from together.app +;; +;; + +(org-add-link-type "x-together-item" 'org-mac-together-item-open) + +(defun org-mac-together-item-open (uid) + "Open the given uid, which is a reference to an item in Together" + (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-add-link-type "addressbook" 'org-mac-addressbook-item-open) + +(defun org-mac-addressbook-item-open (uid) + "Open the given uid, which is a reference to an item in Together" + (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))) + + +(provide 'org-mac-link-grabber) + +;;; org-mac-link-grabber.el ends here diff --git a/.emacs.d/org-7.4/contrib/lisp/org-mairix.el b/.emacs.d/org-7.4/contrib/lisp/org-mairix.el new file mode 100644 index 0000000..1f62b95 --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-mairix.el @@ -0,0 +1,332 @@ +;;; org-mairix.el - Support for hooking mairix search into Org for different MUAs +;; +;; Copyright (C) 2007 Georg C. F. Greve +;; mutt support by Adam Spiers <orgmode at adamspiers dot org> +;; +;; 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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-add-link-type "mairix" 'org-mairix-open) +(add-hook 'org-store-link-functions '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-remove-angle-brackets 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/.emacs.d/org-7.4/contrib/lisp/org-man.el b/.emacs.d/org-7.4/contrib/lisp/org-man.el new file mode 100644 index 0000000..27e8cca --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-man.el @@ -0,0 +1,64 @@ +;;; 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. +;; +;; 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, 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +(require 'org) + +(org-add-link-type "man" 'org-man-open) +(add-hook 'org-store-link-functions '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"))) + +(provide 'org-man) + +;;; org-man.el ends here diff --git a/.emacs.d/org-7.4/contrib/lisp/org-mime.el b/.emacs.d/org-7.4/contrib/lisp/org-mime.el new file mode 100644 index 0000000..bca6e91 --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-mime.el @@ -0,0 +1,245 @@ +;;; org-mime.el --- org html export for text/html MIME emails + +;; Copyright (C) 2010 Eric Schulte + +;; Author: Eric Schulte +;; Keywords: mime, mail, email, html +;; Homepage: http://orgmode.org/worg/org-contrib/org-mime.php +;; Version: 0.01 + +;;; 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; 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) + +(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) + +;; 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 + "<#part type=\"%s\" filename=\"%s\" id=\"<%s>\">\n<#/part>\n" + ext path id)) + ('semi (concat + (format + "--[[%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) + "Markup a multipart/alternative with text/plain and text/html + alternatives." + (case org-mime-library + ('mml (format (concat "<#multipart type=alternative><#part type=text/plain>" + "%s<#part type=text/html>%s<#/multipart>\n") + plain html)) + ('semi (concat + "--" "<<alternative>>-{\n" + "--" "[[text/plain]]\n" plain + "--" "[[text/html]]\n" html + "--" "}-<<alternative>>\n")) + ('vm "?"))) + +(defun org-mime-replace-images (str current-file) + "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 (file-name-directory current-file))) + (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 (arg) + "Export a portion of an email body composed using `mml-mode' to +html using `org-mode'. If called with an active region only +export that region, otherwise export the entire body." + (interactive "P") + (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 (buffer-substring html-start html-end)) + (tmp-file (make-temp-name (expand-file-name "mail" temporary-file-directory))) + (body (org-export-string raw-body "org" (file-name-directory tmp-file))) + ;; because we probably don't want to skip part of our mail + (org-export-skip-text-before-1st-heading nil) + ;; 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) + ;; to hold attachments for inline html images + (html-and-images + (org-mime-replace-images + (org-export-string raw-body "html" (file-name-directory tmp-file)) + tmp-file)) + (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)) + +(defun org-mime-org-buffer-htmlize () + "Export the current org-mode buffer to HTML using +`org-export-as-html' and package the results into an email +handling with appropriate MIME encoding." + (interactive) + (require 'reporter) + (let* ((region-p (org-region-active-p)) + (current-file (buffer-file-name (current-buffer))) + (html-start (or (and region-p (region-beginning)) + (save-excursion + (goto-char (point-min))))) + (html-end (or (and region-p (region-end)) + (point-max))) + (temp-body-file (make-temp-file "org-mime-export")) + (raw-body (buffer-substring html-start html-end)) + (body (with-temp-buffer + (insert raw-body) + (write-file temp-body-file) + (org-export-as-org nil nil nil 'string t))) + (org-link-file-path-type 'absolute) + ;; because we probably don't want to export a huge style file + (org-export-htmlize-output-type 'inline-css) + ;; to hold attachments for inline html images + (html-and-images (org-mime-replace-images + (org-export-as-html nil nil nil 'string t) + current-file)) + (html-images (cdr html-and-images)) + (html (org-mime-apply-html-hook (car html-and-images)))) + ;; dump the exported html into a fresh message buffer + (reporter-compose-outgoing) + (goto-char (point-max)) + (prog1 (insert (org-mime-multipart body html) + (mapconcat 'identity html-images "\n")) + (delete-file temp-body-file)))) + +(provide 'org-mime)
\ No newline at end of file diff --git a/.emacs.d/org-7.4/contrib/lisp/org-mtags.el b/.emacs.d/org-7.4/contrib/lisp/org-mtags.el new file mode 100644 index 0000000..2406552 --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-mtags.el @@ -0,0 +1,257 @@ +;;; org-mtags.el --- Muse-like tags in Org-mode +;; Copyright (C) 2008, 2009 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. +;; +;; 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, 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; This modules implements some of the formatting tags available in +;; Emacs Muse. This is not a way if adding new functionality, but just +;; a different way to write some formatting directives. The advantage is +;; that files written in this way can be read by Muse reasonably well, +;; and that this provides an alternative way of writing formatting +;; directives in Org, a way that some might find more pleasant to type +;; and look at that the Org's #+BEGIN..#+END notation. + +;; The goal of this development is to make it easier for people to +;; move between both worlds as they see fit for different tasks. + +;; The following muse tags will be translated during export into their +;; native Org equivalents: +;; +;; <br> +;; Needs to be at the end of a line. Will be translated to "\\". +;; +;; <example switches="-n -r"> +;; Needs to be on a line by itself, similarly the </example> tag. +;; Will be translated into Org's #+BEGIN_EXAMPLE construct. +;; +;; <quote> +;; Needs to be on a line by itself, similarly the </quote> tag. +;; Will be translated into Org's #+BEGIN_QUOTE construct. +;; +;; <comment> +;; Needs to be on a line by itself, similarly the </comment> tag. +;; Will be translated into Org's #+BEGIN_COMMENT construct. +;; +;; <verse> +;; Needs to be on a line by itself, similarly the </verse> tag. +;; Will be translated into Org's #+BEGIN_VERSE construct. +;; +;; <contents> +;; This gets translated into "[TABLE-OF-CONTENTS]". It will not +;; trigger the production of a table of contents - that is done +;; in Org with the "#+OPTIONS: toc:t" setting. But it will define +;; the location where the TOC will be placed. +;; +;; <literal style="STYLE"> ;; only latex, html, and docbook supported +;; in Org. +;; Needs to be on a line by itself, similarly the </literal> tag. +;; +;; <src lang="LANG" switches="-n -r"> +;; Needs to be on a line by itself, similarly the </src> tag. +;; Will be translated into Org's BEGIN_SRC construct. +;; +;; <include file="FILE" markup="MARKUP" lang="LANG" +;; prefix="str" prefix1="str" switches="-n -r"> +;; Needs to be on a line by itself. +;; Will be translated into Org's #+INCLUDE construct. +;; +;; The lisp/perl/ruby/python tags can be implemented using the +;; `org-eval.el' module, which see. + +(require 'org) + +;;; Customization + +(defgroup org-mtags nil + "Options concerning Muse tags in Org mode." + :tag "Org Muse Tags" + :group 'org) + +(defface org-mtags ; similar to shadow + (org-compatible-face 'shadow + '((((class color grayscale) (min-colors 88) (background light)) + (:foreground "grey50")) + (((class color grayscale) (min-colors 88) (background dark)) + (:foreground "grey70")) + (((class color) (min-colors 8) (background light)) + (:foreground "green")) + (((class color) (min-colors 8) (background dark)) + (:foreground "yellow")))) + "Face for Muse-like tags in Org." + :group 'org-mtags + :group 'org-faces) + +(defcustom org-mtags-prefer-muse-templates t + "Non-nil means prefere Muse tags for structure elements. +This is relevane when expanding the templates defined in the variable +`org-structure-templates'." + :group 'org-mtags + :type 'boolean) + +(defconst org-mtags-supported-tags + '("example" "quote" "comment" "verse" "contents" "literal" "src" "include") + "The tags that are supported by org-mtags.el for conversion. +In addition to this list, the <br> tag is supported as well.") + +(defconst org-mtags-fontification-re + (concat + "^[ \t]*</?\\(" + (mapconcat 'identity org-mtags-supported-tags "\\|") + "\\)\\>[^>]*>\\|<br>[ \t]*$") + "Regular expression used for fontifying muse tags.") + +(defun org-mtags-replace () + "Replace Muse-like tags with the appropriate Org constructs. +The is done in the entire buffer." + (interactive) ;; FIXME + (let ((re (concat "^[ \t]*\\(</?\\(" + (mapconcat 'identity org-mtags-supported-tags "\\|") + "\\)\\>\\)")) + info tag rpl style markup lang file prefix prefix1 switches) + ;; First, do the <br> tag + (goto-char (point-min)) + (while (re-search-forward "<br>[ \t]*$" nil t) + (replace-match "\\\\" t t)) + ;; Now, all the other tags + (goto-char (point-min)) + (while (re-search-forward re nil t) + (goto-char (match-beginning 1)) + (setq info (org-mtags-get-tag-and-attributes)) + (if (not info) + (end-of-line 1) + (setq tag (plist-get info :tag)) + (cond + ((equal tag "contents") + (setq rpl "[TABLE-OF-CONTENTS]") + ;; FIXME: also trigger TOC in options-plist????? + ) + ((member tag '("quote" "comment" "verse")) + (if (plist-get info :closing) + (setq rpl (format "#+END_%s" (upcase tag))) + (setq rpl (format "#+BEGIN_%s" (upcase tag))))) + ((equal tag "literal") + (setq style (plist-get info :style)) + (and style (setq style (downcase style))) + (if (plist-get info :closing) + (setq rpl (cond + ((member style '("latex")) + "#+END_LaTeX") + ((member style '("html")) + "#+END_HTML") + ((member style '("docbook")) + "#+END_DOCBOOK") + ((member style '("ascii")) + "#+END_ASCII"))) + (setq rpl (cond + ((member style '("latex")) + "#+BEGIN_LaTeX") + ((member style '("html")) + "#+BEGIN_HTML") + ((member style '("ascii")) + "#+BEGIN_ASCII"))))) + ((equal tag "example") + (if (plist-get info :closing) + (setq rpl "#+END_EXAMPLE") + (setq rpl "#+BEGIN_EXAMPLE") + (when (setq switches (plist-get info :switches)) + (setq rpl (concat rpl " " switches))))) + ((equal tag "src") + (if (plist-get info :closing) + (setq rpl "#+END_SRC") + (setq rpl "#+BEGIN_SRC") + (when (setq lang (plist-get info :lang)) + (setq rpl (concat rpl " " lang)) + (when (setq switches (plist-get info :switches)) + (setq rpl (concat rpl " " switches)))))) + ((equal tag "include") + (setq file (plist-get info :file) + markup (downcase (plist-get info :markup)) + lang (plist-get info :lang) + prefix (plist-get info :prefix) + prefix1 (plist-get info :prefix1) + switches (plist-get info :switches)) + (setq rpl "#+INCLUDE") + (setq rpl (concat rpl " " (prin1-to-string file))) + (when markup + (setq rpl (concat rpl " " markup)) + (when (and (equal markup "src") lang) + (setq rpl (concat rpl " " lang)))) + (when prefix + (setq rpl (concat rpl " :prefix " (prin1-to-string prefix)))) + (when prefix1 + (setq rpl (concat rpl " :prefix1 " (prin1-to-string prefix1)))) + (when switches + (setq rpl (concat rpl " " switches))))) + (when rpl + (goto-char (plist-get info :match-beginning)) + (delete-region (point-at-bol) (plist-get info :match-end)) + (insert rpl)))))) + +(defun org-mtags-get-tag-and-attributes () + "Parse a Muse-like tag at point ant rturn the information about it. +The return value is a property list which contains all the attributes +with string values. In addition, it reutnrs the following properties: + +:tag The tag as a string. +:match-beginning The beginning of the match, just before \"<\". +:match-end The end of the match, just after \">\". +:closing t when the tag starts with \"</\"." + (when (looking-at "<\\(/\\)?\\([a-zA-Z]+\\>\\)\\([^>]*\\)>") + (let ((start 0) + tag rest prop attributes endp val) + (setq tag (org-match-string-no-properties 2) + endp (match-end 1) + rest (and (match-end 3) + (org-match-string-no-properties 3)) + attributes (list :tag tag + :match-beginning (match-beginning 0) + :match-end (match-end 0) + :closing endp)) + (when rest + (while (string-match "\\([a-zA-Z]+\\)=\\([^ \t\n>]+\\|\"[^>]+\"\\)" + rest start) + (setq start (match-end 0) + prop (org-match-string-no-properties 1 rest) + val (org-remove-double-quotes + (org-match-string-no-properties 2 rest))) + (setq attributes (plist-put attributes + (intern (concat ":" prop)) val)))) + attributes))) + +(defun org-mtags-fontify-tags (limit) + "Fontify the muse-like tags." + (while (re-search-forward org-mtags-fontification-re limit t) + (add-text-properties (match-beginning 0) (match-end 0) + '(face org-mtags font-lock-multiline t + font-lock-fontified t)))) + +(add-hook 'org-export-preprocess-hook 'org-mtags-replace) +(add-hook 'org-font-lock-hook 'org-mtags-fontify-tags) + +(provide 'org-mtags) + +;;; org-mtags.el ends here + diff --git a/.emacs.d/org-7.4/contrib/lisp/org-panel.el b/.emacs.d/org-7.4/contrib/lisp/org-panel.el new file mode 100644 index 0000000..fe0ec64 --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-panel.el @@ -0,0 +1,642 @@ +;;; 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 this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth +;; Floor, Boston, MA 02110-1301, USA. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; 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 + +;;(defvar orgpan-this-panel-window nil) + +(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))))) + (setq orgpan-this-panel-window nil)) + (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: " 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) + +(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) + (split-window) + (set-window-buffer (selected-window) (orgpan-make-panel-buffer)) + (setq orgpan-panel-window (selected-window)) + ;;(set-window-dedicated-p (selected-window) t) + (fit-window-to-buffer nil nil 3) + (setq orgpan-org-window (next-window)) + ;; 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/.emacs.d/org-7.4/contrib/lisp/org-registry.el b/.emacs.d/org-7.4/contrib/lisp/org-registry.el new file mode 100644 index 0000000..ad382f0 --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-registry.el @@ -0,0 +1,271 @@ +;;; org-registry.el --- a registry for Org links +;; +;; Copyright 2007, 2008 Bastien Guerry +;; +;; Emacs Lisp Archive Entry +;; Filename: org-registry.el +;; Version: 0.1a +;; Author: Bastien Guerry <bzg AT altern DOT org> +;; Maintainer: Bastien Guerry <bzg AT altern DOT 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 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; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; 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 (org-mode-p) (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/.emacs.d/org-7.4/contrib/lisp/org-screen.el b/.emacs.d/org-7.4/contrib/lisp/org-screen.el new file mode 100644 index 0000000..fb1e73f --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-screen.el @@ -0,0 +1,108 @@ +;;; org-screen.el --- Integreate Org-mode with screen. + +;; Copyright (c) 2008 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. +;; +;; 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, 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; 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))) + (switch-to-buffer screen-buffer-name) + (switch-to-buffer (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/.emacs.d/org-7.4/contrib/lisp/org-secretary.el b/.emacs.d/org-7.4/contrib/lisp/org-secretary.el new file mode 100644 index 0000000..353e5c3 --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-secretary.el @@ -0,0 +1,232 @@ +;;; org-secretary.el --- Team management with org-mode +;; Copyright (C) 2010 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; 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/.emacs.d/org-7.4/contrib/lisp/org-special-blocks.el b/.emacs.d/org-7.4/contrib/lisp/org-special-blocks.el new file mode 100644 index 0000000..80e2b89 --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-special-blocks.el @@ -0,0 +1,94 @@ +;;; org-special-blocks.el --- Turn blocks into LaTeX envs and HTML divs + +;; Copyright (C) 2009 Chris Gray + +;; Author: Chris Gray <chrismgray@gmail.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 package generalizes the #+begin_foo and #+end_foo tokens. + +;; To use, put the following in your init file: +;; +;; (require 'org-special-blocks) + +;; The tokens #+begin_center, #+begin_verse, etc. existed previously. +;; This package generalizes them (at least for the LaTeX and html +;; exporters). When a #+begin_foo token is encountered by the LaTeX +;; exporter, it is expanded into \begin{foo}. The text inside the +;; environment is not protected, as text inside environments generally +;; is. When #+begin_foo is encountered by the html exporter, a div +;; with class foo is inserted into the HTML file. It is up to the +;; user to add this class to his or her stylesheet if this div is to +;; mean anything. + +(defvar org-special-blocks-ignore-regexp "^\\(LaTeX\\|HTML\\)$" + "A regexp indicating the names of blocks that should be ignored +by org-special-blocks. These blocks will presumably be +interpreted by other mechanisms.") + +(defun org-special-blocks-make-special-cookies () + "Adds special cookies when #+begin_foo and #+end_foo tokens are +seen. This is run after a few special cases are taken care of." + (when (or htmlp latexp) + (goto-char (point-min)) + (while (re-search-forward "^[ \t]*#\\+\\(begin\\|end\\)_\\(.*\\)$" nil t) + (unless (org-string-match-p org-special-blocks-ignore-regexp (match-string 2)) + (replace-match + (if (equal (downcase (match-string 1)) "begin") + (concat "ORG-" (match-string 2) "-START") + (concat "ORG-" (match-string 2) "-END")) + t t))))) + +(add-hook 'org-export-preprocess-after-blockquote-hook + 'org-special-blocks-make-special-cookies) + +(defun org-special-blocks-convert-latex-special-cookies () + "Converts the special cookies into LaTeX blocks." + (goto-char (point-min)) + (while (re-search-forward "^ORG-\\([^ \t\n]*\\)[ \t]*\\(.*\\)-\\(START\\|END\\)$" nil t) + (replace-match + (if (equal (match-string 3) "START") + (concat "\\begin{" (match-string 1) "}" (match-string 2)) + (concat "\\end{" (match-string 1) "}")) + t t))) + + +(add-hook 'org-export-latex-after-blockquotes-hook + 'org-special-blocks-convert-latex-special-cookies) + +(defun org-special-blocks-convert-html-special-cookies () + "Converts the special cookies into div blocks." + ;; Uses the dynamically-bound variable `line'. + (when (string-match "^ORG-\\(.*\\)-\\(START\\|END\\)$" line) +; (org-close-par-maybe) + (message "%s" (match-string 1)) + (if (equal (match-string 2 line) "START") + (insert "<div class=\"" (match-string 1 line) "\">\n") + (insert "</div>\n")) + (throw 'nextline nil))) + +(add-hook 'org-export-html-after-blockquotes-hook + 'org-special-blocks-convert-html-special-cookies) + +(provide 'org-special-blocks) + +;;; org-special-blocks.el ends here diff --git a/.emacs.d/org-7.4/contrib/lisp/org-static-mathjax.el b/.emacs.d/org-7.4/contrib/lisp/org-static-mathjax.el new file mode 100644 index 0000000..6a9f0ec --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-static-mathjax.el @@ -0,0 +1,171 @@ +;;; org-static-mathjax.el --- Muse-like tags in Org-mode +;; +;; Author: Jan Böker <jan dot boecker at jboecker dot de> + +;; 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; -*- +;; +;; License: GPL v2 or later + +(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/.emacs.d/org-7.4/contrib/lisp/org-toc.el b/.emacs.d/org-7.4/contrib/lisp/org-toc.el new file mode 100644 index 0000000..2c5eb9c --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-toc.el @@ -0,0 +1,488 @@ +;;; org-toc.el --- Table of contents for Org-mode buffer + +;; Copyright 2007 Bastien Guerry +;; +;; Author: Bastien Guerry <bzg AT altern DOT org> +;; Keywords: Org table of contents +;; Homepage: http://www.cognition.ens.fr/~guerry/u/org-toc.el +;; Version: 0.8 + +;; 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; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; 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 [(left)] 'org-toc-previous) +(define-key org-toc-mode-map [(right)] 'org-toc-next) +(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)) + (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 "^\\*+ " nil t)))) + +;;;###autoload +(defun org-toc-show (&optional depth position) + "Show the table of contents of the current Org-mode buffer." + (interactive "P") + (if (org-mode-p) + (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) + (switch-to-buffer 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 "^\\*+ " 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-quit () + "Quit the current Org TOC buffer." + (interactive) + (kill-this-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))) + (switch-to-buffer 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))) + (switch-to-buffer 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) + (switch-to-buffer 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 " "))))) + (switch-to-buffer 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) + (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 "^\\*+ ") + (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 +\[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/.emacs.d/org-7.4/contrib/lisp/org-track.el b/.emacs.d/org-7.4/contrib/lisp/org-track.el new file mode 100644 index 0000000..e65364e --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-track.el @@ -0,0 +1,219 @@ +;;; org-track.el --- Track the most recent Org-mode version available. +;; +;; Copyright (C) 2009 +;; Free Software Foundation, Inc. +;; +;; Author: Bastien Guerry <bzg at altern dot 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 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: +;; +;; 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-install.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." + :version "22.1" + :group 'org) + +(defcustom org-track-directory "~/.emacs.d/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-install.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-install.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-install file + (require 'autoload) + (setq esf/org-install-file (concat directory "org-install.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-install))\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/.emacs.d/org-7.4/contrib/lisp/org-velocity.el b/.emacs.d/org-7.4/contrib/lisp/org-velocity.el new file mode 100644 index 0000000..2a1f41b --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-velocity.el @@ -0,0 +1,527 @@ +;;; org-velocity.el --- something like Notational Velocity for Org. + +;; Copyright (C) 2010 Paul M. Rodriguez + +;; Author: Paul M. Rodriguez <paulmrodriguez@gmail.com> +;; Created: 2010-05-05 +;; Version: 2.2 + +;; 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. + +;; For a copy of the GNU General Public License, search the Internet, +;; or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA + +;;; Commentary: +;; Org-Velocity.el implements an interface for Org inspired by the +;; minimalist notetaking program Notational Velocity. The idea is to +;; allow you to maintain, amass and access brief notes on many +;; subjects with minimal fuss. + +;; It can be used in two ways: to store and access notes from any +;; buffer a universal bucket file; or as a method for navigating any +;; Org file. + +;; The name of the bucket-file (`org-velocity-bucket') and whether to +;; always use it (`org-velocity-always-use-bucket-file') are set +;; through Customize. If the bucket file is set but not always to be +;; used, then calling Org-Velocity outside of Org-mode uses the bucket +;; file; calling it in Org mode uses the current buffer. If no bucket +;; file is set then Org-Velocity only works when called from Org. +;; Even if the bucket file is always to be used, calling +;; `org-velocity-read' with an argument will use the current file. + +;; The interface, unlike its inspiration, is not incremental. +;; Org-Velocity prompts for search terms in the usual way; if the user +;; has customized `org-velocity-use-completion', completion is offered +;; on the headings in the target file. If the search multiple times +;; in the target file, a buffer containing a buttonized list of the +;; headings where it occurs is displayed. Results beyond what can be +;; indexed are discarded. After clicking on a heading, or typing a +;; character associated with it, the user is taken to the heading. +;; (Typing 0 forces a new heading to be created.) If +;; `org-velocity-edit-indirectly' is so set, the heading and its +;; subtree are displayed in an indirect buffer. Otherwise the user is +;; simply taken to the proper buffer and position. + +;; If the user simply hits RET at the prompt, without making a choice, +;; then the search is restored for editing. A blank search quits. +;; This method of selection is obviously not as slick as the original, +;; but probably more useful for a keyboard-driven interface. + +;; If the search does not occur in the file the user is offered a +;; choice to create a new heading named with the search. Org-Velocity +;; will use `org-capture' or `org-remember' if they are loaded, +;; preferring `org-capture'. Otherwise the user is simply taken to a +;; new heading at the end of the file. + +;; Thanks to Richard Riley, Carsten Dominik, and Bastien Guerry for +;; their suggestions. + +;;; Usage: +;; (require 'org-velocity) +;; (setq org-velocity-bucket (concat org-directory "/bucket.org")) +;; (global-set-key (kbd "C-c v") 'org-velocity-read) + +;;; Code: +(require 'org) +(require 'button) +(require 'electric) +(eval-when-compile (require 'cl)) + +(defgroup org-velocity nil + "Notational Velocity-style interface for Org." + :tag "Org-Velocity" + :group 'outlines + :group 'hypermedia) + +(defcustom org-velocity-bucket "" + "Where is the bucket file?" + :group 'org-velocity + :type 'file) + +(defcustom org-velocity-always-use-bucket nil + "Use bucket file even when called from an Org buffer?" + :group 'org-velocity + :type 'boolean) + +(defcustom org-velocity-use-completion nil + "Complete on heading names?" + :group 'org-velocity + :type 'boolean) + +(defcustom org-velocity-edit-indirectly t + "Edit entries in an indirect buffer or just visit the file?" + :group 'org-velocity + :type 'boolean) + +(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))) + +(defcustom org-velocity-create-method 'capture + "Prefer `org-capture', `org-remember', or neither?" + :group 'org-velocity + :type '(choice + (const :tag "Prefer capture > remember > default." capture) + (const :tag "Prefer remember > default." remember) + (const :tag "Edit in buffer." buffer))) + +(defcustom org-velocity-allow-regexps nil + "Allow searches to use regular expressions?" + :group 'org-velocity + :type 'boolean) + +(defstruct (org-velocity-heading + (:constructor org-velocity-make-heading) + (:type list)) + (marker (point-marker)) + (name (substring-no-properties + (org-get-heading)))) + +(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.") + +(defun org-velocity-use-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 this is an Org file, use it." + (let ((org-velocity-bucket + (and org-velocity-bucket (expand-file-name org-velocity-bucket)))) + (if org-velocity-always-use-bucket + (or org-velocity-bucket (error "Bucket required but not defined")) + (if (and (eq major-mode 'org-mode) + (buffer-file-name)) + (buffer-file-name) + (or org-velocity-bucket + (error "No bucket and not an Org file")))))) + +(defsubst org-velocity-display-buffer () + "Return the proper buffer for Org-Velocity to display in." + (get-buffer-create "*Velocity headings*")) + +(defsubst org-velocity-bucket-buffer () + "Return proper buffer for bucket operations." + (find-file-noselect (org-velocity-use-file))) + +(defun org-velocity-quote (search) + "Quote SEARCH as a regexp if `org-velocity-allow-regexps' is non-nil. +Acts like `regexp-quote' on a string, `regexp-opt' on a list." + (if org-velocity-allow-regexps + search + (if (listp search) + (regexp-opt search) + (regexp-quote search)))) + +(defun org-velocity-nearest-heading (position) + "Return last heading at POSITION. +If there is no last heading, return nil." + (save-excursion + (goto-char position) + (unless (org-before-first-heading-p) + (org-back-to-heading) + (org-velocity-make-heading)))) + +(defun org-velocity-make-button-action (heading) + "Return a form to visit HEADING." + `(lambda (button) + (run-hooks 'mouse-leave-buffer-hook) ;turn off temporary modes + (if org-velocity-edit-indirectly + (org-velocity-edit-entry ',heading) + (progn + (message "%s" ,(org-velocity-heading-name heading)) + (switch-to-buffer (marker-buffer + ,(org-velocity-heading-marker heading))) + (goto-char (marker-position + ,(org-velocity-heading-marker heading))))))) + +(defun org-velocity-edit-entry (heading) + "Edit entry at HEADING in an indirect buffer." + (let ((buffer (make-indirect-buffer + (marker-buffer (org-velocity-heading-marker heading)) + (generate-new-buffer-name + (org-velocity-heading-name heading))))) + (with-current-buffer buffer + (let ((org-inhibit-startup t)) + (org-mode)) + (goto-char (marker-position (org-velocity-heading-marker heading))) + (narrow-to-region (point) + (save-excursion + (org-end-of-subtree) + (point))) + (goto-char (point-min)) + (add-hook 'org-ctrl-c-ctrl-c-hook 'org-velocity-dismiss nil t)) + (pop-to-buffer buffer) + (set (make-local-variable 'header-line-format) + (format "%s Use C-c C-c to finish." + (abbreviate-file-name + (buffer-file-name + (marker-buffer + (org-velocity-heading-marker heading)))))))) + +(defun org-velocity-dismiss () + "Save current entry and close indirect buffer." + (progn + (save-buffer) + (kill-buffer))) + +(defun org-velocity-buttonize (heading) + "Insert HEADING as a text button." + (insert (format "#%c " (nth (1- (line-number-at-pos)) + org-velocity-index))) + (let ((action (org-velocity-make-button-action heading))) + (insert-text-button + (org-velocity-heading-name heading) + 'action action)) + (newline)) + +(defun org-velocity-remember (heading &optional region) + "Use `org-remember' to record a note to HEADING. +If there is a REGION that will be inserted." + (let ((org-remember-templates + (list (list + "Velocity entry" + ?v + (format "* %s\n\n%%?%s" heading (or region "")) + (org-velocity-use-file) + 'bottom)))) + (org-remember nil ?v))) + +(defun org-velocity-capture (heading &optional region) + "Use `org-capture' to record a note to HEADING. +If there is a REGION that will be inserted." + (let ((org-capture-templates + (list `("v" + "Velocity entry" + entry + (file ,(org-velocity-use-file)) + ,(format "* %s\n\n%%?%s" heading (or region "")))))) + (if (fboundp 'org-capture) ;; quiet compiler + (org-capture nil "v")))) + +(defun org-velocity-insert-heading (heading) + "Add a new heading named HEADING." + (with-current-buffer (org-velocity-bucket-buffer) + (goto-char (point-max)) + (newline) + (org-insert-heading) (insert heading) + (newline) + (goto-char (point-max)))) + +(defun org-velocity-create-heading (search region) + "Add and visit a new heading named SEARCH. +If REGION is non-nil insert as the contents of the heading." + (org-velocity-insert-heading search) + (switch-to-buffer (org-velocity-bucket-buffer)) + (when region (insert region))) + +(defun org-velocity-all-search (search) + "Return entries containing all words in SEARCH." + (when (file-exists-p (org-velocity-use-file)) + (save-excursion + (delq nil + (let ((keywords + (mapcar 'org-velocity-quote + (split-string search))) + (case-fold-search t)) + (org-map-entries + (lambda () + (if (loop with limit = (save-excursion + (org-end-of-subtree) + (point)) + for word in keywords + always (save-excursion + (re-search-forward word limit t))) + (org-velocity-nearest-heading + (match-beginning 0)))))))))) + +(defun org-velocity-generic-search (search) + "Return entries containing SEARCH." + (save-excursion + (delq nil + (nreverse + (let (matches (case-fold-search t)) + (goto-char (point-min)) + (while (re-search-forward search + (point-max) t) + (push (org-velocity-nearest-heading (match-beginning 0)) + matches) + (outline-next-heading)) + matches))))) + +(defsubst org-velocity-phrase-search (search) + "Return entries containing SEARCH as a phrase." + (org-velocity-generic-search (org-velocity-quote search))) + +(defsubst org-velocity-any-search (search) + "Return entries containing any word in SEARCH." + (org-velocity-generic-search (org-velocity-quote (split-string search)))) + +(defun org-velocity-present (headings) + "Buttonize HEADINGS in `org-velocity-display-buffer'." + (and (listp headings) (delete-dups headings)) + (let ((cdr (nthcdr + (1- (length org-velocity-index)) + headings))) + (and (consp cdr) (setcdr cdr nil))) + (with-current-buffer (org-velocity-display-buffer) + (mapc + 'org-velocity-buttonize + headings) + (goto-char (point-min)))) + +(defun org-velocity-create-1 (search region) + "Create a new heading named SEARCH. +If REGION is non-nil insert as contents of new heading. +The possible methods are `org-velocity-capture', +`org-velocity-remember', or `org-velocity-create-heading', in +that order. Which is preferred is determined by +`org-velocity-create-method'." + (funcall + (ecase org-velocity-create-method + (capture (or (and (featurep 'org-capture) 'org-velocity-capture) + (and (featurep 'org-remember) 'org-velocity-remember) + 'org-velocity-create-heading)) + (remember (or (and (featurep 'org-remember) 'org-velocity-remember) + 'org-velocity-create-heading)) + (buffer 'org-velocity-create-heading)) + search region)) + +(defun org-velocity-create (search &optional ask) + "Create new heading named SEARCH. +If ASK is non-nil, ask first." + (if (or (null ask) + (y-or-n-p "No match found, create? ")) + ;; if there's a region, we want to insert it + (let ((region (if (use-region-p) + (buffer-substring + (region-beginning) + (region-end))))) + (with-current-buffer (org-velocity-bucket-buffer) + (org-velocity-create-1 search region)) + (when region (message "%s" "Inserted region")) + search))) + +(defun org-velocity-get-matches (search) + "Return matches for SEARCH in current bucket. +Use method specified by `org-velocity-search-method'." + (with-current-buffer (org-velocity-bucket-buffer) + (case org-velocity-search-method + ('phrase (org-velocity-phrase-search search)) + ('any (org-velocity-any-search search)) + ('all (org-velocity-all-search search))))) + +(defun org-velocity-engine (search) + "Display a list of headings where SEARCH occurs." + (with-current-buffer (org-velocity-display-buffer) + (erase-buffer) + (setq cursor-type nil)) + (unless (or + (not (stringp search)) + (string-equal "" search)) ;exit on empty string + (case + (with-current-buffer (org-velocity-bucket-buffer) + (save-excursion + (let ((matches (org-velocity-get-matches search))) + (org-velocity-present matches) + (cond ((zerop (length matches)) 'new) + ((= (length matches) 1) 'follow) + ((> (length matches) 1) 'prompt))))) + ('prompt (progn + (Electric-pop-up-window (org-velocity-display-buffer)) + (let ((hint (org-velocity-electric-follow-hint))) + (if hint + (case hint + (edit (org-velocity-read nil search)) + (new (org-velocity-create search)) + (otherwise (org-velocity-activate-button hint))))))) + ('new (unless (org-velocity-create search t) + (org-velocity-read nil search))) + ('follow (if (y-or-n-p "One match, follow? ") + (progn + (set-buffer (org-velocity-display-buffer)) + (goto-char (point-min)) + (button-activate (next-button (point)))) + (org-velocity-read nil search)))))) + +(defun org-velocity-position (item list) + "Return first position of ITEM in LIST." + (loop for elt in list + for i from 0 + if (equal elt item) + return i)) + +(defun org-velocity-activate-button (char) + "Go to button on line number associated with CHAR in `org-velocity-index'." + (goto-char (point-min)) + (forward-line (org-velocity-position char org-velocity-index)) + (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.")) + (sit-for 4)) + +(defun org-velocity-electric-follow (ev) + "Follow a hint indexed by keyboard event EV." + (interactive (list last-command-event)) + (if (not (> (org-velocity-position ev org-velocity-index) + (1- (count-lines (point-min) (point-max))))) + (throw 'org-velocity-select ev) + (call-interactively 'org-velocity-electric-undefined))) + +(defun org-velocity-electric-click (ev) + "Follow hint indexed by a mouse event EV." + (interactive "e") + (throw 'org-velocity-select + (nth (1- (count-lines + (point-min) + (posn-point (event-start ev)))) + org-velocity-index))) + +(defun org-velocity-electric-edit () + "Edit the search string." + (interactive) + (throw 'org-velocity-select 'edit)) + +(defun org-velocity-electric-new () + "Force a new entry." + (interactive) + (throw 'org-velocity-select 'new)) + +(defvar org-velocity-electric-map + (let ((map (make-sparse-keymap))) + (define-key map [t] 'org-velocity-electric-undefined) (loop for c in org-velocity-index + do (define-key map (char-to-string c) 'org-velocity-electric-follow)) + (define-key map "0" 'org-velocity-electric-new) + (define-key map [tab] 'scroll-up) + (define-key map [return] 'org-velocity-electric-edit) + (define-key map [mouse-1] 'org-velocity-electric-click) + (define-key map [mouse-2] 'org-velocity-electric-click) + (define-key map [escape escape escape] 'keyboard-quit) + (define-key map "\C-h" 'help-command) + map)) + +(defun org-velocity-electric-follow-hint () + "Read index of button electrically." + (with-current-buffer (org-velocity-display-buffer) + (use-local-map org-velocity-electric-map) + (catch 'org-velocity-select + (Electric-command-loop 'org-velocity-select + "Follow: ")))) + +(defun org-velocity-read-with-completion (prompt) + "Like `completing-read' on entries with PROMPT. +Use `minibuffer-local-filename-completion-map'." + (let ((minibuffer-local-completion-map + minibuffer-local-filename-completion-map)) + (completing-read + prompt + (mapcar 'substring-no-properties + (org-map-entries 'org-get-heading))))) + +(defun org-velocity-read-string (prompt &optional initial-input) + "Read string with PROMPT followed by INITIAL-INPUT." + ;; The use of initial inputs to the minibuffer is deprecated (see + ;; `read-from-minibuffer'), but in this case it is the user-friendly + ;; thing to do. + (minibuffer-with-setup-hook + (lexical-let ((initial-input initial-input)) + (lambda () + (and initial-input (insert initial-input)) + (goto-char (point-max)))) + (if (and org-velocity-use-completion + ;; map-entries complains for nonexistent files + (file-exists-p (org-velocity-use-file))) + (org-velocity-read-with-completion prompt) + (read-string prompt)))) + +(defun org-velocity-read (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 forces current file." + (interactive "P") + (let ((org-velocity-always-use-bucket + (if arg nil org-velocity-always-use-bucket))) + ;; complain if inappropriate + (assert (org-velocity-use-file)) + (unwind-protect + (org-velocity-engine + (org-velocity-read-string "Velocity search: " search)) + (progn + (kill-buffer (org-velocity-display-buffer)) + (delete-other-windows))))) + +(provide 'org-velocity) +;;; org-velocity.el ends here diff --git a/.emacs.d/org-7.4/contrib/lisp/org-wikinodes.el b/.emacs.d/org-7.4/contrib/lisp/org-wikinodes.el new file mode 100644 index 0000000..85c32f6 --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org-wikinodes.el @@ -0,0 +1,339 @@ +;;; org-wikinodes.el --- Wiki-like CamelCase links to outline nodes + +;; Copyright (C) 2010 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 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/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(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)) + (add-text-properties (match-beginning 0) (match-end 0) + '(org-no-flyspell t)) + t) + ;; this is a wiki link + (org-remove-flyspell-overlays-in (match-beginning 0) + (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-on-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-direcory-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)) + (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)) + (switch-to-buffer (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-on-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-direcory-targets-cache) + t)) + +(defun org-wikinodes-clear-direcory-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 (org-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." + (setq directory (expand-file-name (or directory default-directory))) + (unless (assoc directory org-wikinodes-directory-targets-cache) + (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))))) + +(defvar org-current-export-file) +(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) + (org-if-unprotected-at (match-beginning 0) + (unless (save-match-data + (or (org-on-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))) + ((setq file + (and (org-string-nw-p org-current-export-file) + (org-wikinodes-which-file + link (file-name-directory org-current-export-file)))) + ;; Match in another file in the current directory + (insert (format "[[file:%s::%s][%s]]" file link link))) + (t ;; No match for this link + (insert (format "%s" link)))))))))) + +;;; 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-define-heading-targets-headline-hook + 'org-wikinodes-set-wiki-targets-during-export) + +;; Turn Wiki links into links the exporter will treat correctly +(add-hook 'org-export-preprocess-after-radio-targets-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-plain-links) org-font-lock-extra-keywords))) + (if m + (setcdr m (cons '(org-wikinodes-activate-links) (cdr m))) + (message + "Failed to add wikinodes to `org-font-lock-extra-keywords'.")))) + +(add-hook 'org-font-lock-set-keywords-hook + 'org-wikinodes-add-to-font-lock-keywords) + +(provide 'org-wikinodes) + +;; arch-tag: e3b56e38-a2be-478c-b56c-68a913ec54ec + +;;; org-wikinodes.el ends here diff --git a/.emacs.d/org-7.4/contrib/lisp/org2rem.el b/.emacs.d/org-7.4/contrib/lisp/org2rem.el new file mode 100644 index 0000000..5d160dc --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/org2rem.el @@ -0,0 +1,653 @@ +;;; org2rem.el --- Convert org appointments into reminders + +;; Copyright (C) 2006, 2007, 2008 Free Software Foundation, Inc. + +;; Author: Bastien Guerry and Shatad Pratap +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 6.09a +;; +;; 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: + +;; (require 'org2rem) +;; To export, do +;; +;; M-x org2rem-combine-agenda-files +;; +;; Then you can use reming like this: +;; +;; $ remind ~/org.rem +;; +;; If you want to use this regualrly, try in .emacs +;; +;; (add-hook 'org-mode-hook +;; (lambda() (add-hook 'after-save-hook +;; 'org-export-remind-all-agenda-files t t))) + +(require 'org) +(require 'org-agenda) +(require 'org-exp) +(eval-and-compile + (require 'cl)) + +(defgroup org2rem nil + "Options specific for Remind export of Org-mode files." + :tag "Org Export Remind" + :group 'org-export) + +(defcustom org-combined-agenda-remind-file "~/org.rem" + "The file name for the Remind file covering all agenda files. +This file is created with the command \\[org2rem-all-agenda-files]. +The file name should be absolute, the file will be overwritten without warning." + :group 'org2rem + :type 'file) + +(defcustom org-remind-combined-name "OrgMode" + "Calendar name for the combined Remind representing all agenda files." + :group 'org2rem + :type 'string) + +(defcustom org-remind-use-deadline '(event-if-not-todo todo-due) + "Contexts where Remind export should use a deadline time stamp. +This is a list with several symbols in it. Valid symbol are: + +event-if-todo Deadlines in TODO entries become calendar events. +event-if-not-todo Deadlines in non-TODO entries become calendar events. +todo-due Use deadlines in TODO entries as due-dates" + :group 'org2rem + :type '(set :greedy t + (const :tag "Deadlines in non-TODO entries become events" + event-if-not-todo) + (const :tag "Deadline in TODO entries become events" + event-if-todo) + (const :tag "Deadlines in TODO entries become due-dates" + todo-due))) + +(defcustom org-remind-use-scheduled '(todo-start) + "Contexts where Remind export should use a scheduling time stamp. +This is a list with several symbols in it. Valid symbol are: + +event-if-todo Scheduling time stamps in TODO entries become an event. +event-if-not-todo Scheduling time stamps in non-TODO entries become an event. +todo-start Scheduling time stamps in TODO entries become start date. + Some calendar applications show TODO entries only after + that date." + :group 'org2rem + :type '(set :greedy t + (const :tag + "SCHEDULED timestamps in non-TODO entries become events" + event-if-not-todo) + (const :tag "SCHEDULED timestamps in TODO entries become events" + event-if-todo) + (const :tag "SCHEDULED in TODO entries become start date" + todo-start))) + +(defcustom org-remind-categories '(local-tags category) + "Items that should be entered into the categories field. +This is a list of symbols, the following are valid: + +category The Org-mode category of the current file or tree +todo-state The todo state, if any +local-tags The tags, defined in the current line +all-tags All tags, including inherited ones." + :group 'org2rem + :type '(repeat + (choice + (const :tag "The file or tree category" category) + (const :tag "The TODO state" todo-state) + (const :tag "Tags defined in current line" local-tags) + (const :tag "All tags, including inherited ones" all-tags)))) + +(defcustom org-remind-include-todo nil + "Non-nil means export to remind files should also cover TODO items." + :group 'org2rem + :type '(choice + (const :tag "None" nil) + (const :tag "Unfinished" t) + (const :tag "All" all))) + +(defcustom org-remind-include-sexps t + "Non-nil means export to Remind files should also cover sexp entries. +These are entries like in the diary, but directly in an Org-mode file." + :group 'org2rem + :type 'boolean) + +(defcustom org-remind-deadline-over-scheduled t + "Non-nil means use deadline as target when both deadline and +scheduled present, vice-versa. Default is Non-nil." + :group 'org2rem + :type 'boolean) + +(defcustom org-remind-escape-percentage t + "Non-nil means % will be escaped, vice-versa. Default is Non-nil." + :group 'org2rem + :type 'boolean) + +(defcustom org-remind-extra-warn-days 3 + "Extra days Remind keep reminding." + :group 'org2rem + :type 'number) + +(defcustom org-remind-advanced-warn-days 3 + "Advanced days Remind start reminding." + :group 'org2rem + :type 'number) + +(defcustom org-remind-suppress-last-newline nil + "Non-nil means suppress last newline REM body. Default is nil." + :group 'org2rem + :type 'boolean) + +(defcustom org-remind-include-body 100 + "Amount of text below headline to be included in Remind export. +This is a number of characters that should maximally be included. +Properties, scheduling and clocking lines will always be removed. +The text will be inserted into the DESCRIPTION field." + :group 'org2rem + :type '(choice + (const :tag "Nothing" nil) + (const :tag "Everything" t) + (integer :tag "Max characters"))) + +(defcustom org-remind-store-UID nil + "Non-nil means store any created UIDs in properties. +The Remind standard requires that all entries have a unique identifyer. +Org will create these identifiers as needed. When this variable is non-nil, +the created UIDs will be stored in the ID property of the entry. Then the +next time this entry is exported, it will be exported with the same UID, +superceeding the previous form of it. This is essential for +synchronization services. +This variable is not turned on by default because we want to avoid creating +a property drawer in every entry if people are only playing with this feature, +or if they are only using it locally." + :group 'org2rem + :type 'boolean) + +;;;; Exporting + +;;; Remind export + +;;;###autoload +(defun org2rem-this-file () + "Export current file as an Remind file. +The Remind file will be located in the same directory as the Org-mode +file, but with extension `.rem'." + (interactive) + (org2rem nil buffer-file-name)) + +;;;###autoload +(defun org2rem-all-agenda-files () + "Export all files in `org-agenda-files' to Remind .rem files. +Each Remind file will be located in the same directory as the Org-mode +file, but with extension `.rem'." + (interactive) + (apply 'org2rem nil (org-agenda-files t))) + +;;;###autoload +(defun org2rem-combine-agenda-files () + "Export all files in `org-agenda-files' to a single combined Remind file. +The file is stored under the name `org-combined-agenda-remind-file'." + (interactive) + (apply 'org2rem t (org-agenda-files t))) + +(defun org2rem (combine &rest files) + "Create Remind files for all elements of FILES. +If COMBINE is non-nil, combine all calendar entries into a single large +file and store it under the name `org-combined-agenda-remind-file'." + (save-excursion + (org-prepare-agenda-buffers files) + (let* ((dir (org-export-directory + :ical (list :publishing-directory + org-export-publishing-directory))) + file rem-file rem-buffer category started org-agenda-new-buffers) + (and (get-buffer "*rem-tmp*") (kill-buffer "*rem-tmp*")) + (when combine + (setq rem-file + (if (file-name-absolute-p org-combined-agenda-remind-file) + org-combined-agenda-remind-file + (expand-file-name org-combined-agenda-remind-file dir)) + rem-buffer (org-get-agenda-file-buffer rem-file)) + (set-buffer rem-buffer) (erase-buffer)) + (while (setq file (pop files)) + (catch 'nextfile + (org-check-agenda-file file) + (set-buffer (org-get-agenda-file-buffer file)) + (unless combine + (setq rem-file (concat (file-name-as-directory dir) + (file-name-sans-extension + (file-name-nondirectory buffer-file-name)) + ".rem")) + (setq rem-buffer (org-get-agenda-file-buffer rem-file)) + (with-current-buffer rem-buffer (erase-buffer))) + (setq category (or org-category + (file-name-sans-extension + (file-name-nondirectory buffer-file-name)))) + (if (symbolp category) (setq category (symbol-name category))) + (let ((standard-output rem-buffer)) + (if combine + (and (not started) (setq started t) + (org-start-remind-file org-remind-combined-name)) + (org-start-remind-file category)) + (org-print-remind-entries combine) + (when (or (and combine (not files)) (not combine)) + (org-finish-remind-file) + (set-buffer rem-buffer) + (run-hooks 'org-before-save-Remind-file-hook) + (save-buffer) + (run-hooks 'org-after-save-Remind-file-hook) + (and (boundp 'org-wait) (numberp org-wait) (sit-for org-wait)) + )))) + (org-release-buffers org-agenda-new-buffers)))) + +(defvar org-before-save-Remind-file-hook nil + "Hook run before an Remind file has been saved. +This can be used to modify the result of the export.") + +(defvar org-after-save-Remind-file-hook nil + "Hook run after an Remind file has been saved. +The Remind buffer is still current when this hook is run. +A good way to use this is to tell a desktop calenndar application to re-read +the Remind file.") + +(defvar org-agenda-default-appointment-duration) ; defined in org-agenda.el +(defun org-print-remind-entries (&optional combine) + "Print Remind entries for the current Org-mode file to `standard-output'. +When COMBINE is non nil, add the category to each line." + (require 'org-agenda) + (let ((re1 (concat org-ts-regexp "\\|<%%([^>\n]+>")) + (re2 (concat "--?-?\\(" org-ts-regexp "\\)")) + (dts (org-rem-ts-to-string + (format-time-string (cdr org-time-stamp-formats) (current-time)) + "start time:")) + hd ts ts2 state status (inc t) pos b sexp rrule + scheduledp deadlinep todo prefix due start + tmp pri categories entry location summary desc uid + remind-aw remind-ew (org-rem-ew org-remind-extra-warn-days) + (org-rem-aw org-remind-advanced-warn-days) + trigger diff-days (dos org-remind-deadline-over-scheduled) + (suppress-last-newline org-remind-suppress-last-newline) + (sexp-buffer (get-buffer-create "*rem-tmp*"))) + (org-refresh-category-properties) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward re1 nil t) + (catch :skip + (org-agenda-skip) + (when (boundp 'org-remind-verify-function) + (unless (funcall org-remind-verify-function) + (outline-next-heading) + (backward-char 1) + (throw :skip nil))) + (setq pos (match-beginning 0) + ts (match-string 0) + inc t + hd (condition-case nil + (org-remind-cleanup-string + (org-get-heading)) + (error (throw :skip nil))) + summary (org-remind-cleanup-string + (org-entry-get nil "SUMMARY")) + desc (org-remind-cleanup-string + (or (org-entry-get nil "DESCRIPTION") + (and org-remind-include-body (org-get-entry))) + t org-remind-include-body) + location (org-remind-cleanup-string + (org-entry-get nil "LOCATION")) + uid (if org-remind-store-UID + (org-id-get-create) + (or (org-id-get) (org-id-new))) + categories (org-export-get-remind-categories) + deadlinep nil scheduledp nil) + (if (looking-at re2) + (progn + (goto-char (match-end 0)) + (setq ts2 (match-string 1) + inc (not (string-match "[0-9]\\{1,2\\}:[0-9][0-9]" ts2)))) + (setq tmp (buffer-substring (max (point-min) + (- pos org-ds-keyword-length)) + pos) + ts2 (if (string-match "[0-9]\\{1,2\\}:[0-9][0-9]-\\([0-9]\\{1,2\\}:[0-9][0-9]\\)" ts) + (progn + (setq inc nil) + (replace-match "\\1" t nil ts)) + ts) + deadlinep (string-match org-deadline-regexp tmp) + scheduledp (string-match org-scheduled-regexp tmp) + todo (org-get-todo-state) + ;; donep (org-entry-is-done-p) + )) + (when (and + deadlinep + (if todo + (not (memq 'event-if-todo org-remind-use-deadline)) + (not (memq 'event-if-not-todo org-remind-use-deadline)))) + (throw :skip t)) + (when (and + scheduledp + (if todo + (not (memq 'event-if-todo org-remind-use-scheduled)) + (not (memq 'event-if-not-todo org-remind-use-scheduled)))) + (throw :skip t)) + (setq prefix (if deadlinep "DEADLINE-" (if scheduledp "SCHEDULED-" "TS-"))) + (if (or (string-match org-tr-regexp hd) + (string-match org-ts-regexp hd)) + (setq hd (replace-match "" t t hd))) + (if (string-match "\\+\\([0-9]+\\)\\([dwmy]\\)>" ts) + (setq rrule ;is recurrence value. later give it good name. + (* (string-to-number + (cdr (assoc + (match-string 2 ts) + '(("d" . "1")("w" . "7") + ("m" . "0")("y" . "0"))))) + (string-to-number (match-string 1 ts)))) + (setq rrule nil)) + (setq summary (or summary hd)) + (if (string-match org-bracket-link-regexp summary) + (setq summary + (replace-match (if (match-end 3) + (match-string 3 summary) + (match-string 1 summary)) + t t summary))) + (if deadlinep (setq summary (concat "DEADLINE: " summary))) + (if scheduledp (setq summary (concat "SCHEDULED: " summary))) + (if (string-match "\\`<%%" ts) + (with-current-buffer sexp-buffer + (insert (substring ts 1 -1) " " summary "\n")) + (princ (format "\n## BEGIN:EVENT +## UID: %s +REM %s %s MSG EVENT:%s%s %s%s%% +## CATEGORIES:%s +## END:EVENT\n" + (concat prefix uid) + (org-rem-ts-to-string ts nil nil rrule) + (org-rem-ts-to-string ts2 "UNTIL " inc) + summary + (if (and desc (string-match "\\S-" desc)) + (concat "%_\\\n" desc) "") + (if (and location (string-match "\\S-" location)) + (concat "\nLOCATION: " location) "") + (if suppress-last-newline "" "%_") + categories))))) + + (when (and org-remind-include-sexps + (condition-case nil (require 'remind) (error nil)) + (fboundp 'remind-export-region)) + ;; Get all the literal sexps + (goto-char (point-min)) + (while (re-search-forward "^&?%%(" nil t) + (catch :skip + (org-agenda-skip) + (setq b (match-beginning 0)) + (goto-char (1- (match-end 0))) + (forward-sexp 1) + (end-of-line 1) + (setq sexp (buffer-substring b (point))) + (with-current-buffer sexp-buffer + (insert sexp "\n")))) + ;; (princ (org-diary-to-rem-string sexp-buffer)) + (kill-buffer sexp-buffer)) + + (when org-remind-include-todo + (setq prefix "TODO-") + (goto-char (point-min)) + (while (re-search-forward org-todo-line-regexp nil t) + (catch :skip + (org-agenda-skip) + (when (boundp 'org-remind-verify-function) + (unless (funcall org-remind-verify-function) + (outline-next-heading) + (backward-char 1) + (throw :skip nil))) + (setq state (match-string 2)) + (setq status (if (member state org-done-keywords) + "COMPLETED" "NEEDS-ACTION")) + (when (and state + (or (not (member state org-done-keywords)) + (eq org-remind-include-todo 'all)) + (not (member org-archive-tag (org-get-tags-at))) + ) + (setq hd (match-string 3) + summary (org-remind-cleanup-string + (org-entry-get nil "SUMMARY")) + desc (org-remind-cleanup-string + (or (org-entry-get nil "DESCRIPTION") + (and org-remind-include-body (org-get-entry))) + t org-remind-include-body) + location (org-remind-cleanup-string + (org-entry-get nil "LOCATION")) + due (and (member 'todo-due org-remind-use-deadline) + (org-entry-get nil "DEADLINE")) + start (and (member 'todo-start org-remind-use-scheduled) + (org-entry-get nil "SCHEDULED")) + categories (org-export-get-remind-categories) + uid (if org-remind-store-UID + (org-id-get-create) + (or (org-id-get) (org-id-new)))) + + (if (and due start) + (setq diff-days (org-rem-time-diff-days due start))) + + (setq remind-aw + (if due + (if diff-days + (if (> diff-days 0) + (if dos diff-days 0) + (if dos 0 diff-days)) + 1000))) + + (if (and (numberp org-rem-aw) (> org-rem-aw 0)) + (setq remind-aw (+ (or remind-aw 0) org-rem-aw))) + + (setq remind-ew + (if due + (if diff-days + (if (> diff-days 0) due nil) + due))) + + (setq trigger (if dos (if due due start) (if start start due))) + ;; (and trigger (setq trigger (org-rem-ts-to-string trigger nil nil 1 remind-aw))) + (if trigger + (setq trigger (concat + (format "[trigger('%s')] *%d " + (org-rem-ts-to-remind-date-type trigger) 1) + (if remind-aw (format "++%d" remind-aw))))) + (and due (setq due (org-rem-ts-to-remind-date-type due))) + (and start (setq start (org-rem-ts-to-remind-date-type start))) + (and remind-ew (setq remind-ew (org-rem-ts-to-remind-date-type remind-ew))) + + (if (string-match org-bracket-link-regexp hd) + (setq hd (replace-match (if (match-end 3) (match-string 3 hd) + (match-string 1 hd)) + t t hd))) + (if (string-match org-priority-regexp hd) + (setq pri (string-to-char (match-string 2 hd)) + hd (concat (substring hd 0 (match-beginning 1)) + (substring hd (match-end 1)))) + (setq pri org-default-priority)) + (setq pri (floor (1+ (* 8. (/ (float (- org-lowest-priority pri)) + (- org-lowest-priority org-highest-priority)))))) + + (princ (format "\n## BEGIN:TODO +## UID: %s +REM %s %s %s MSG TODO: %s%s%s%s%s%s%% +## CATEGORIES:%s +## SEQUENCE:1 +## STATUS:%s +## END:TODO\n" + (concat prefix uid) + (or trigger "") ;; dts) + (if remind-ew (format "UNTIL [trigger('%s' + %d)]" remind-ew (or org-rem-ew 0)) "") + (if pri (format "PRIORITY %d" pri) "") + (or summary hd) + (if (and desc (string-match "\\S-" desc)) + (concat "%_\\\nDESCRIPTION: " desc) "") + (if (and location (string-match "\\S-" location)) + (concat "LOCATION: " location) "") + (if start + (concat + "%_\\\n['" start "' - today()] " + "days over, for scheduled date - " + "[trigger('" start "')]") "") + (if due + (concat + "%_\\\n[today() - '" due "'] " + "days left, to deadline date - " + "[trigger('" due "')]") "") + (if suppress-last-newline "" "%_") + categories + status))))))))) + +(defun org-export-get-remind-categories () + "Get categories according to `org-remind-categories'." + (let ((cs org-remind-categories) c rtn tmp) + (while (setq c (pop cs)) + (cond + ((eq c 'category) (push (org-get-category) rtn)) + ((eq c 'todo-state) + (setq tmp (org-get-todo-state)) + (and tmp (push tmp rtn))) + ((eq c 'local-tags) + (setq rtn (append (nreverse (org-get-local-tags-at (point))) rtn))) + ((eq c 'all-tags) + (setq rtn (append (nreverse (org-get-tags-at (point))) rtn))))) + (mapconcat 'identity (nreverse rtn) ","))) + +(defun org-remind-cleanup-string (s &optional is-body maxlength) + "Take out stuff and quote what needs to be quoted. +When IS-BODY is non-nil, assume that this is the body of an item, clean up +whitespace, newlines, drawers, and timestamps, and cut it down to MAXLENGTH +characters." + (if (or (not s) (string-match "^[ \t\n]*$" s)) + nil + (when is-body + (let ((re (concat "\\(" org-drawer-regexp "\\)[^\000]*?:END:.*\n?")) + (re2 (concat "^[ \t]*" org-keyword-time-regexp ".*\n?"))) + (while (string-match re s) (setq s (replace-match "" t t s))) + (while (string-match re2 s) (setq s (replace-match "" t t s))))) + (if org-remind-escape-percentage + (let ((start 0)) + (while (string-match "\\([%]\\)" s start) + (setq start (+ (match-beginning 0) 2) + s (replace-match "\\1\\1" nil nil s))))) + + (let ((start 0)) + (while (string-match "\\([\n]\\)" s start) + (setq start (+ (match-beginning 0) 4) ;; less than 4 is not correct. + s (replace-match "%_\\\\\\1" nil nil s)))) + + (let ((start 0)) + (while (string-match "\\([[]\\)" s start) + (setq start (+ (match-beginning 0) 5) + s (replace-match (concat "\[" "\"" "\\1" "\"" "\]") nil nil s)))) + +;;; (when is-body +;;; (while (string-match "[ \t]*\n[ \t]*" s) +;;; (setq s (replace-match "%_" t t s)))) + + (setq s (org-trim s)) + (if is-body + (if maxlength + (if (and (numberp maxlength) + (> (length s) maxlength)) + (setq s (substring s 0 maxlength))))) + s)) + +(defun org-get-entry () + "Clean-up description string." + (save-excursion + (org-back-to-heading t) + (buffer-substring (point-at-bol 2) (org-end-of-subtree t)))) + +(defun org-start-remind-file (name) + "Start an Remind file by inserting the header." + (let ((user user-full-name) + (name (or name "unknown")) + (timezone (cadr (current-time-zone)))) + (princ + (format "# -*- Mode: shell-script; auto-fill-mode: nil -*- +## BEGIN: Reminders +## VERSION:2.0 +## Emacs with Org-mode +## Calendar:%s +## Created by: %s +## Timezone:%s +## Calscale:Gregorian\n" name user timezone)))) + +(defun org-finish-remind-file () + "Finish an Remind file by inserting the END statement." + (princ "\n## END:Reminders\n")) + +(defun org-rem-ts-to-remind-date-type (s) + (format-time-string + "%Y-%m-%d" + (apply 'encode-time (butlast (org-parse-time-string s) 3)))) + +;; (defun org-rem-date-type-to-string (s keyword &optional inc day-repeat day-advance-warn) +;; (if trigger +;; (setq trigger +;; (concat +;; (format "[trigger('%s')] *%d " +;; (org-rem-ts-to-remind-date-type trigger) day-repeat) +;; (if day-advance-warn (format "++%d" day-advance-warn)))))) + +;; (format-time-string "%Y" +;; (apply 'encode-time (butlast (org-parse-time-string "<2008-11-20 Thu 10:30>") 3))) + +(defun org-rem-ts-to-string (s keyword &optional inc day-repeat day-advance-warn) + "Take a time string S and convert it to Remind format. +KEYWORD is added in front, to make a complete line like DTSTART.... +When INC is non-nil, increase the hour by two (if time string contains +a time), or the day by one (if it does not contain a time)." + (let ((t1 (org-parse-time-string s 'nodefault)) + t2 fmt have-time time) + (if (and (car t1) (nth 1 t1) (nth 2 t1)) + (setq t2 t1 have-time t) + (setq t2 (org-parse-time-string s))) + (let ((s (car t2)) (mi (nth 1 t2)) (h (nth 2 t2)) + (d (nth 3 t2)) (m (nth 4 t2)) (y (nth 5 t2))) + (when inc + (if have-time + (if org-agenda-default-appointment-duration + (setq mi (+ org-agenda-default-appointment-duration mi)) + (setq h (+ 2 h))) + (setq d (1+ d)))) + (setq time (encode-time s mi h d m y))) + (setq fmt (concat + "%d %b %Y" + (if day-advance-warn (format " ++%d" day-advance-warn)) + (if day-repeat (format " *%d" day-repeat)) + (if have-time " AT %H:%M"))) + (concat keyword (format-time-string fmt time)))) + +(defun org-rem-time-diff-days (end start) + (floor (/ (apply '- (mapcar + (lambda (s) + (let* + ((t1 (org-parse-time-string s)) + (s (car t1)) (mi (nth 1 t1)) + (h (nth 2 t1)) (d (nth 3 t1)) + (m (nth 4 t1)) (y (nth 5 t1))) + (float-time (encode-time s mi h d m y)))) + (list end start))) (* 24 60 60)))) + +(provide 'org2rem) + +;; arch-tag: 65985fe9-095c-49c7-a7b6-cb4ee15c0a95 + +;;; org-exp.el ends here diff --git a/.emacs.d/org-7.4/contrib/lisp/orgtbl-sqlinsert.el b/.emacs.d/org-7.4/contrib/lisp/orgtbl-sqlinsert.el new file mode 100644 index 0000000..648e44c --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/orgtbl-sqlinsert.el @@ -0,0 +1,115 @@ +;;; orgtbl-sqlinsert.el --- orgtbl to SQL insert statements. + +;; Copyright (C) 2008 Free Software Foundation + +;; Author: Jason Riedy <jason@acm.org> +;; Keywords: org, tables, sql + +;; 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 name + :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 (lst) (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/.emacs.d/org-7.4/contrib/lisp/test-org-export-preproc.el b/.emacs.d/org-7.4/contrib/lisp/test-org-export-preproc.el new file mode 100644 index 0000000..3af8461 --- /dev/null +++ b/.emacs.d/org-7.4/contrib/lisp/test-org-export-preproc.el @@ -0,0 +1,39 @@ +(require 'org-export-generic) + +(defun test-preproc () + (interactive) + (let ((string + (let ((region + (buffer-substring + (if (org-region-active-p) (region-beginning) (point-min)) + (if (org-region-active-p) (region-end) (point-max)))) + (opt-plist (org-combine-plists (org-default-export-plist) + (org-infile-export-plist))) + (export-plist '("tikiwiki" :file-suffix ".txt" :key-binding 85 :header-prefix "" :header-suffix "" :title-format "-= %s =-\n" :date-export nil :toc-export nil :body-header-section-numbers nil :body-section-prefix "\n" :body-section-header-prefix + ("! " "!! " "!!! " "!!!! " "!!!!! " "!!!!!! " "!!!!!!! ") + :body-section-header-suffix + (" \n" " \n" " \n" " \n" " \n" " \n") + :body-line-export-preformated t :body-line-format "%s " :body-line-wrap nil :body-line-fixed-format " %s\n" :body-list-format "* %s\n" :body-number-list-format "# %s\n" :blockquote-start "\n^\n" :blockquote-end "^\n\n" :body-newline-paragraph "\n" :bold-format "__%s__" :italic-format "''%s''" :underline-format "===%s===" :strikethrough-format "--%s--" :code-format "-+%s+-" :verbatim-format "~pp~%s~/pp~"))) + (org-export-preprocess-string + region + :for-ascii t + :skip-before-1st-heading + (plist-get opt-plist :skip-before-1st-heading) + :drawers (plist-get export-plist :drawers-export) + :tags (plist-get export-plist :tags-export) + :priority (plist-get export-plist :priority-export) + :footnotes (plist-get export-plist :footnotes-export) + :timestamps (plist-get export-plist :timestamps-export) + :todo-keywords (plist-get export-plist :todo-keywords-export) + :verbatim-multiline t + :select-tags (plist-get export-plist :select-tags-export) + :exclude-tags (plist-get export-plist :exclude-tags-export) + :emph-multiline t + :archived-trees + (plist-get export-plist :archived-trees-export) + :add-text (plist-get opt-plist :text))))) + (save-excursion + (switch-to-buffer "*preproc-temp*") + (point-max) + (insert string)))) + |