mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2025-01-23 18:47:57 +00:00
Code Issues Releases Activity

Fix previous commit: remove files that are not part of Org 8.2.3a anymore

Browse Source
This commit is contained in:
Bastien Guerry 2013-11-12 14:13:04 +01:00
parent 271672fad7
commit 9b1ee27c6c
20 changed files with 0 additions and 21717 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

730
lisp/org/org-ascii.el
View File

@ -1,730 +0,0 @@
;;; org-ascii.el --- ASCII export for Org-mode
;; Copyright (C) 2004-2013 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
;;
;; 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:
;;; Code:
(require 'org-exp)
(eval-when-compile
(require 'cl))
(defgroup org-export-ascii nil
"Options specific for ASCII export of Org-mode files."
:tag "Org Export ASCII"
:group 'org-export)
(defcustom org-export-ascii-underline '(?\= ?\- ?\~ ?\^ ?\. ?\# ?\$)
"Characters for underlining headings in ASCII export.
In the given sequence, these characters will be used for level 1, 2, ..."
:group 'org-export-ascii
:type '(repeat character))
(defcustom org-export-ascii-bullets '(?* ?+ ?-)
"Bullet characters for headlines converted to lists in ASCII export.
The first character is used for the first lest level generated in this
way, and so on. If there are more levels than characters given here,
the list will be repeated.
Note that plain lists will keep the same bullets as the have in the
Org-mode file."
:group 'org-export-ascii
:type '(repeat character))
(defcustom org-export-ascii-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-ascii
:type 'boolean)
(defcustom org-export-ascii-table-keep-all-vertical-lines nil
"Non-nil means keep all vertical lines in ASCII tables.
When nil, vertical lines will be removed except for those needed
for column grouping."
:group 'org-export-ascii
:type 'boolean)
(defcustom org-export-ascii-table-widen-columns t
"Non-nil means widen narrowed columns for export.
When nil, narrowed columns will look in ASCII export just like in org-mode,
i.e. with \"=>\" as ellipsis."
:group 'org-export-ascii
:type 'boolean)
(defvar org-export-ascii-entities 'ascii
"The ascii representation to be used during ascii export.
Possible values are:
ascii Only use plain ASCII characters
latin1 Include Latin-1 character
utf8 Use all UTF-8 characters")
;;; Hooks
(defvar org-export-ascii-final-hook nil
"Hook run at the end of ASCII export, in the new buffer.")
;;; ASCII export
(defvar org-ascii-current-indentation nil) ; For communication
;;;###autoload
(defun org-export-as-latin1 (&rest args)
"Like `org-export-as-ascii', use latin1 encoding for special symbols."
(interactive)
(org-export-as-encoding 'org-export-as-ascii (org-called-interactively-p 'any)
'latin1 args))
;;;###autoload
(defun org-export-as-latin1-to-buffer (&rest args)
"Like `org-export-as-ascii-to-buffer', use latin1 encoding for symbols."
(interactive)
(org-export-as-encoding 'org-export-as-ascii-to-buffer
(org-called-interactively-p 'any) 'latin1 args))
;;;###autoload
(defun org-export-as-utf8 (&rest args)
"Like `org-export-as-ascii', use encoding for special symbols."
(interactive)
(org-export-as-encoding 'org-export-as-ascii
(org-called-interactively-p 'any)
'utf8 args))
;;;###autoload
(defun org-export-as-utf8-to-buffer (&rest args)
"Like `org-export-as-ascii-to-buffer', use utf8 encoding for symbols."
(interactive)
(org-export-as-encoding 'org-export-as-ascii-to-buffer
(org-called-interactively-p 'any) 'utf8 args))
(defun org-export-as-encoding (command interactivep encoding &rest args)
(let ((org-export-ascii-entities encoding))
(if interactivep
(call-interactively command)
(apply command args))))
;;;###autoload
(defun org-export-as-ascii-to-buffer (arg)
"Call `org-export-as-ascii` with output to a temporary buffer.
No file is created. The prefix ARG is passed through to `org-export-as-ascii'."
(interactive "P")
(org-export-as-ascii arg nil "*Org ASCII Export*")
(when org-export-show-temporary-export-buffer
(switch-to-buffer-other-window "*Org ASCII Export*")))
;;;###autoload
(defun org-replace-region-by-ascii (beg end)
"Assume the current region has org-mode syntax, and convert it to plain ASCII.
This can be used in any buffer. For example, you could write an
itemized list in org-mode syntax in a Mail buffer and then use this
command to convert it."
(interactive "r")
(let (reg ascii buf pop-up-frames)
(save-window-excursion
(if (derived-mode-p 'org-mode)
(setq ascii (org-export-region-as-ascii
beg end t 'string))
(setq reg (buffer-substring beg end)
buf (get-buffer-create "*Org tmp*"))
(with-current-buffer buf
(erase-buffer)
(insert reg)
(org-mode)
(setq ascii (org-export-region-as-ascii
(point-min) (point-max) t 'string)))
(kill-buffer buf)))
(delete-region beg end)
(insert ascii)))
;;;###autoload
(defun org-export-region-as-ascii (beg end &optional body-only buffer)
"Convert region from BEG to END in org-mode buffer to plain ASCII.
If prefix arg BODY-ONLY is set, omit file header, footer, and table of
contents, and only produce the region of converted text, useful for
cut-and-paste operations.
If BUFFER is a buffer or a string, use/create that buffer as a target
of the converted ASCII. If BUFFER is the symbol `string', return the
produced ASCII as a string and leave not buffer behind. For example,
a Lisp program could call this function in the following way:
(setq ascii (org-export-region-as-ascii beg end t 'string))
When called interactively, the output buffer is selected, and shown
in a window. A non-interactive call will only return the buffer."
(interactive "r\nP")
(when (org-called-interactively-p 'any)
(setq buffer "*Org ASCII Export*"))
(let ((transient-mark-mode t) (zmacs-regions t)
ext-plist rtn)
(setq ext-plist (plist-put ext-plist :ignore-subtree-p t))
(goto-char end)
(set-mark (point)) ;; to activate the region
(goto-char beg)
(setq rtn (org-export-as-ascii nil ext-plist buffer body-only))
(if (fboundp 'deactivate-mark) (deactivate-mark))
(if (and (org-called-interactively-p 'any) (bufferp rtn))
(switch-to-buffer-other-window rtn)
rtn)))
;;;###autoload
(defun org-export-as-ascii (arg &optional ext-plist to-buffer body-only pub-dir)
"Export the outline as a pretty ASCII file.
If there is an active region, export only the region.
The prefix ARG specifies how many levels of the outline should become
underlined headlines, default is 3. Lower levels will become bulleted
lists. EXT-PLIST is a property list with external parameters overriding
org-mode's default settings, but still inferior to file-local
settings. When TO-BUFFER is non-nil, create a buffer with that
name and export to that buffer. If TO-BUFFER is the symbol
`string', don't leave any buffer behind but just return the
resulting ASCII as a string. When BODY-ONLY is set, don't produce
the file header and footer. When PUB-DIR is set, use this as the
publishing directory."
(interactive "P")
(run-hooks 'org-export-first-hook)
(setq-default org-todo-line-regexp org-todo-line-regexp)
(let* ((opt-plist (org-combine-plists (org-default-export-plist)
ext-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
(if (plist-get opt-plist :ignore-subtree-p)
nil
(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)))
;; The following two are dynamically scoped into other
;; routines below.
(org-current-export-dir
(or pub-dir (org-export-directory :html opt-plist)))
(org-current-export-file buffer-file-name)
(custom-times org-display-custom-times)
(org-ascii-current-indentation '(0 . 0))
(level 0) line txt
(umax nil)
(umax-toc nil)
(case-fold-search nil)
(bfname (buffer-file-name (or (buffer-base-buffer) (current-buffer))))
(filename (if to-buffer
nil
(concat (file-name-as-directory
(or pub-dir
(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)))
".txt")))
(filename (and filename
(if (equal (file-truename filename)
(file-truename bfname))
(concat filename ".txt")
filename)))
(buffer (if to-buffer
(cond
((eq to-buffer 'string)
(get-buffer-create "*Org ASCII Export*"))
(t (get-buffer-create to-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))
(and (buffer-file-name)
(file-name-sans-extension
(file-name-nondirectory bfname)))
"UNTITLED"))
(email (plist-get opt-plist :email))
(language (plist-get opt-plist :language))
(quote-re0 (concat "^\\(" org-quote-string "\\)\\( +\\|[ \t]*$\\)"))
(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))))
(org-export-footnotes-seen nil)
(org-export-footnotes-data (org-footnote-all-labels 'with-defs))
(lines (org-split-string
(org-export-preprocess-string
region
:for-backend 'ascii
:skip-before-1st-heading
(plist-get opt-plist :skip-before-1st-heading)
:drawers (plist-get opt-plist :drawers)
:tags (plist-get opt-plist :tags)
:priority (plist-get opt-plist :priority)
:footnotes (plist-get opt-plist :footnotes)
:timestamps (plist-get opt-plist :timestamps)
:todo-keywords (plist-get opt-plist :todo-keywords)
:tasks (plist-get opt-plist :tasks)
:verbatim-multiline t
:select-tags (plist-get opt-plist :select-tags)
:exclude-tags (plist-get opt-plist :exclude-tags)
:archived-trees
(plist-get opt-plist :archived-trees)
:add-text (plist-get opt-plist :text))
"\n"))
thetoc have-headings first-heading-pos
table-open table-buffer link-buffer link type path desc desc0 rpl wrap fnc)
(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)
(setq lang-words (or (assoc language org-export-language-setup)
(assoc "en" org-export-language-setup)))
(set-buffer buffer)
(erase-buffer)
(fundamental-mode)
(org-install-letbind)
;; 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 (if (integerp org-export-with-toc)
(min org-export-with-toc umax)
umax))
;; File header
(unless body-only
(when (and title (not (string= "" title)))
(org-insert-centered title ?=)
(insert "\n"))
(if (and (or author email)
org-export-author-info)
(insert (concat (nth 1 lang-words) ": " (or author "")
(if (and org-export-email-info
email (string-match "\\S-" 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 org-export-time-stamp-file)
(insert (concat (nth 2 lang-words) ": " date"\n")))
(unless (= (point) (point-min))
(insert "\n\n")))
(if (and org-export-with-toc (not body-only))
(progn
(push (concat (nth 3 lang-words) "\n") thetoc)
(push (concat (make-string (string-width (nth 3 lang-words)) ?=)
"\n") 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-ascii 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 (memq org-export-with-tags '(not-in-toc nil))
(string-match
(org-re "[ \t]+:[[:alnum:]_@#%:]+:[ \t]*$")
txt))
(setq txt (replace-match "" t t txt)))
(if (string-match quote-re0 txt)
(setq txt (replace-match "" t t txt 1)))
(if org-export-with-section-numbers
(setq txt (concat (org-section-number level)
" " txt)))
(if (<= level umax-toc)
(progn
(push
(concat
(make-string
(* (max 0 (- level org-min-level)) 4) ?\ )
(format (if todo "%s (*)\n" "%s\n") txt))
thetoc)
(setq org-last-level level))
))))
lines)
(setq thetoc (if have-headings (nreverse thetoc) nil))))
(org-init-section-numbers)
(while (setq line (pop lines))
(when (and link-buffer (string-match org-outline-regexp-bol line))
(org-export-ascii-push-links (nreverse link-buffer))
(setq link-buffer nil))
(setq wrap nil)
;; Remove the quoted HTML tags.
(setq line (org-html-expand-for-ascii line))
;; Replace links with the description when possible
(while (string-match org-bracket-link-analytic-regexp++ line)
(setq path (match-string 3 line)
link (concat (match-string 1 line) path)
type (match-string 2 line)
desc0 (match-string 5 line)
desc0 (replace-regexp-in-string "\\\\_" "_" desc0)
desc (or desc0 link)
desc (replace-regexp-in-string "\\\\_" "_" desc))
(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 "[" desc "]"))
(if (functionp (setq fnc (nth 2 (assoc type org-link-protocols))))
(setq rpl (or (save-match-data
(funcall fnc (org-link-unescape path)
desc0 'ascii))
rpl))
(when (and desc0 (not (equal desc0 link)))
(if org-export-ascii-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
(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-ascii-level-start level txt umax lines))
((and org-export-with-tables
(string-match "^\\([ \t]*\\)\\(|\\|\\+-+\\+\\)" line))
(if (not table-open)
;; New table starts
(setq table-open t table-buffer nil))
;; Accumulate 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-ascii-current-indentation))
(org-format-table-ascii table-buffer)
"\n") "\n")))
(t
(if (string-match "^\\([ \t]*\\)\\([-+*][ \t]+\\)\\(.*?\\)\\( ::\\)"
line)
(setq line (replace-match "\\1\\3:" t nil line)))
(setq line (org-fix-indentation line org-ascii-current-indentation))
;; Remove forced line breaks
(if (string-match "\\\\\\\\[ \t]*$" line)
(setq line (replace-match "" t t line)))
(if (and org-export-with-fixed-width
(string-match "^\\([ \t]*\\)\\(:\\( \\|$\\)\\)" line))
(setq line (replace-match "\\1" nil nil line))
(if wrap (setq line (org-export-ascii-wrap line wrap))))
(insert line "\n"))))
(org-export-ascii-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) ?\ ))))
;; 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)))
(run-hooks 'org-export-ascii-final-hook)
(or to-buffer (save-buffer))
(goto-char (point-min))
(or (org-export-push-to-kill-ring "ASCII")
(message "Exporting... done"))
;; Return the buffer or a string, according to how this function was called
(if (eq to-buffer 'string)
(prog1 (buffer-substring (point-min) (point-max))
(kill-buffer (current-buffer)))
(current-buffer))))
;;;###autoload
(defun org-export-ascii-preprocess (parameters)
"Do extra work for ASCII export."
;;
;; Realign tables to get rid of narrowing
(when org-export-ascii-table-widen-columns
(let ((org-table-do-narrow nil))
(goto-char (point-min))
(org-ascii-replace-entities)
(goto-char (point-min))
(org-table-map-tables
(lambda () (org-if-unprotected (org-table-align)))
'quietly)))
;; Put quotes around verbatim text
(goto-char (point-min))
(while (re-search-forward org-verbatim-re nil t)
(org-if-unprotected-at (match-beginning 4)
(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)
(org-if-unprotected-at (match-beginning 1)
(replace-match "\\1\\2")))
;; Remove list start counters
(goto-char (point-min))
(while (org-list-search-forward
"\\[@\\(?:start:\\)?\\([0-9]+\\|[A-Za-z]\\)\\][ \t]*" nil t)
(replace-match ""))
(remove-text-properties
(point-min) (point-max)
'(face nil font-lock-fontified nil font-lock-multiline nil line-prefix nil wrap-prefix nil)))
(defun org-html-expand-for-ascii (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-ascii-replace-entities ()
"Replace entities with the ASCII representation."
(let (e)
(while (re-search-forward "\\\\\\([a-zA-Z]+[0-9]*\\)\\({}\\)?" nil t)
(org-if-unprotected-at (match-beginning 1)
(setq e (org-entity-get-representation (match-string 1)
org-export-ascii-entities))
(and e (replace-match e t t))))))
(defun org-export-ascii-wrap (line where)
"Wrap LINE at or before WHERE."
(let ((ind (org-get-indentation line))
pos)
(catch 'found
(loop for i from where downto (/ where 2) do
(and (equal (aref line i) ?\ )
(setq pos i)
(throw 'found t))))
(if pos
(concat (substring line 0 pos) "\n"
(make-string ind ?\ )
(substring line (1+ pos)))
line)))
(defun org-export-ascii-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
(concat "^\\(\\([ \t]*\\)\\|\\("
org-outline-regexp
"\\)\\)[^ \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-ascii-level-start (level title umax &optional lines)
"Insert a new level in ASCII export."
(let (char (n (- level umax 1)) (ind 0))
(if (> level umax)
(progn
(insert (make-string (* 2 n) ?\ )
(char-to-string (nth (% n (length org-export-ascii-bullets))
org-export-ascii-bullets))
" " title "\n")
;; find the indentation of the next non-empty line
(catch 'stop
(while lines
(if (string-match "^\\* " (car lines)) (throw 'stop nil))
(if (string-match "^\\([ \t]*\\)\\S-" (car lines))
(throw 'stop (setq ind (org-get-indentation (car lines)))))
(pop lines)))
(setq org-ascii-current-indentation (cons (* 2 (1+ n)) ind)))
(if (or (not (equal (char-before) ?\n))
(not (equal (char-before (1- (point))) ?\n)))
(insert "\n"))
(setq char (or (nth (1- level) org-export-ascii-underline)
(car (last org-export-ascii-underline))))
(unless org-export-with-tags
(if (string-match (org-re "[ \t]+\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$") title)
(setq title (replace-match "" t t title))))
(if org-export-with-section-numbers
(setq title (concat (org-section-number level) " " title)))
(insert title "\n" (make-string (string-width title) char) "\n")
(setq org-ascii-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-ascii (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
(if org-export-ascii-table-keep-all-vertical-lines
lines
(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))
(provide 'org-ascii)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; org-ascii.el ends here

657
lisp/org/org-beamer.el
View File

@ -1,657 +0,0 @@
;;; org-beamer.el --- Beamer-specific LaTeX export for org-mode
;;
;; Copyright (C) 2007-2013 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten.dominik AT gmail DOT com>
;; Maintainer: Carsten Dominik <carsten.dominik AT gmail DOT com>
;; Keywords: org, wp, tex
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; This library implement the special treatment needed by using the
;; beamer class during LaTeX export.
;;; Code:
(require 'org)
(require 'org-exp)
(defvar org-export-latex-header)
(defvar org-export-latex-options-plist)
(defvar org-export-opt-plist)
(defgroup org-beamer nil
"Options specific for using the beamer class in LaTeX export."
:tag "Org Beamer"
:group 'org-export-latex)
(defcustom org-beamer-use-parts nil
""
:group 'org-beamer
:version "24.1"
:type 'boolean)
(defcustom org-beamer-frame-level 1
"The level that should be interpreted as a frame.
The levels above this one will be translated into a sectioning structure.
Setting this to 2 will allow sections, 3 will allow subsections as well.
You can set this to 4 as well, if you at the same time set
`org-beamer-use-parts' to make the top levels `\part'."
:group 'org-beamer
:version "24.1"
:type '(choice
(const :tag "Frames need a BEAMER_env property" nil)
(integer :tag "Specific level makes a frame")))
(defcustom org-beamer-frame-default-options ""
"Default options string to use for frames, should contains the [brackets].
And example for this is \"[allowframebreaks]\"."
:group 'org-beamer
:version "24.1"
:type '(string :tag "[options]"))
(defcustom org-beamer-column-view-format
"%45ITEM %10BEAMER_env(Env) %10BEAMER_envargs(Env Args) %4BEAMER_col(Col) %8BEAMER_extra(Extra)"
"Default column view format that should be used to fill the template."
:group 'org-beamer
:version "24.1"
:type '(choice
(const :tag "Do not insert Beamer column view format" nil)
(string :tag "Beamer column view format")))
(defcustom org-beamer-themes
"\\usetheme{default}\\usecolortheme{default}"
"Default string to be used for extra heading stuff in beamer presentations.
When a beamer template is filled, this will be the default for
BEAMER_HEADER_EXTRA, which will be inserted just before \\begin{document}."
:group 'org-beamer
:version "24.1"
:type '(choice
(const :tag "Do not insert Beamer themes" nil)
(string :tag "Beamer themes")))
(defconst org-beamer-column-widths
"0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 0.0 :ETC"
"The column widths that should be installed as allowed property values.")
(defconst org-beamer-transitions
"\transblindsvertical \transblindshorizontal \transboxin \transboxout \transdissolve \transduration \transglitter \transsplithorizontalin \transsplithorizontalout \transsplitverticalin \transsplitverticalout \transwipe :ETC"
"Transitions available for beamer.
These are just a completion help.")
(defconst org-beamer-environments-default
'(("frame" "f" "dummy- special handling hard coded" "dummy")
("columns" "C" "\\begin{columns}%o %% %h%x" "\\end{columns}")
("column" "c" "\\begin{column}%o{%h\\textwidth}%x" "\\end{column}")
("block" "b" "\\begin{block}%a{%h}%x" "\\end{block}")
("alertblock" "a" "\\begin{alertblock}%a{%h}%x" "\\end{alertblock}")
("verse" "v" "\\begin{verse}%a %% %h%x" "\\end{verse}")
("quotation" "q" "\\begin{quotation}%a %% %h%x" "\\end{quotation}")
("quote" "Q" "\\begin{quote}%a %% %h%x" "\\end{quote}")
("structureenv" "s" "\\begin{structureenv}%a %% %h%x" "\\end{structureenv}")
("theorem" "t" "\\begin{theorem}%a%U%x" "\\end{theorem}")
("definition" "d" "\\begin{definition}%a%U%x" "\\end{definition}")
("example" "e" "\\begin{example}%a%U%x" "\\end{example}")
("exampleblock" "E" "\\begin{exampleblock}%a{%h}%x" "\\end{exampleblock}")
("proof" "p" "\\begin{proof}%a%U%x" "\\end{proof}")
("beamercolorbox" "o" "\\begin{beamercolorbox}%o{%h}%x" "\\end{beamercolorbox}")
("normal" "h" "%h" "") ; Emit the heading as normal text
("note" "n" "\\note%o%a{%h" "}")
("noteNH" "N" "\\note%o%a{" "}") ; note, ignore heading
("ignoreheading" "i" "%%%% %h" ""))
"Environments triggered by properties in Beamer export.
These are the defaults - for user definitions, see
`org-beamer-environments-extra'.
\"normal\" is a special fake environment, which emit the heading as
normal text. It is needed when an environment should be surrounded
by normal text. Since beamer export converts nodes into environments,
you need to have a node to end the environment.
For example
** a frame
some text
*** Blocktitle :B_block:
inside the block
*** After the block :B_normal:
continuing here
** next frame")
(defcustom org-beamer-environments-extra nil
"Environments triggered by tags in Beamer export.
Each entry has 4 elements:
name Name of the environment
key Selection key for `org-beamer-select-environment'
open The opening template for the environment, with the following escapes
%a the action/overlay specification
%A the default action/overlay specification
%o the options argument of the template
%h the headline text
%H if there is headline text, that text in {} braces
%U if there is headline text, that text in [] brackets
%x the content of the BEAMER_extra property
close The closing string of the environment."
:group 'org-beamer
:version "24.1"
:type '(repeat
(list
(string :tag "Environment")
(string :tag "Selection key")
(string :tag "Begin")
(string :tag "End"))))
(defcustom org-beamer-inherited-properties nil
"Properties that should be inherited during beamer export."
:group 'org-beamer
:type '(repeat
(string :tag "Property")))
(defvar org-beamer-frame-level-now nil)
(defvar org-beamer-header-extra nil)
(defvar org-beamer-export-is-beamer-p nil)
(defvar org-beamer-inside-frame-at-level nil)
(defvar org-beamer-columns-open nil)
(defvar org-beamer-column-open nil)
(defun org-beamer-cleanup-column-width (width)
"Make sure the width is not empty, and that it has a unit."
(setq width (org-trim (or width "")))
(unless (string-match "\\S-" width) (setq width "0.5"))
(if (string-match "\\`[.0-9]+\\'" width)
(setq width (concat width "\\textwidth")))
width)
(defun org-beamer-open-column (&optional width opt)
(org-beamer-close-column-maybe)
(setq org-beamer-column-open t)
(setq width (org-beamer-cleanup-column-width width))
(insert (format "\\begin{column}%s{%s}\n" (or opt "") width)))
(defun org-beamer-close-column-maybe ()
(when org-beamer-column-open
(setq org-beamer-column-open nil)
(insert "\\end{column}\n")))
(defun org-beamer-open-columns-maybe (&optional opts)
(unless org-beamer-columns-open
(setq org-beamer-columns-open t)
(insert (format "\\begin{columns}%s\n" (or opts "")))))
(defun org-beamer-close-columns-maybe ()
(org-beamer-close-column-maybe)
(when org-beamer-columns-open
(setq org-beamer-columns-open nil)
(insert "\\end{columns}\n")))
(defun org-beamer-select-environment ()
"Select the environment to be used by beamer for this entry.
While this uses (for convenience) a tag selection interface, the result
of this command will be that the BEAMER_env *property* of the entry is set.
In addition to this, the command will also set a tag as a visual aid, but
the tag does not have any semantic meaning."
(interactive)
(let* ((envs (append org-beamer-environments-extra
org-beamer-environments-default))
(org-tag-alist
(append '((:startgroup))
(mapcar (lambda (e) (cons (concat "B_" (car e))
(string-to-char (nth 1 e))))
envs)
'((:endgroup))
'(("BMCOL" . ?|))))
(org-fast-tag-selection-single-key t))
(org-set-tags)
(let ((tags (or (ignore-errors (org-get-tags-string)) "")))
(cond
((equal org-last-tag-selection-key ?|)
(if (string-match ":BMCOL:" tags)
(org-set-property "BEAMER_col" (read-string "Column width: "))
(org-delete-property "BEAMER_col")))
((string-match (concat ":B_\\("
(mapconcat 'car envs "\\|")
"\\):")
tags)
(org-entry-put nil "BEAMER_env" (match-string 1 tags)))
(t (org-entry-delete nil "BEAMER_env"))))))
;;;###autoload
(defun org-beamer-sectioning (level text)
"Return the sectioning entry for the current headline.
LEVEL is the reduced level of the headline.
TEXT is the text of the headline, everything except the leading stars.
The return value is a cons cell. The car is the headline text, usually
just TEXT, but possibly modified if options have been extracted from the
text. The cdr is the sectioning entry, similar to what is given
in org-export-latex-classes."
(let* ((frame-level (or org-beamer-frame-level-now org-beamer-frame-level))
(default
(if org-beamer-use-parts
'((1 . ("\\part{%s}" . "\\part*{%s}"))
(2 . ("\\section{%s}" . "\\section*{%s}"))
(3 . ("\\subsection{%s}" . "\\subsection*{%s}")))
'((1 . ("\\section{%s}" . "\\section*{%s}"))
(2 . ("\\subsection{%s}" . "\\subsection*{%s}")))))
(envs (append org-beamer-environments-extra
org-beamer-environments-default))
(props (org-get-text-property-any 0 'org-props text))
(in "") (out "") org-beamer-option org-beamer-action org-beamer-defaction org-beamer-environment org-beamer-extra
columns-option column-option
env have-text ass tmp)
(if (= frame-level 0) (setq frame-level nil))
(when (and org-beamer-inside-frame-at-level
(<= level org-beamer-inside-frame-at-level))
(setq org-beamer-inside-frame-at-level nil))
(when (setq tmp (org-beamer-assoc-not-empty "BEAMER_col" props))
(if (and (string-match "\\`[0-9.]+\\'" tmp)
(or (= (string-to-number tmp) 1.0)
(= (string-to-number tmp) 0.0)))
;; column width 1 means close columns, go back to full width
(org-beamer-close-columns-maybe)
(when (setq ass (assoc "BEAMER_envargs" props))
(let (case-fold-search)
(while (string-match "C\\(\\[[^][]*\\]\\|<[^<>]*>\\)" (cdr ass))
(setq columns-option (match-string 1 (cdr ass)))
(setcdr ass (replace-match "" t t (cdr ass))))
(while (string-match "c\\(\\[[^][]*\\]\\|<[^<>]*>\\)" (cdr ass))
(setq column-option (match-string 1 (cdr ass)))
(setcdr ass (replace-match "" t t (cdr ass))))))
(org-beamer-open-columns-maybe columns-option)
(org-beamer-open-column tmp column-option)))
(cond
((or (equal (cdr (assoc "BEAMER_env" props)) "frame")
(and frame-level (= level frame-level)))
;; A frame
(org-beamer-get-special props)
(setq in (org-fill-template
"\\begin{frame}%a%A%o%T%S%x"
(list (cons "a" (or org-beamer-action ""))
(cons "A" (or org-beamer-defaction ""))
(cons "o" (or org-beamer-option org-beamer-frame-default-options ""))
(cons "x" (if org-beamer-extra (concat "\n" org-beamer-extra) ""))
(cons "h" "%s")
(cons "T" (if (string-match "\\S-" text)
"\n\\frametitle{%s}" ""))
(cons "S" (if (string-match "\\\\\\\\" text)
"\n\\framesubtitle{%s}" ""))))
out (copy-sequence "\\end{frame}"))
(org-add-props out
'(org-insert-hook org-beamer-close-columns-maybe))
(setq org-beamer-inside-frame-at-level level)
(cons text (list in out in out)))
((and (setq env (cdr (assoc "BEAMER_env" props)))
(setq ass (assoc env envs)))
;; A beamer environment selected by the BEAMER_env property
(if (string-match "[ \t]+:[ \t]*$" text)
(setq text (replace-match "" t t text)))
(if (member env '("note" "noteNH"))
;; There should be no labels in a note, so we remove the targets
;; FIXME???
(remove-text-properties 0 (length text) '(target nil) text))
(org-beamer-get-special props)
(setq text (org-trim text))
(setq have-text (string-match "\\S-" text))
(setq in (org-fill-template
(nth 2 ass)
(list (cons "a" (or org-beamer-action ""))
(cons "A" (or org-beamer-defaction ""))
(cons "o" (or org-beamer-option ""))
(cons "x" (if org-beamer-extra (concat "\n" org-beamer-extra) ""))
(cons "h" "%s")
(cons "H" (if have-text (concat "{" text "}") ""))
(cons "U" (if have-text (concat "[" text "]") ""))))
out (nth 3 ass))
(cond
((equal out "\\end{columns}")
(setq org-beamer-columns-open t)
(setq out (org-add-props (copy-sequence out)
'(org-insert-hook
(lambda ()
(org-beamer-close-column-maybe)
(setq org-beamer-columns-open nil))))))
((equal out "\\end{column}")
(org-beamer-open-columns-maybe)))
(cons text (list in out in out)))
((and (not org-beamer-inside-frame-at-level)
(or (not frame-level)
(< level frame-level))
(assoc level default))
;; Normal sectioning
(cons text (cdr (assoc level default))))
(t nil))))
(defvar org-beamer-extra)
(defvar org-beamer-option)
(defvar org-beamer-action)
(defvar org-beamer-defaction)
(defvar org-beamer-environment)
(defun org-beamer-get-special (props)
"Extract an option, action, and default action string from text.
The variables org-beamer-option, org-beamer-action, org-beamer-defaction,
org-beamer-extra are all scoped into this function dynamically."
(let (tmp)
(setq org-beamer-environment (org-beamer-assoc-not-empty "BEAMER_env" props))
(setq org-beamer-extra (org-beamer-assoc-not-empty "BEAMER_extra" props))
(when org-beamer-extra
(setq org-beamer-extra (replace-regexp-in-string "\\\\n" "\n" org-beamer-extra)))
(setq tmp (org-beamer-assoc-not-empty "BEAMER_envargs" props))
(when tmp
(setq tmp (copy-sequence tmp))
(if (string-match "\\[<[^][<>]*>\\]" tmp)
(setq org-beamer-defaction (match-string 0 tmp)
tmp (replace-match "" t t tmp)))
(if (string-match "\\[[^][]*\\]" tmp)
(setq org-beamer-option (match-string 0 tmp)
tmp (replace-match "" t t tmp)))
(if (string-match "<[^<>]*>" tmp)
(setq org-beamer-action (match-string 0 tmp)
tmp (replace-match "" t t tmp))))))
(defun org-beamer-assoc-not-empty (elt list)
(let ((tmp (cdr (assoc elt list))))
(and tmp (string-match "\\S-" tmp) tmp)))
(defvar org-beamer-mode-map (make-sparse-keymap)
"The keymap for `org-beamer-mode'.")
(define-key org-beamer-mode-map "\C-c\C-b" 'org-beamer-select-environment)
;;;###autoload
(define-minor-mode org-beamer-mode
"Special support for editing Org-mode files made to export to beamer."
nil " Bm" nil)
(when (fboundp 'font-lock-add-keywords)
(font-lock-add-keywords
'org-mode
'((":\\(B_[a-z]+\\|BMCOL\\):" 1 'org-beamer-tag prepend))
'prepent))
(defun org-beamer-place-default-actions-for-lists ()
"Find default overlay specifications in items, and move them.
The need to be after the begin statement of the environment."
(when org-beamer-export-is-beamer-p
(let (dovl)
(goto-char (point-min))
(while (re-search-forward
"^[ \t]*\\\\begin{\\(itemize\\|enumerate\\|description\\)}[ \t\n]*\\\\item\\>\\( ?\\(<[^<>\n]*>\\|\\[[^][\n*]\\]\\)\\)?[ \t]*\\S-" nil t)
(if (setq dovl (cdr (assoc "BEAMER_dovl"
(get-text-property (match-end 0)
'org-props))))
(save-excursion
(goto-char (1+ (match-end 1)))
(insert dovl)))))))
(defun org-beamer-amend-header ()
"Add `org-beamer-header-extra' to the LaTeX header.
If the file contains the string BEAMER-HEADER-EXTRA-HERE on a line
by itself, it will be replaced with `org-beamer-header-extra'. If not,
the value will be inserted right after the documentclass statement."
(when (and org-beamer-export-is-beamer-p
org-beamer-header-extra)
(goto-char (point-min))
(cond
((re-search-forward
"^[ \t]*\\[?BEAMER-HEADER-EXTRA\\(-HERE\\)?\\]?[ \t]*$" nil t)
(replace-match org-beamer-header-extra t t)
(or (bolp) (insert "\n")))
((re-search-forward "^[ \t]*\\\\begin{document}" nil t)
(beginning-of-line 1)
(insert org-beamer-header-extra)
(or (bolp) (insert "\n"))))))
(defcustom org-beamer-fragile-re "\\\\\\(verb\\|lstinline\\)\\|^[ \t]*\\\\begin{\\(verbatim\\|lstlisting\\|minted\\)}"
"If this regexp matches in a frame, the frame is marked as fragile."
:group 'org-beamer
:version "24.1"
:type 'regexp)
(defface org-beamer-tag '((t (:box (:line-width 1 :color grey40))))
"The special face for beamer tags."
:group 'org-beamer)
;; Functions to initialize and post-process
;; These functions will be hooked into various places in the export process
(defun org-beamer-initialize-open-trackers ()
"Reset variables that track if certain environments are open during export."
(setq org-beamer-columns-open nil)
(setq org-beamer-column-open nil)
(setq org-beamer-inside-frame-at-level nil)
(setq org-beamer-export-is-beamer-p nil))
(defun org-beamer-after-initial-vars ()
"Find special settings for beamer and store them.
The effect is that these values will be accessible during export."
;; First verify that we are exporting using the beamer class
(setq org-beamer-export-is-beamer-p
(string-match "\\\\documentclass\\(\\[[^][]*?\\]\\)?{beamer}"
org-export-latex-header))
(when org-beamer-export-is-beamer-p
;; Find the frame level
(setq org-beamer-frame-level-now
(or (and (org-region-active-p)
(save-excursion
(goto-char (region-beginning))
(and (looking-at org-complex-heading-regexp)
(org-entry-get nil "BEAMER_FRAME_LEVEL" 'selective))))
(save-excursion
(save-restriction
(widen)
(goto-char (point-min))
(and (re-search-forward
"^#\\+BEAMER_FRAME_LEVEL:[ \t]*\\(.*?\\)[ \t]*$" nil t)
(match-string 1))))
(plist-get org-export-latex-options-plist :beamer-frame-level)
org-beamer-frame-level))
;; Normalize the value so that the functions can trust the value
(cond
((not org-beamer-frame-level-now)
(setq org-beamer-frame-level-now nil))
((stringp org-beamer-frame-level-now)
(setq org-beamer-frame-level-now
(string-to-number org-beamer-frame-level-now))))
;; Find the header additions, most likely theme commands
(setq org-beamer-header-extra
(or (and (org-region-active-p)
(save-excursion
(goto-char (region-beginning))
(and (looking-at org-complex-heading-regexp)
(org-entry-get nil "BEAMER_HEADER_EXTRA"
'selective))))
(save-excursion
(save-restriction
(widen)
(let ((txt ""))
(goto-char (point-min))
(while (re-search-forward
"^#\\+BEAMER_HEADER_EXTRA:[ \t]*\\(.*?\\)[ \t]*$"
nil t)
(setq txt (concat txt "\n" (match-string 1))))
(if (> (length txt) 0) (substring txt 1)))))
(plist-get org-export-latex-options-plist
:beamer-header-extra)))
(let ((inhibit-read-only t)
(case-fold-search nil)
props)
(org-unmodified
(remove-text-properties (point-min) (point-max) '(org-props nil))
(org-map-entries
'(progn
(setq props (org-entry-properties nil 'standard))
(if (and (not (assoc "BEAMER_env" props))
(looking-at ".*?:B_\\(note\\(NH\\)?\\):"))
(push (cons "BEAMER_env" (match-string 1)) props))
(when (org-bound-and-true-p org-beamer-inherited-properties)
(mapc (lambda (p)
(unless (assoc p props)
(let ((v (org-entry-get nil p 'inherit)))
(and v (push (cons p v) props)))))
org-beamer-inherited-properties))
(put-text-property (point-at-bol) (point-at-eol) 'org-props props)))
(setq org-export-latex-options-plist
(plist-put org-export-latex-options-plist :tags nil))))))
(defun org-beamer-auto-fragile-frames ()
"Mark any frames containing verbatim environments as fragile.
This function will run in the final LaTeX document."
(when org-beamer-export-is-beamer-p
(let (opts)
(goto-char (point-min))
;; Find something that might be fragile
(while (re-search-forward org-beamer-fragile-re nil t)
(save-excursion
;; Are we inside a frame here?
(when (and (re-search-backward "^[ \t]*\\\\\\(begin\\|end\\){frame}\\(<[^>]*>\\)?"
nil t)
(equal (match-string 1) "begin"))
;; yes, inside a frame, make sure "fragile" is one of the options
(goto-char (match-end 0))
(if (not (looking-at "\\[.*?\\]"))
(insert "[fragile]")
(setq opts (substring (match-string 0) 1 -1))
(delete-region (match-beginning 0) (match-end 0))
(setq opts (org-split-string opts ","))
(add-to-list 'opts "fragile")
(insert "[" (mapconcat 'identity opts ",") "]"))))))))
(defcustom org-beamer-outline-frame-title "Outline"
"Default title of a frame containing an outline."
:group 'org-beamer
:version "24.1"
:type '(string :tag "Outline frame title")
)
(defcustom org-beamer-outline-frame-options nil
"Outline frame options appended after \\begin{frame}.
You might want to put e.g. [allowframebreaks=0.9] here. Remember to
include square brackets."
:group 'org-beamer
:version "24.1"
:type '(string :tag "Outline frame options")
)
(defun org-beamer-fix-toc ()
"Fix the table of contents by removing the vspace line."
(when org-beamer-export-is-beamer-p
(save-excursion
(goto-char (point-min))
(when (re-search-forward "\\(\\\\setcounter{tocdepth.*\n\\\\tableofcontents.*\n\\)\\(\\\\vspace\\*.*\\)"
nil t)
(replace-match
(concat "\\\\begin{frame}" org-beamer-outline-frame-options
"\n\\\\frametitle{"
org-beamer-outline-frame-title
"}\n\\1\\\\end{frame}")
t nil)))))
(defun org-beamer-property-changed (property value)
"Track the BEAMER_env property with tags."
(cond
((equal property "BEAMER_env")
(save-excursion
(org-back-to-heading t)
(let ((tags (org-get-tags)))
(setq tags (delq nil (mapcar (lambda (x)
(if (string-match "^B_" x) nil x))
tags)))
(org-set-tags-to tags))
(when (and value (stringp value) (string-match "\\S-" value))
(org-toggle-tag (concat "B_" value) 'on))))
((equal property "BEAMER_col")
(org-toggle-tag "BMCOL" (if (and value (string-match "\\S-" value))
'on 'off)))))
(defun org-beamer-select-beamer-code ()
"Take code marked for BEAMER and turn it into marked for LaTeX."
(when org-beamer-export-is-beamer-p
(goto-char (point-min))
(while (re-search-forward
"^\\([ \]*#\\+\\(begin_\\|end_\\)?\\)\\(beamer\\)\\>" nil t)
(replace-match "\\1latex"))))
;; OK, hook all these functions into appropriate places
(add-hook 'org-export-first-hook
'org-beamer-initialize-open-trackers)
(add-hook 'org-property-changed-functions
'org-beamer-property-changed)
(add-hook 'org-export-latex-after-initial-vars-hook
'org-beamer-after-initial-vars)
(add-hook 'org-export-latex-final-hook
'org-beamer-place-default-actions-for-lists)
(add-hook 'org-export-latex-final-hook
'org-beamer-auto-fragile-frames)
(add-hook 'org-export-latex-final-hook
'org-beamer-fix-toc)
(add-hook 'org-export-latex-final-hook
'org-beamer-amend-header)
(add-hook 'org-export-preprocess-before-selecting-backend-code-hook
'org-beamer-select-beamer-code)
(defun org-insert-beamer-options-template (&optional kind)
"Insert a settings template, to make sure users do this right."
(interactive (progn
(message "Current [s]ubtree or [g]lobal?")
(if (equal (read-char-exclusive) ?g)
(list 'global)
(list 'subtree))))
(if (eq kind 'subtree)
(progn
(org-back-to-heading t)
(org-reveal)
(org-entry-put nil "LaTeX_CLASS" "beamer")
(org-entry-put nil "LaTeX_CLASS_OPTIONS" "[presentation]")
(org-entry-put nil "EXPORT_FILE_NAME" "presentation.pdf")
(org-entry-put nil "BEAMER_FRAME_LEVEL" (number-to-string
org-beamer-frame-level))
(when org-beamer-themes
(org-entry-put nil "BEAMER_HEADER_EXTRA" org-beamer-themes))
(when org-beamer-column-view-format
(org-entry-put nil "COLUMNS" org-beamer-column-view-format))
(org-entry-put nil "BEAMER_col_ALL" "0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 1.0 :ETC"))
(insert "#+LaTeX_CLASS: beamer\n")
(insert "#+LaTeX_CLASS_OPTIONS: [presentation]\n")
(insert (format "#+BEAMER_FRAME_LEVEL: %d\n" org-beamer-frame-level) "\n")
(when org-beamer-themes
(insert "#+BEAMER_HEADER_EXTRA: " org-beamer-themes "\n"))
(when org-beamer-column-view-format
(insert "#+COLUMNS: " org-beamer-column-view-format "\n"))
(insert "#+PROPERTY: BEAMER_col_ALL 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 1.0 :ETC\n")))
(defun org-beamer-allowed-property-values (property)
"Supply allowed values for BEAMER properties."
(cond
((and (equal property "BEAMER_env")
(not (org-entry-get nil (concat property "_ALL") 'inherit)))
;; If no allowed values for BEAMER_env have been defined,
;; supply all defined environments
(mapcar 'car (append org-beamer-environments-extra
org-beamer-environments-default)))
((and (equal property "BEAMER_col")
(not (org-entry-get nil (concat property "_ALL") 'inherit)))
;; If no allowed values for BEAMER_col have been defined,
;; supply some
'("0.1" "0.2" "0.3" "0.4" "0.5" "0.6" "0.7" "0.8" "0.9" "" ":ETC"))
(t nil)))
(add-hook 'org-property-allowed-value-functions
'org-beamer-allowed-property-values)
(provide 'org-beamer)
;;; org-beamer.el ends here

402
lisp/org/org-exp-blocks.el
View File

@ -1,402 +0,0 @@
;;; org-exp-blocks.el --- pre-process blocks when exporting org files
;; Copyright (C) 2009-2013 Free Software Foundation, Inc.
;; Author: Eric Schulte
;; This file is part of GNU Emacs.
;;
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; This is a utility for pre-processing blocks in org files before
;; export using the `org-export-preprocess-hook'. It can be used for
;; exporting new types of blocks from org-mode files and also for
;; changing the default export behavior of existing org-mode blocks.
;; The `org-export-blocks' and `org-export-interblocks' variables can
;; be used to control how blocks and the spaces between blocks
;; respectively are processed upon export.
;;
;; The type of a block is defined as the string following =#+begin_=,
;; so for example the following block would be of type ditaa. Note
;; that both upper or lower case are allowed in =#+BEGIN_= and
;; =#+END_=.
;;
;; #+begin_ditaa blue.png -r -S
;; +---------+
;; | cBLU |
;; | |
;; | +----+
;; | |cPNK|
;; | | |
;; +----+----+
;; #+end_ditaa
;;
;;; Currently Implemented Block Types
;;
;; ditaa :: (DEPRECATED--use "#+begin_src ditaa" code blocks) Convert
;; ascii pictures to actual images using ditaa
;; http://ditaa.sourceforge.net/. To use this set
;; `org-ditaa-jar-path' to the path to ditaa.jar on your
;; system (should be set automatically in most cases) .
;;
;; dot :: (DEPRECATED--use "#+begin_src dot" code blocks) Convert
;; graphs defined using the dot graphing language to images
;; using the dot utility. For information on dot see
;; http://www.graphviz.org/
;;
;; export-comment :: Wrap comments with titles and author information,
;; in their own divs with author-specific ids allowing for
;; css coloring of comments based on the author.
;;
;;; Adding new blocks
;;
;; When adding a new block type first define a formatting function
;; along the same lines as `org-export-blocks-format-dot' and then use
;; `org-export-blocks-add-block' to add your block type to
;; `org-export-blocks'.
;;; Code:
(eval-when-compile
(require 'cl))
(require 'find-func)
(require 'org-compat)
(declare-function org-split-string "org" (string &optional separators))
(declare-function org-remove-indentation "org" (code &optional n))
(defvar org-protecting-blocks nil) ; From org.el
(defun org-export-blocks-set (var value)
"Set the value of `org-export-blocks' and install fontification."
(set var value)
(mapc (lambda (spec)
(if (nth 2 spec)
(setq org-protecting-blocks
(delete (symbol-name (car spec))
org-protecting-blocks))
(add-to-list 'org-protecting-blocks
(symbol-name (car spec)))))
value))
(defcustom org-export-blocks
'((export-comment org-export-blocks-format-comment t)
(ditaa org-export-blocks-format-ditaa nil)
(dot org-export-blocks-format-dot nil))
"Use this alist to associate block types with block exporting functions.
The type of a block is determined by the text immediately
following the '#+BEGIN_' portion of the block header. Each block
export function should accept three arguments."
:group 'org-export-general
:type '(repeat
(list
(symbol :tag "Block name")
(function :tag "Block formatter")
(boolean :tag "Fontify content as Org syntax")))
:set 'org-export-blocks-set)
(defun org-export-blocks-add-block (block-spec)
"Add a new block type to `org-export-blocks'.
BLOCK-SPEC should be a three element list the first element of
which should indicate the name of the block, the second element
should be the formatting function called by
`org-export-blocks-preprocess' and the third element a flag
indicating whether these types of blocks should be fontified in
org-mode buffers (see `org-protecting-blocks'). For example the
BLOCK-SPEC for ditaa blocks is as follows.
(ditaa org-export-blocks-format-ditaa nil)"
(unless (member block-spec org-export-blocks)
(setq org-export-blocks (cons block-spec org-export-blocks))
(org-export-blocks-set 'org-export-blocks org-export-blocks)))
(defcustom org-export-interblocks
'()
"Use this a-list to associate block types with block exporting functions.
The type of a block is determined by the text immediately
following the '#+BEGIN_' portion of the block header. Each block
export function should accept three arguments."
:group 'org-export-general
:type 'alist)
(defcustom org-export-blocks-witheld
'(hidden)
"List of block types (see `org-export-blocks') which should not be exported."
:group 'org-export-general
:type 'list)
(defcustom org-export-blocks-postblock-hook nil
"Run after blocks have been processed with `org-export-blocks-preprocess'."
:group 'org-export-general
:version "24.1"
:type 'hook)
(defun org-export-blocks-html-quote (body &optional open close)
"Protect BODY from org html export.
The optional OPEN and CLOSE tags will be inserted around BODY."
(concat
"\n#+BEGIN_HTML\n"
(or open "")
body (if (string-match "\n$" body) "" "\n")
(or close "")
"#+END_HTML\n"))
(defun org-export-blocks-latex-quote (body &optional open close)
"Protect BODY from org latex export.
The optional OPEN and CLOSE tags will be inserted around BODY."
(concat
"\n#+BEGIN_LaTeX\n"
(or open "")
body (if (string-match "\n$" body) "" "\n")
(or close "")
"#+END_LaTeX\n"))
(defvar org-src-preserve-indentation) ; From org-src.el
(defun org-export-blocks-preprocess ()
"Export all blocks according to the `org-export-blocks' block export alist.
Does not export block types specified in specified in BLOCKS
which defaults to the value of `org-export-blocks-witheld'."
(interactive)
(save-window-excursion
(let ((case-fold-search t)
(interblock (lambda (start end)
(mapcar (lambda (pair) (funcall (second pair) start end))
org-export-interblocks)))
matched indentation type types func
start end body headers preserve-indent progress-marker)
(goto-char (point-min))
(setq start (point))
(let ((beg-re "^\\([ \t]*\\)#\\+begin_\\(\\S-+\\)[ \t]*\\(.*\\)?[\r\n]"))
(while (re-search-forward beg-re nil t)
(let* ((match-start (copy-marker (match-beginning 0)))
(body-start (copy-marker (match-end 0)))
(indentation (length (match-string 1)))
(inner-re (format "^[ \t]*#\\+\\(begin\\|end\\)_%s"
(regexp-quote (downcase (match-string 2)))))
(type (intern (downcase (match-string 2))))
(headers (save-match-data
(org-split-string (match-string 3) "[ \t]+")))
(balanced 1)
(preserve-indent (or org-src-preserve-indentation
(member "-i" headers)))
match-end)
(while (and (not (zerop balanced))
(re-search-forward inner-re nil t))
(if (string= (downcase (match-string 1)) "end")
(decf balanced)
(incf balanced)))
(when (not (zerop balanced))
(error "Unbalanced begin/end_%s blocks with %S"
type (buffer-substring match-start (point))))
(setq match-end (copy-marker (match-end 0)))
(unless preserve-indent
(setq body (save-match-data (org-remove-indentation
(buffer-substring
body-start (match-beginning 0))))))
(unless (memq type types) (setq types (cons type types)))
(save-match-data (funcall interblock start match-start))
(when (setq func (cadr (assoc type org-export-blocks)))
(let ((replacement (save-match-data
(if (memq type org-export-blocks-witheld) ""
(apply func body headers)))))
;; ;; un-comment this code after the org-element merge
;; (save-match-data
;; (when (and replacement (string= replacement ""))
;; (delete-region
;; (car (org-element-collect-affiliated-keyword))
;; match-start)))
(when replacement
(delete-region match-start match-end)
(goto-char match-start) (insert replacement)
(if preserve-indent
;; indent only the code block markers
(save-excursion
(indent-line-to indentation) ; indent end_block
(goto-char match-start)
(indent-line-to indentation)) ; indent begin_block
;; indent everything
(indent-code-rigidly match-start (point) indentation)))))
;; cleanup markers
(set-marker match-start nil)
(set-marker body-start nil)
(set-marker match-end nil))
(setq start (point))))
(funcall interblock start (point-max))
(run-hooks 'org-export-blocks-postblock-hook))))
;;================================================================================
;; type specific functions
;;--------------------------------------------------------------------------------
;; ditaa: create images from ASCII art using the ditaa utility
(defcustom org-ditaa-jar-path (expand-file-name
"ditaa.jar"
(file-name-as-directory
(expand-file-name
"scripts"
(file-name-as-directory
(expand-file-name
"../contrib"
(file-name-directory (org-find-library-dir "org")))))))
"Path to the ditaa jar executable."
:group 'org-babel
:type 'string)
(defvar org-export-current-backend) ; dynamically bound in org-exp.el
(defun org-export-blocks-format-ditaa (body &rest headers)
"DEPRECATED: use begin_src ditaa code blocks
Pass block BODY to the ditaa utility creating an image.
Specify the path at which the image should be saved as the first
element of headers, any additional elements of headers will be
passed to the ditaa utility as command line arguments."
(message "begin_ditaa blocks are DEPRECATED, use begin_src blocks")
(let* ((args (if (cdr headers) (mapconcat 'identity (cdr headers) " ")))
(data-file (make-temp-file "org-ditaa"))
(hash (progn
(set-text-properties 0 (length body) nil body)
(sha1 (prin1-to-string (list body args)))))
(raw-out-file (if headers (car headers)))
(out-file-parts (if (string-match "\\(.+\\)\\.\\([^\\.]+\\)$" raw-out-file)
(cons (match-string 1 raw-out-file)
(match-string 2 raw-out-file))
(cons raw-out-file "png")))
(out-file (concat (car out-file-parts) "_" hash "." (cdr out-file-parts))))
(unless (file-exists-p org-ditaa-jar-path)
(error (format "Could not find ditaa.jar at %s" org-ditaa-jar-path)))
(setq body (if (string-match "^\\([^:\\|:[^ ]\\)" body)
body
(mapconcat (lambda (x) (substring x (if (> (length x) 1) 2 1)))
(org-split-string body "\n")
"\n")))
(prog1
(cond
((member org-export-current-backend '(html latex docbook))
(unless (file-exists-p out-file)
(mapc ;; remove old hashed versions of this file
(lambda (file)
(when (and (string-match (concat (regexp-quote (car out-file-parts))
"_\\([[:alnum:]]+\\)\\."
(regexp-quote (cdr out-file-parts)))
file)
(= (length (match-string 1 out-file)) 40))
(delete-file (expand-file-name file
(file-name-directory out-file)))))
(directory-files (or (file-name-directory out-file)
default-directory)))
(with-temp-file data-file (insert body))
(message (concat "java -jar " org-ditaa-jar-path " " args " " data-file " " out-file))
(shell-command (concat "java -jar " org-ditaa-jar-path " " args " " data-file " " out-file)))
(format "\n[[file:%s]]\n" out-file))
(t (concat
"\n#+BEGIN_EXAMPLE\n"
body (if (string-match "\n$" body) "" "\n")
"#+END_EXAMPLE\n")))
(message "begin_ditaa blocks are DEPRECATED, use begin_src blocks"))))
;;--------------------------------------------------------------------------------
;; dot: create graphs using the dot graphing language
;; (require the dot executable to be in your path)
(defun org-export-blocks-format-dot (body &rest headers)
"DEPRECATED: use \"#+begin_src dot\" code blocks
Pass block BODY to the dot graphing utility creating an image.
Specify the path at which the image should be saved as the first
element of headers, any additional elements of headers will be
passed to the dot utility as command line arguments. Don't
forget to specify the output type for the dot command, so if you
are exporting to a file with a name like 'image.png' you should
include a '-Tpng' argument, and your block should look like the
following.
#+begin_dot models.png -Tpng
digraph data_relationships {
\"data_requirement\" [shape=Mrecord, label=\"{DataRequirement|description\lformat\l}\"]
\"data_product\" [shape=Mrecord, label=\"{DataProduct|name\lversion\lpoc\lformat\l}\"]
\"data_requirement\" -> \"data_product\"
}
#+end_dot"
(message "begin_dot blocks are DEPRECATED, use begin_src blocks")
(let* ((args (if (cdr headers) (mapconcat 'identity (cdr headers) " ")))
(data-file (make-temp-file "org-ditaa"))
(hash (progn
(set-text-properties 0 (length body) nil body)
(sha1 (prin1-to-string (list body args)))))
(raw-out-file (if headers (car headers)))
(out-file-parts (if (string-match "\\(.+\\)\\.\\([^\\.]+\\)$" raw-out-file)
(cons (match-string 1 raw-out-file)
(match-string 2 raw-out-file))
(cons raw-out-file "png")))
(out-file (concat (car out-file-parts) "_" hash "." (cdr out-file-parts))))
(prog1
(cond
((member org-export-current-backend '(html latex docbook))
(unless (file-exists-p out-file)
(mapc ;; remove old hashed versions of this file
(lambda (file)
(when (and (string-match (concat (regexp-quote (car out-file-parts))
"_\\([[:alnum:]]+\\)\\."
(regexp-quote (cdr out-file-parts)))
file)
(= (length (match-string 1 out-file)) 40))
(delete-file (expand-file-name file
(file-name-directory out-file)))))
(directory-files (or (file-name-directory out-file)
default-directory)))
(with-temp-file data-file (insert body))
(message (concat "dot " data-file " " args " -o " out-file))
(shell-command (concat "dot " data-file " " args " -o " out-file)))
(format "\n[[file:%s]]\n" out-file))
(t (concat
"\n#+BEGIN_EXAMPLE\n"
body (if (string-match "\n$" body) "" "\n")
"#+END_EXAMPLE\n")))
(message "begin_dot blocks are DEPRECATED, use begin_src blocks"))))
;;--------------------------------------------------------------------------------
;; comment: export comments in author-specific css-stylable divs
(defun org-export-blocks-format-comment (body &rest headers)
"Format comment BODY by OWNER and return it formatted for export.
Currently, this only does something for HTML export, for all
other backends, it converts the comment into an EXAMPLE segment."
(let ((owner (if headers (car headers)))
(title (if (cdr headers) (mapconcat 'identity (cdr headers) " "))))
(cond
((eq org-export-current-backend 'html) ;; We are exporting to HTML
(concat "#+BEGIN_HTML\n"
"<div class=\"org-comment\""
(if owner (format " id=\"org-comment-%s\" " owner))
">\n"
(if owner (concat "<b>" owner "</b> ") "")
(if (and title (> (length title) 0)) (concat " -- " title "<br/>\n") "<br/>\n")
"<p>\n"
"#+END_HTML\n"
body
"\n#+BEGIN_HTML\n"
"</p>\n"
"</div>\n"
"#+END_HTML\n"))
(t ;; This is not HTML, so just make it an example.
(concat "#+BEGIN_EXAMPLE\n"
(if title (concat "Title:" title "\n") "")
(if owner (concat "By:" owner "\n") "")
body
(if (string-match "\n\\'" body) "" "\n")
"#+END_EXAMPLE\n")))))
(provide 'org-exp-blocks)
;;; org-exp-blocks.el ends here

3354
lisp/org/org-exp.el
View File

File diff suppressed because it is too large Load Diff

1227
lisp/org/org-freemind.el
View File

File diff suppressed because it is too large Load Diff

2761
lisp/org/org-html.el
View File

File diff suppressed because it is too large Load Diff

692
lisp/org/org-icalendar.el
View File

@ -1,692 +0,0 @@
;;; org-icalendar.el --- iCalendar export for Org-mode
;; Copyright (C) 2004-2013 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
;;
;; 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:
;;; Code:
(require 'org-exp)
(eval-when-compile (require 'cl))
(declare-function org-bbdb-anniv-export-ical "org-bbdb" nil)
(defgroup org-export-icalendar nil
"Options specific for iCalendar export of Org-mode files."
:tag "Org Export iCalendar"
:group 'org-export)
(defcustom org-combined-agenda-icalendar-file "~/org.ics"
"The file name for the iCalendar file covering all agenda files.
This file is created with the command \\[org-export-icalendar-all-agenda-files].
The file name should be absolute, the file will be overwritten without warning."
:group 'org-export-icalendar
:type 'file)
(defcustom org-icalendar-alarm-time 0
"Number of minutes for triggering an alarm for exported timed events.
A zero value (the default) turns off the definition of an alarm trigger
for timed events. If non-zero, alarms are created.
- a single alarm per entry is defined
- The alarm will go off N minutes before the event
- only a DISPLAY action is defined."
:group 'org-export-icalendar
:version "24.1"
:type 'integer)
(defcustom org-icalendar-combined-name "OrgMode"
"Calendar name for the combined iCalendar representing all agenda files."
:group 'org-export-icalendar
:type 'string)
(defcustom org-icalendar-combined-description nil
"Calendar description for the combined iCalendar (all agenda files)."
:group 'org-export-icalendar
:version "24.1"
:type 'string)
(defcustom org-icalendar-use-plain-timestamp t
"Non-nil means make an event from every plain time stamp."
:group 'org-export-icalendar
:type 'boolean)
(defcustom org-icalendar-honor-noexport-tag nil
"Non-nil means don't export entries with a tag in `org-export-exclude-tags'."
:group 'org-export-icalendar
:version "24.1"
:type 'boolean)
(defcustom org-icalendar-use-deadline '(event-if-not-todo todo-due)
"Contexts where iCalendar 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 'org-export-icalendar
: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-icalendar-use-scheduled '(todo-start)
"Contexts where iCalendar 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 'org-export-icalendar
: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-icalendar-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 'org-export-icalendar
: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-icalendar-include-todo nil
"Non-nil means export to iCalendar files should also cover TODO items.
Valid values are:
nil don't include any TODO items
t include all TODO items that are not in a DONE state
unblocked include all TODO items that are not blocked
all include both done and not done items."
:group 'org-export-icalendar
:type '(choice
(const :tag "None" nil)
(const :tag "Unfinished" t)
(const :tag "Unblocked" unblocked)
(const :tag "All" all)))
(defvar org-icalendar-verify-function nil
"Function to verify entries for iCalendar export.
This can be set to a function that will be called at each entry that
is considered for export to iCalendar. When the function returns nil,
the entry will be skipped. When it returns a non-nil value, the entry
will be considered for export.
This is used internally when an agenda buffer is exported to an ics file,
to make sure that only entries currently listed in the agenda will end
up in the ics file. But for normal iCalendar export, you can use this
for whatever you need.")
(defcustom org-icalendar-include-bbdb-anniversaries nil
"Non-nil means a combined iCalendar files should include anniversaries.
The anniversaries are define in the BBDB database."
:group 'org-export-icalendar
:type 'boolean)
(defcustom org-icalendar-include-sexps t
"Non-nil means export to iCalendar files should also cover sexp entries.
These are entries like in the diary, but directly in an Org-mode file."
:group 'org-export-icalendar
:type 'boolean)
(defcustom org-icalendar-include-body 100
"Amount of text below headline to be included in iCalendar 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 'org-export-icalendar
:type '(choice
(const :tag "Nothing" nil)
(const :tag "Everything" t)
(integer :tag "Max characters")))
(defcustom org-icalendar-store-UID nil
"Non-nil means store any created UIDs in properties.
The iCalendar standard requires that all entries have a unique identifier.
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,
superseding 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 'org-export-icalendar
:type 'boolean)
(defcustom org-icalendar-timezone (getenv "TZ")
"The time zone string for iCalendar export.
When nil or the empty string, use output from \(current-time-zone\)."
:group 'org-export-icalendar
:type '(choice
(const :tag "Unspecified" nil)
(string :tag "Time zone")))
;; Backward compatibility with previous variable
(defvar org-icalendar-use-UTC-date-time nil)
(defcustom org-icalendar-date-time-format
(if org-icalendar-use-UTC-date-time
":%Y%m%dT%H%M%SZ"
":%Y%m%dT%H%M%S")
"Format-string for exporting icalendar DATE-TIME.
See `format-time-string' for a full documentation. The only
difference is that `org-icalendar-timezone' is used for %Z.
Interesting value are:
- \":%Y%m%dT%H%M%S\" for local time
- \";TZID=%Z:%Y%m%dT%H%M%S\" for local time with explicit timezone
- \":%Y%m%dT%H%M%SZ\" for time expressed in Universal Time"
:group 'org-export-icalendar
:version "24.1"
:type '(choice
(const :tag "Local time" ":%Y%m%dT%H%M%S")
(const :tag "Explicit local time" ";TZID=%Z:%Y%m%dT%H%M%S")
(const :tag "Universal time" ":%Y%m%dT%H%M%SZ")
(string :tag "Explicit format")))
(defun org-icalendar-use-UTC-date-timep ()
(char-equal (elt org-icalendar-date-time-format
(1- (length org-icalendar-date-time-format))) ?Z))
;;; iCalendar export
;;;###autoload
(defun org-export-icalendar-this-file ()
"Export current file as an iCalendar file.
The iCalendar file will be located in the same directory as the Org-mode
file, but with extension `.ics'."
(interactive)
(org-export-icalendar nil buffer-file-name))
;;;###autoload
(defun org-export-icalendar-all-agenda-files ()
"Export all files in the variable `org-agenda-files' to iCalendar .ics files.
Each iCalendar file will be located in the same directory as the Org-mode
file, but with extension `.ics'."
(interactive)
(apply 'org-export-icalendar nil (org-agenda-files t)))
;;;###autoload
(defun org-export-icalendar-combine-agenda-files ()
"Export all files in `org-agenda-files' to a single combined iCalendar file.
The file is stored under the name `org-combined-agenda-icalendar-file'."
(interactive)
(apply 'org-export-icalendar t (org-agenda-files t)))
(defun org-export-icalendar (combine &rest files)
"Create iCalendar 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-icalendar-file'."
(save-excursion
(org-agenda-prepare-buffers files)
(let* ((dir (org-export-directory
:ical (list :publishing-directory
org-export-publishing-directory)))
file ical-file ical-buffer category started org-agenda-new-buffers)
(and (get-buffer "*ical-tmp*") (kill-buffer "*ical-tmp*"))
(when combine
(setq ical-file
(if (file-name-absolute-p org-combined-agenda-icalendar-file)
org-combined-agenda-icalendar-file
(expand-file-name org-combined-agenda-icalendar-file dir))
ical-buffer (org-get-agenda-file-buffer ical-file))
(set-buffer ical-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 ical-file (concat (file-name-as-directory dir)
(file-name-sans-extension
(file-name-nondirectory buffer-file-name))
".ics"))
(setq ical-buffer (org-get-agenda-file-buffer ical-file))
(with-current-buffer ical-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 ical-buffer))
(if combine
(and (not started) (setq started t)
(org-icalendar-start-file org-icalendar-combined-name))
(org-icalendar-start-file category))
(org-icalendar-print-entries combine)
(when (or (and combine (not files)) (not combine))
(when (and combine org-icalendar-include-bbdb-anniversaries)
(require 'org-bbdb)
(org-bbdb-anniv-export-ical))
(org-icalendar-finish-file)
(set-buffer ical-buffer)
(run-hooks 'org-before-save-iCalendar-file-hook)
(save-buffer)
(run-hooks 'org-after-save-iCalendar-file-hook)
(and (boundp 'org-wait) (numberp org-wait) (sit-for org-wait))))))
(org-release-buffers org-agenda-new-buffers))))
(defvar org-before-save-iCalendar-file-hook nil
"Hook run before an iCalendar file has been saved.
This can be used to modify the result of the export.")
(defvar org-after-save-iCalendar-file-hook nil
"Hook run after an iCalendar file has been saved.
The iCalendar buffer is still current when this hook is run.
A good way to use this is to tell a desktop calendar application to re-read
the iCalendar file.")
(defvar org-agenda-default-appointment-duration) ; defined in org-agenda.el
(defun org-icalendar-print-entries (&optional combine)
"Print iCalendar 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-icalendar-ts-to-string
(format-time-string (cdr org-time-stamp-formats) (current-time))
"DTSTART"))
hd ts ts2 state status (inc t) pos b sexp rrule
scheduledp deadlinep todo prefix due start tags
tmp pri categories location summary desc uid alarm alarm-time
(sexp-buffer (get-buffer-create "*ical-tmp*")))
(org-refresh-category-properties)
(org-refresh-properties "APPT_WARNTIME" 'org-appt-warntime)
(save-excursion
(goto-char (point-min))
(while (re-search-forward re1 nil t)
(catch :skip
(org-agenda-skip)
(when org-icalendar-verify-function
(unless (save-match-data (funcall org-icalendar-verify-function))
(outline-next-heading)
(backward-char 1)
(throw :skip nil)))
(setq pos (match-beginning 0)
ts (match-string 0)
tags (org-get-tags-at)
inc t
hd (condition-case nil
(org-icalendar-cleanup-string
(org-get-heading t))
(error (throw :skip nil)))
summary (org-icalendar-cleanup-string
(org-entry-get nil "SUMMARY"))
desc (org-icalendar-cleanup-string
(or (org-entry-get nil "DESCRIPTION")
(and org-icalendar-include-body (org-get-entry)))
t org-icalendar-include-body)
location (org-icalendar-cleanup-string
(org-entry-get nil "LOCATION" 'selective))
uid (if org-icalendar-store-UID
(org-id-get-create)
(or (org-id-get) (org-id-new)))
categories (org-export-get-categories)
alarm-time (get-text-property (point) 'org-appt-warntime)
alarm-time (if alarm-time (string-to-number alarm-time) 0)
alarm ""
deadlinep nil scheduledp nil)
(setq tmp (buffer-substring (max (point-min) (- pos org-ds-keyword-length)) pos)
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)
(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 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)))
(when (and (not org-icalendar-use-plain-timestamp)
(not deadlinep) (not scheduledp))
(throw :skip t))
;; don't export entries with a :noexport: tag
(when (and org-icalendar-honor-noexport-tag
(delq nil (mapcar (lambda(x)
(member x org-export-exclude-tags)) tags)))
(throw :skip t))
(when (and
deadlinep
(if todo
(not (memq 'event-if-todo org-icalendar-use-deadline))
(not (memq 'event-if-not-todo org-icalendar-use-deadline))))
(throw :skip t))
(when (and
scheduledp
(if todo
(not (memq 'event-if-todo org-icalendar-use-scheduled))
(not (memq 'event-if-not-todo org-icalendar-use-scheduled))))
(throw :skip t))
(setq prefix (if deadlinep "DL-" (if scheduledp "SC-" "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]+\\)\\([hdwmy]\\)>" ts)
(setq rrule
(concat "\nRRULE:FREQ="
(cdr (assoc
(match-string 2 ts)
'(("h" . "HOURLY")("d" . "DAILY")("w" . "WEEKLY")
("m" . "MONTHLY")("y" . "YEARLY"))))
";INTERVAL=" (match-string 1 ts)))
(setq rrule ""))
(setq summary (or summary hd))
;; create an alarm entry if the entry is timed. this is not very general in that:
;; (a) only one alarm per entry is defined,
;; (b) only minutes are allowed for the trigger period ahead of the start time, and
;; (c) only a DISPLAY action is defined.
;; [ESF]
(let ((t1 (ignore-errors (org-parse-time-string ts 'nodefault))))
(if (and (or (> alarm-time 0) (> org-icalendar-alarm-time 0))
(car t1) (nth 1 t1) (nth 2 t1))
(setq alarm (format "\nBEGIN:VALARM\nACTION:DISPLAY\nDESCRIPTION:%s\nTRIGGER:-P0DT0H%dM0S\nEND:VALARM"
summary (or alarm-time org-icalendar-alarm-time)))
(setq alarm "")))
(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 "DL: " summary)))
(if scheduledp (setq summary (concat "S: " summary)))
(if (string-match "\\`<%%" ts)
(with-current-buffer sexp-buffer
(let ((entry (substring ts 1 -1)))
(put-text-property 0 1 'uid
(concat " " prefix uid) entry)
(insert entry " " summary "\n")))
(princ (format "BEGIN:VEVENT
UID: %s
%s
%s%s
SUMMARY:%s%s%s
CATEGORIES:%s%s
END:VEVENT\n"
(concat prefix uid)
(org-icalendar-ts-to-string ts "DTSTART")
(org-icalendar-ts-to-string ts2 "DTEND" inc)
rrule summary
(if (and desc (string-match "\\S-" desc))
(concat "\nDESCRIPTION: " desc) "")
(if (and location (string-match "\\S-" location))
(concat "\nLOCATION: " location) "")
categories
alarm)))))
(when (and org-icalendar-include-sexps
(condition-case nil (require 'icalendar) (error nil))
(fboundp 'icalendar-export-region))
;; Get all the literal sexps
(goto-char (point-min))
(while (re-search-forward "^&?%%(" nil t)
(catch :skip
(org-agenda-skip)
(when org-icalendar-verify-function
(unless (save-match-data (funcall org-icalendar-verify-function))
(outline-next-heading)
(backward-char 1)
(throw :skip nil)))
(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-ical-string sexp-buffer))
(kill-buffer sexp-buffer))
(when org-icalendar-include-todo
(setq prefix "TODO-")
(goto-char (point-min))
(while (re-search-forward org-complex-heading-regexp nil t)
(catch :skip
(org-agenda-skip)
(when org-icalendar-verify-function
(unless (save-match-data
(funcall org-icalendar-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
(cond
;; check if the state is one we should use
((eq org-icalendar-include-todo 'all)
;; all should be included
t)
((eq org-icalendar-include-todo 'unblocked)
;; only undone entries that are not blocked
(and (member state org-not-done-keywords)
(or (not org-blocker-hook)
(save-match-data
(run-hook-with-args-until-failure
'org-blocker-hook
(list :type 'todo-state-change
:position (point-at-bol)
:from 'todo
:to 'done))))))
((eq org-icalendar-include-todo t)
;; include everything that is not done
(member state org-not-done-keywords))))
(setq hd (match-string 4)
summary (org-icalendar-cleanup-string
(org-entry-get nil "SUMMARY"))
desc (org-icalendar-cleanup-string
(or (org-entry-get nil "DESCRIPTION")
(and org-icalendar-include-body (org-get-entry)))
t org-icalendar-include-body)
location (org-icalendar-cleanup-string
(org-entry-get nil "LOCATION" 'selective))
due (and (member 'todo-due org-icalendar-use-deadline)
(org-entry-get nil "DEADLINE"))
start (and (member 'todo-start org-icalendar-use-scheduled)
(org-entry-get nil "SCHEDULED"))
categories (org-export-get-categories)
uid (if org-icalendar-store-UID
(org-id-get-create)
(or (org-id-get) (org-id-new))))
(and due (setq due (org-icalendar-ts-to-string due "DUE")))
(and start (setq start (org-icalendar-ts-to-string start "DTSTART")))
(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 (- 9 (* 8. (/ (float (- org-lowest-priority pri))
(- org-lowest-priority org-highest-priority))))))
(princ (format "BEGIN:VTODO
UID: %s
%s
SUMMARY:%s%s%s%s
CATEGORIES:%s
SEQUENCE:1
PRIORITY:%d
STATUS:%s
END:VTODO\n"
(concat prefix uid)
(or start dts)
(or summary hd)
(if (and location (string-match "\\S-" location))
(concat "\nLOCATION: " location) "")
(if (and desc (string-match "\\S-" desc))
(concat "\nDESCRIPTION: " desc) "")
(if due (concat "\n" due) "")
categories
pri status)))))))))
(defun org-export-get-categories ()
"Get categories according to `org-icalendar-categories'."
(let ((cs org-icalendar-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-icalendar-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 (not s)
nil
(if 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))))
(setq s (replace-regexp-in-string "[[:space:]]+" " " s)))
(let ((start 0))
(while (string-match "\\([,;]\\)" s start)
(setq start (+ (match-beginning 0) 2)
s (replace-match "\\\\\\1" nil nil s))))
(setq s (org-trim s))
(when is-body
(while (string-match "[ \t]*\n[ \t]*" s)
(setq s (replace-match "\\n" t t s))))
(if is-body
(if maxlength
(if (and (numberp maxlength)
(> (length s) maxlength))
(setq s (substring s 0 maxlength)))))
s))
(defun org-icalendar-cleanup-string-rfc2455 (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.
This seems to be more like RFC 2455, but it causes problems, so it is
not used right now."
(if (not s)
nil
(if 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)))
(setq s (org-trim s))
(while (string-match "[ \t]*\n[ \t]*" s)
(setq s (replace-match "\\n" t t s)))
(if maxlength
(if (and (numberp maxlength)
(> (length s) maxlength))
(setq s (substring s 0 maxlength)))))
(setq s (org-trim s)))
(while (string-match "\"" s) (setq s (replace-match "''" t t s)))
(when (string-match "[;,:]" s) (setq s (concat "\"" s "\"")))
s))
(defun org-icalendar-start-file (name)
"Start an iCalendar file by inserting the header."
(let ((user user-full-name)
(name (or name "unknown"))
(timezone (if (> (length org-icalendar-timezone) 0)
org-icalendar-timezone
(cadr (current-time-zone))))
(description org-icalendar-combined-description))
(princ
(format "BEGIN:VCALENDAR
VERSION:2.0
X-WR-CALNAME:%s
PRODID:-//%s//Emacs with Org-mode//EN
X-WR-TIMEZONE:%s
X-WR-CALDESC:%s
CALSCALE:GREGORIAN\n" name user timezone description))))
(defun org-icalendar-finish-file ()
"Finish an iCalendar file by inserting the END statement."
(princ "END:VCALENDAR\n"))
(defun org-icalendar-ts-to-string (s keyword &optional inc)
"Take a time string S and convert it to iCalendar 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 (ignore-errors (org-parse-time-string s 'nodefault)))
t2 fmt have-time time)
(if (not t1)
""
(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 (if have-time
(replace-regexp-in-string "%Z"
org-icalendar-timezone
org-icalendar-date-time-format t)
";VALUE=DATE:%Y%m%d"))
(concat keyword (format-time-string fmt time
(and (org-icalendar-use-UTC-date-timep)
have-time))))))
(provide 'org-icalendar)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; org-icalendar.el ends here

262
lisp/org/org-jsinfo.el
View File

@ -1,262 +0,0 @@
;;; org-jsinfo.el --- Support for org-info.js Javascript in Org HTML export
;; Copyright (C) 2004-2013 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
;;
;; This file is part of GNU Emacs.
;;
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;; This file implements the support for Sebastian Rose's JavaScript
;; org-info.js to display an org-mode file exported to HTML in an
;; Info-like way, or using folding similar to the outline structure
;; org org-mode itself.
;; Documentation for using this module is in the Org manual. The script
;; itself is documented by Sebastian Rose in a file distributed with
;; the script. FIXME: Accurate pointers!
;; Org-mode loads this module by default - if this is not what you want,
;; configure the variable `org-modules'.
;;; Code:
(require 'org-exp)
(require 'org-html)
(add-to-list 'org-export-inbuffer-options-extra '("INFOJS_OPT" :infojs-opt))
(add-hook 'org-export-options-filters 'org-infojs-handle-options)
(defgroup org-infojs nil
"Options specific for using org-info.js in HTML export of Org-mode files."
:tag "Org Export HTML INFOJS"
:group 'org-export-html)
(defcustom org-export-html-use-infojs 'when-configured
"Should Sebastian Rose's Java Script org-info.js be linked into HTML files?
This option can be nil or t to never or always use the script. It can
also be the symbol `when-configured', meaning that the script will be
linked into the export file if and only if there is a \"#+INFOJS_OPT:\"
line in the buffer. See also the variable `org-infojs-options'."
:group 'org-export-html
:group 'org-infojs
:type '(choice
(const :tag "Never" nil)
(const :tag "When configured in buffer" when-configured)
(const :tag "Always" t)))
(defconst org-infojs-opts-table
'((path PATH "http://orgmode.org/org-info.js")
(view VIEW "info")
(toc TOC :table-of-contents)
(ftoc FIXED_TOC "0")
(tdepth TOC_DEPTH "max")
(sdepth SECTION_DEPTH "max")
(mouse MOUSE_HINT "underline")
(buttons VIEW_BUTTONS "0")
(ltoc LOCAL_TOC "1")
(up LINK_UP :link-up)
(home LINK_HOME :link-home))
"JavaScript options, long form for script, default values.")
(defvar org-infojs-options)
(when (and (boundp 'org-infojs-options)
(assq 'runs org-infojs-options))
(setq org-infojs-options (delq (assq 'runs org-infojs-options)
org-infojs-options)))
(defcustom org-infojs-options
(mapcar (lambda (x) (cons (car x) (nth 2 x)))
org-infojs-opts-table)
"Options settings for the INFOJS JavaScript.
Each of the options must have an entry in `org-export-html/infojs-opts-table'.
The value can either be a string that will be passed to the script, or
a property. This property is then assumed to be a property that is defined
by the Export/Publishing setup of Org.
The `sdepth' and `tdepth' parameters can also be set to \"max\", which
means to use the maximum value consistent with other options."
:group 'org-infojs
:type
`(set :greedy t :inline t
,@(mapcar
(lambda (x)
(list 'cons (list 'const (car x))
'(choice
(symbol :tag "Publishing/Export property")
(string :tag "Value"))))
org-infojs-opts-table)))
(defcustom org-infojs-template
"<script type=\"text/javascript\" src=\"%SCRIPT_PATH\">
/**
*
* @source: %SCRIPT_PATH
*
* @licstart The following is the entire license notice for the
* JavaScript code in %SCRIPT_PATH.
*
* Copyright (C) 2012-2013 Sebastian Rose
*
*
* The JavaScript code in this tag is free software: you can
* redistribute it and/or modify it under the terms of the GNU
* General Public License (GNU GPL) as published by the Free Software
* Foundation, either version 3 of the License, or (at your option)
* any later version. The code is distributed WITHOUT ANY WARRANTY;
* without even the implied warranty of MERCHANTABILITY or FITNESS
* FOR A PARTICULAR PURPOSE. See the GNU GPL for more details.
*
* As additional permission under GNU GPL version 3 section 7, you
* may distribute non-source (e.g., minimized or compacted) forms of
* that code without the copy of the GNU GPL normally required by
* section 4, provided you include this license notice and a URL
* through which recipients can access the Corresponding Source.
*
* @licend The above is the entire license notice
* for the JavaScript code in %SCRIPT_PATH.
*
*/
</script>
<script type=\"text/javascript\">
/*
@licstart The following is the entire license notice for the
JavaScript code in this tag.
Copyright (C) 2012-2013 Free Software Foundation, Inc.
The JavaScript code in this tag is free software: you can
redistribute it and/or modify it under the terms of the GNU
General Public License (GNU GPL) as published by the Free Software
Foundation, either version 3 of the License, or (at your option)
any later version. The code is distributed WITHOUT ANY WARRANTY;
without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU GPL for more details.
As additional permission under GNU GPL version 3 section 7, you
may distribute non-source (e.g., minimized or compacted) forms of
that code without the copy of the GNU GPL normally required by
section 4, provided you include this license notice and a URL
through which recipients can access the Corresponding Source.
@licend The above is the entire license notice
for the JavaScript code in this tag.
*/
<!--/*--><![CDATA[/*><!--*/
%MANAGER_OPTIONS
org_html_manager.setup(); // activate after the parameters are set
/*]]>*///-->
</script>"
"The template for the export style additions when org-info.js is used.
Option settings will replace the %MANAGER-OPTIONS cookie."
:group 'org-infojs
:type 'string)
(defun org-infojs-handle-options (exp-plist)
"Analyze JavaScript options in INFO-PLIST and modify EXP-PLIST accordingly."
(if (or (not org-export-html-use-infojs)
(and (eq org-export-html-use-infojs 'when-configured)
(or (not (plist-get exp-plist :infojs-opt))
(string-match "\\<view:nil\\>"
(plist-get exp-plist :infojs-opt)))))
;; We do not want to use the script
exp-plist
;; We do want to use the script, set it up
(let ((template org-infojs-template)
(ptoc (plist-get exp-plist :table-of-contents))
(hlevels (plist-get exp-plist :headline-levels))
tdepth sdepth s v e opt var val table default)
(setq sdepth hlevels
tdepth hlevels)
(if (integerp ptoc) (setq tdepth (min ptoc tdepth)))
(setq v (plist-get exp-plist :infojs-opt)
table org-infojs-opts-table)
(while (setq e (pop table))
(setq opt (car e) var (nth 1 e)
default (cdr (assoc opt org-infojs-options)))
(and (symbolp default) (not (memq default '(t nil)))
(setq default (plist-get exp-plist default)))
(if (and v (string-match (format " %s:\\(\\S-+\\)" opt) v))
(setq val (match-string 1 v))
(setq val default))
(cond
((eq opt 'path)
(setq template
(replace-regexp-in-string "%SCRIPT_PATH" val template t t)))
((eq opt 'sdepth)
(if (integerp (read val))
(setq sdepth (min (read val) hlevels))))
((eq opt 'tdepth)
(if (integerp (read val))
(setq tdepth (min (read val) hlevels))))
(t
(setq val
(cond
((or (eq val t) (equal val "t")) "1")
((or (eq val nil) (equal val "nil")) "0")
((stringp val) val)
(t (format "%s" val))))
(push (cons var val) s))))
;; Now we set the depth of the *generated* TOC to SDEPTH, because the
;; toc will actually determine the splitting. How much of the toc will
;; actually be displayed is governed by the TDEPTH option.
(setq exp-plist (plist-put exp-plist :table-of-contents sdepth))
;; The table of contents should not show more sections then we generate
(setq tdepth (min tdepth sdepth))
(push (cons "TOC_DEPTH" tdepth) s)
(setq s (mapconcat
(lambda (x) (format "org_html_manager.set(\"%s\", \"%s\");"
(car x) (cdr x)))
s "\n"))
(when (and s (> (length s) 0))
(and (string-match "%MANAGER_OPTIONS" template)
(setq s (replace-match s t t template))
(setq exp-plist
(plist-put
exp-plist :style-extra
(concat (or (plist-get exp-plist :style-extra) "") "\n" s)))))
;; This script absolutely needs the table of contents, to we change that
;; setting
(if (not (plist-get exp-plist :table-of-contents))
(setq exp-plist (plist-put exp-plist :table-of-contents t)))
;; Return the modified property list
exp-plist)))
(defun org-infojs-options-inbuffer-template ()
(format "#+INFOJS_OPT: view:%s toc:%s ltoc:%s mouse:%s buttons:%s path:%s"
(if (eq t org-export-html-use-infojs) (cdr (assoc 'view org-infojs-options)) nil)
(let ((a (cdr (assoc 'toc org-infojs-options))))
(cond ((memq a '(nil t)) a)
(t (plist-get (org-infile-export-plist) :table-of-contents))))
(if (equal (cdr (assoc 'ltoc org-infojs-options)) "1") t nil)
(cdr (assoc 'mouse org-infojs-options))
(cdr (assoc 'buttons org-infojs-options))
(cdr (assoc 'path org-infojs-options))))
(provide 'org-infojs)
(provide 'org-jsinfo)
;;; org-jsinfo.el ends here

2901
lisp/org/org-latex.el
View File

File diff suppressed because it is too large Load Diff

2303
lisp/org/org-lparse.el
View File

File diff suppressed because it is too large Load Diff

216
lisp/org/org-mac-message.el
View File

@ -1,216 +0,0 @@
;;; org-mac-message.el --- Links to Apple Mail.app messages from within Org-mode
;; Copyright (C) 2008-2013 Free Software Foundation, Inc.
;; Authors: John Wiegley <johnw@gnu.org>
;; Christopher Suckling <suckling at gmail dot com>
;; Keywords: outlines, hypermedia, calendar, wp
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This file implements links to Apple Mail.app messages from within Org-mode.
;; Org-mode does not load this module by default - if you would actually like
;; this to happen then configure the variable `org-modules'.
;; If you would like to create links to all flagged messages in an
;; Apple Mail.app account, please customize the variable
;; `org-mac-mail-account' and then call one of the following functions:
;; (org-mac-message-insert-selected) copies a formatted list of links to
;; the kill ring.
;; (org-mac-message-insert-selected) inserts at point links to any
;; messages selected in Mail.app.
;; (org-mac-message-insert-flagged) searches within an org-mode buffer
;; for a specific heading, creating it if it doesn't exist. Any
;; message:// links within the first level of the heading are deleted
;; and replaced with links to flagged messages.
;;; Code:
(require 'org)
(defgroup org-mac-flagged-mail nil
"Options concerning linking to flagged Mail.app messages."
:tag "Org Mail.app"
:group 'org-link)
(defcustom org-mac-mail-account "customize"
"The Mail.app account in which to search for flagged messages."
:group 'org-mac-flagged-mail
:type 'string)
(org-add-link-type "message" 'org-mac-message-open)
;; In mac.c, removed in Emacs 23.
(declare-function do-applescript "org-mac-message" (script))
(unless (fboundp 'do-applescript)
;; Need to fake this using shell-command-to-string
(defun do-applescript (script)
(let (start cmd return)
(while (string-match "\n" script)
(setq script (replace-match "\r" t t script)))
(while (string-match "'" script start)
(setq start (+ 2 (match-beginning 0))
script (replace-match "\\'" t t script)))
(setq cmd (concat "osascript -e '" script "'"))
(setq return (shell-command-to-string cmd))
(concat "\"" (org-trim return) "\""))))
(defun org-mac-message-open (message-id)
"Visit the message with the given MESSAGE-ID.
This will use the command `open' with the message URL."
(start-process (concat "open message:" message-id) nil
"open" (concat "message://<" (substring message-id 2) ">")))
(defun as-get-selected-mail ()
"AppleScript to create links to selected messages in Mail.app."
(do-applescript
(concat
"tell application \"Mail\"\n"
"set theLinkList to {}\n"
"set theSelection to selection\n"
"repeat with theMessage in theSelection\n"
"set theID to message id of theMessage\n"
"set theSubject to subject of theMessage\n"
"set theLink to \"message://\" & theID & \"::split::\" & theSubject & \"\n\"\n"
"copy theLink to end of theLinkList\n"
"end repeat\n"
"return theLinkList as string\n"
"end tell")))
(defun as-get-flagged-mail ()
"AppleScript to create links to flagged messages in Mail.app."
(do-applescript
(concat
;; Is Growl installed?
"tell application \"System Events\"\n"
"set growlHelpers to the name of every process whose creator type contains \"GRRR\"\n"
"if (count of growlHelpers) > 0 then\n"
"set growlHelperApp to item 1 of growlHelpers\n"
"else\n"
"set growlHelperApp to \"\"\n"
"end if\n"
"end tell\n"
;; Get links
"tell application \"Mail\"\n"
"set theMailboxes to every mailbox of account \"" org-mac-mail-account "\"\n"
"set theLinkList to {}\n"
"repeat with aMailbox in theMailboxes\n"
"set theSelection to (every message in aMailbox whose flagged status = true)\n"
"repeat with theMessage in theSelection\n"
"set theID to message id of theMessage\n"
"set theSubject to subject of theMessage\n"
"set theLink to \"message://\" & theID & \"::split::\" & theSubject & \"\n\"\n"
"copy theLink to end of theLinkList\n"
;; Report progress through Growl
;; This "double tell" idiom is described in detail at
;; http://macscripter.net/viewtopic.php?id=24570 The
;; script compiler needs static knowledge of the
;; growlHelperApp. Hmm, since we're compiling
;; on-the-fly here, this is likely to be way less
;; portable than I'd hoped. It'll work when the name
;; is still "GrowlHelperApp", though.
"if growlHelperApp is not \"\" then\n"
"tell application \"GrowlHelperApp\"\n"
"tell application growlHelperApp\n"
"set the allNotificationsList to {\"FlaggedMail\"}\n"
"set the enabledNotificationsList to allNotificationsList\n"
"register as application \"FlaggedMail\" all notifications allNotificationsList default notifications enabledNotificationsList icon of application \"Mail\"\n"
"notify with name \"FlaggedMail\" title \"Importing flagged message\" description theSubject application name \"FlaggedMail\"\n"
"end tell\n"
"end tell\n"
"end if\n"
"end repeat\n"
"end repeat\n"
"return theLinkList as string\n"
"end tell")))
(defun org-mac-message-get-links (&optional select-or-flag)
"Create links to the messages currently selected or flagged in Mail.app.
This will use AppleScript to get the message-id and the subject of the
messages in Mail.app and make a link out of it.
When SELECT-OR-FLAG is \"s\", get the selected messages (this is also
the default). When SELECT-OR-FLAG is \"f\", get the flagged messages.
The Org-syntax text will be pushed to the kill ring, and also returned."
(interactive "sLink to (s)elected or (f)lagged messages: ")
(setq select-or-flag (or select-or-flag "s"))
(message "AppleScript: searching mailboxes...")
(let* ((as-link-list
(if (string= select-or-flag "s")
(as-get-selected-mail)
(if (string= select-or-flag "f")
(as-get-flagged-mail)
(error "Please select \"s\" or \"f\""))))
(link-list
(mapcar
(lambda (x) (if (string-match "\\`\"\\(.*\\)\"\\'" x) (setq x (match-string 1 x))) x)
(split-string as-link-list "[\r\n]+")))
split-link URL description orglink orglink-insert rtn orglink-list)
(while link-list
(setq split-link (split-string (pop link-list) "::split::"))
(setq URL (car split-link))
(setq description (cadr split-link))
(when (not (string= URL ""))
(setq orglink (org-make-link-string URL description))
(push orglink orglink-list)))
(setq rtn (mapconcat 'identity orglink-list "\n"))
(kill-new rtn)
rtn))
(defun org-mac-message-insert-selected ()
"Insert a link to the messages currently selected in Mail.app.
This will use AppleScript to get the message-id and the subject of the
active mail in Mail.app and make a link out of it."
(interactive)
(insert (org-mac-message-get-links "s")))
;; The following line is for backward compatibility
(defalias 'org-mac-message-insert-link 'org-mac-message-insert-selected)
(defun org-mac-message-insert-flagged (org-buffer org-heading)
"Asks for an org buffer and a heading within it, and replace message links.
If heading exists, delete all message:// links within heading's first
level. If heading doesn't exist, create it at point-max. Insert
list of message:// links to flagged mail after heading."
(interactive "bBuffer in which to insert links: \nsHeading after which to insert links: ")
(with-current-buffer org-buffer
(goto-char (point-min))
(let ((isearch-forward t)
(message-re "\\[\\[\\(message:\\)\\([^]]+\\)\\]\\(\\[\\([^]]+\\)\\]\\)?\\]"))
(if (org-goto-local-search-headings org-heading nil t)
(if (not (eobp))
(progn
(save-excursion
(while (re-search-forward
message-re (save-excursion (outline-next-heading)) t)
(delete-region (match-beginning 0) (match-end 0)))
(insert "\n" (org-mac-message-get-links "f")))
(flush-lines "^$" (point) (outline-next-heading)))
(insert "\n" (org-mac-message-get-links "f")))
(goto-char (point-max))
(insert "\n")
(org-insert-heading nil t)
(insert org-heading "\n" (org-mac-message-get-links "f"))))))
(provide 'org-mac-message)
;;; org-mac-message.el ends here

136
lisp/org/org-mew.el
View File

@ -1,136 +0,0 @@
;;; org-mew.el --- Support for links to Mew messages from within Org-mode
;; Copyright (C) 2008-2013 Free Software Foundation, Inc.
;; Author: Tokuya Kameshima <kames at fa2 dot so-net dot ne dot jp>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;; This file implements links to Mew messages from within Org-mode.
;; Org-mode loads this module by default - if this is not what you want,
;; configure the variable `org-modules'.
;;; Code:
(require 'org)
(defgroup org-mew nil
"Options concerning the Mew link."
:tag "Org Startup"
:group 'org-link)
(defcustom org-mew-link-to-refile-destination t
"Create a link to the refile destination if the message is marked as refile."
:group 'org-mew
:type 'boolean)
;; Declare external functions and variables
(declare-function mew-cache-hit "ext:mew-cache" (fld msg &optional must-hit))
(declare-function mew-case-folder "ext:mew-func" (case folder))
(declare-function mew-header-get-value "ext:mew-header"
(field &optional as-list))
(declare-function mew-init "ext:mew" ())
(declare-function mew-refile-get "ext:mew-refile" (msg))
(declare-function mew-sinfo-get-case "ext:mew-summary" ())
(declare-function mew-summary-display "ext:mew-summary2" (&optional redisplay))
(declare-function mew-summary-folder-name "ext:mew-syntax" (&optional ext))
(declare-function mew-summary-get-mark "ext:mew-mark" ())
(declare-function mew-summary-message-number2 "ext:mew-syntax" ())
(declare-function mew-summary-pick-with-mewl "ext:mew-pick"
(pattern folder src-msgs))
(declare-function mew-summary-search-msg "ext:mew-const" (msg))
(declare-function mew-summary-set-message-buffer "ext:mew-summary3" (fld msg))
(declare-function mew-summary-visit-folder "ext:mew-summary4"
(folder &optional goend no-ls))
(declare-function mew-window-push "ext:mew" ())
(defvar mew-init-p)
(defvar mew-summary-goto-line-then-display)
;; Install the link type
(org-add-link-type "mew" 'org-mew-open)
(add-hook 'org-store-link-functions 'org-mew-store-link)
;; Implementation
(defun org-mew-store-link ()
"Store a link to a Mew folder or message."
(when (memq major-mode '(mew-summary-mode mew-virtual-mode))
(let* ((msgnum (mew-summary-message-number2))
(mark-info (mew-summary-get-mark))
(folder-name
(if (and org-mew-link-to-refile-destination
(eq mark-info ?o)) ; marked as refile
(mew-case-folder (mew-sinfo-get-case)
(nth 1 (mew-refile-get msgnum)))
(mew-summary-folder-name)))
message-id from to subject desc link date date-ts date-ts-ia)
(save-window-excursion
(if (fboundp 'mew-summary-set-message-buffer)
(mew-summary-set-message-buffer folder-name msgnum)
(set-buffer (mew-cache-hit folder-name msgnum t)))
(setq message-id (mew-header-get-value "Message-Id:"))
(setq from (mew-header-get-value "From:"))
(setq to (mew-header-get-value "To:"))
(setq date (mew-header-get-value "Date:"))
(setq date-ts (and date (format-time-string
(org-time-stamp-format t)
(date-to-time date))))
(setq date-ts-ia (and date (format-time-string
(org-time-stamp-format t t)
(date-to-time date))))
(setq subject (mew-header-get-value "Subject:")))
(org-store-link-props :type "mew" :from from :to to
:subject subject :message-id message-id)
(when date
(org-add-link-props :date date :date-timestamp date-ts
:date-timestamp-inactive date-ts-ia))
(setq message-id (org-remove-angle-brackets message-id))
(setq desc (org-email-link-description))
(setq link (concat "mew:" folder-name "#" message-id))
(org-add-link-props :link link :description desc)
link)))
(defun org-mew-open (path)
"Follow the Mew message link specified by PATH."
(let (folder msgnum)
(cond ((string-match "\\`\\(+.*\\)+\\+\\([0-9]+\\)\\'" path) ; for Bastien's
(setq folder (match-string 1 path))
(setq msgnum (match-string 2 path)))
((string-match "\\`\\(\\(%#\\)?[^#]+\\)\\(#\\(.*\\)\\)?" path)
(setq folder (match-string 1 path))
(setq msgnum (match-string 4 path)))
(t (error "Error in Mew link")))
(require 'mew)
(mew-window-push)
(unless mew-init-p (mew-init))
(mew-summary-visit-folder folder)
(when msgnum
(if (not (string-match "\\`[0-9]+\\'" msgnum))
(let* ((pattern (concat "message-id=" msgnum))
(msgs (mew-summary-pick-with-mewl pattern folder nil)))
(setq msgnum (car msgs))))
(if (mew-summary-search-msg msgnum)
(if mew-summary-goto-line-then-display
(mew-summary-display))
(error "Message not found")))))
(provide 'org-mew)
;;; org-mew.el ends here

134
lisp/org/org-mks.el
View File

@ -1,134 +0,0 @@
;;; org-mks.el --- Multi-key-selection for Org-mode
;; Copyright (C) 2010-2013 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
;;
;; 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:
;;
;;; Code:
(require 'org)
(eval-when-compile
(require 'cl))
(defun org-mks (table title &optional prompt specials)
"Select a member of an alist with multiple keys.
TABLE is the alist which should contain entries where the car is a string.
There should be two types of entries.
1. prefix descriptions like (\"a\" \"Description\")
This indicates that `a' is a prefix key for multi-letter selection, and
that there are entries following with keys like \"ab\", \"ax\"...
2. Selectable members must have more than two elements, with the first
being the string of keys that lead to selecting it, and the second a
short description string of the item.
The command will then make a temporary buffer listing all entries
that can be selected with a single key, and all the single key
prefixes. When you press the key for a single-letter entry, it is selected.
When you press a prefix key, the commands (and maybe further prefixes)
under this key will be shown and offered for selection.
TITLE will be placed over the selection in the temporary buffer,
PROMPT will be used when prompting for a key. SPECIAL is an alist with
also (\"key\" \"description\") entries. When one of these is selection,
only the bare key is returned."
(setq prompt (or prompt "Select: "))
(let (tbl orig-table dkey ddesc des-keys allowed-keys
current prefix rtn re pressed buffer (inhibit-quit t))
(save-window-excursion
(setq buffer (org-switch-to-buffer-other-window "*Org Select*"))
(setq orig-table table)
(catch 'exit
(while t
(erase-buffer)
(insert title "\n\n")
(setq tbl table
des-keys nil
allowed-keys nil)
(setq prefix (if current (concat current " ") ""))
(while tbl
(cond
((and (= 2 (length (car tbl))) (= (length (caar tbl)) 1))
;; This is a description on this level
(setq dkey (caar tbl) ddesc (cadar tbl))
(pop tbl)
(push dkey des-keys)
(push dkey allowed-keys)
(insert prefix "[" dkey "]" "..." " " ddesc "..." "\n")
;; Skip keys which are below this prefix
(setq re (concat "\\`" (regexp-quote dkey)))
(while (and tbl (string-match re (caar tbl))) (pop tbl)))
((= 2 (length (car tbl)))
;; Not yet a usable description, skip it
)
(t
;; usable entry on this level
(insert prefix "[" (caar tbl) "]" " " (nth 1 (car tbl)) "\n")
(push (caar tbl) allowed-keys)
(pop tbl))))
(when specials
(insert "-------------------------------------------------------------------------------\n")
(let ((sp specials))
(while sp
(insert (format "[%s] %s\n"
(caar sp) (nth 1 (car sp))))
(push (caar sp) allowed-keys)
(pop sp))))
(push "\C-g" allowed-keys)
(goto-char (point-min))
(if (not (pos-visible-in-window-p (point-max)))
(org-fit-window-to-buffer))
(message prompt)
(setq pressed (char-to-string (read-char-exclusive)))
(while (not (member pressed allowed-keys))
(message "Invalid key `%s'" pressed) (sit-for 1)
(message prompt)
(setq pressed (char-to-string (read-char-exclusive))))
(when (equal pressed "\C-g")
(kill-buffer buffer)
(error "Abort"))
(when (and (not (assoc pressed table))
(not (member pressed des-keys))
(assoc pressed specials))
(throw 'exit (setq rtn pressed)))
(unless (member pressed des-keys)
(throw 'exit (setq rtn (rassoc (cdr (assoc pressed table))
orig-table))))
(setq current (concat current pressed))
(setq table (mapcar
(lambda (x)
(if (and (> (length (car x)) 1)
(equal (substring (car x) 0 1) pressed))
(cons (substring (car x) 1) (cdr x))
nil))
table))
(setq table (remove nil table)))))
(when buffer (kill-buffer buffer))
rtn))
(provide 'org-mks)
;;; org-mks.el ends here

2859
lisp/org/org-odt.el
View File

File diff suppressed because it is too large Load Diff

1198
lisp/org/org-publish.el
View File

File diff suppressed because it is too large Load Diff

1156
lisp/org/org-remember.el
View File

File diff suppressed because it is too large Load Diff

104
lisp/org/org-special-blocks.el
View File

@ -1,104 +0,0 @@
;;; org-special-blocks.el --- handle Org special blocks
;; Copyright (C) 2009-2013 Free Software Foundation, Inc.
;; Author: Chris Gray <chrismgray@gmail.com>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; This 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.
(require 'org-html)
(require 'org-compat)
(declare-function org-open-par "org-html" ())
(declare-function org-close-par-maybe "org-html" ())
(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.")
(defvar org-export-current-backend) ; dynamically bound in org-exp.el
(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 (eq org-export-current-backend 'html)
(eq org-export-current-backend 'latex))
(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)
(defvar org-line)
(defun org-special-blocks-convert-html-special-cookies ()
"Converts the special cookies into div blocks."
;; Uses the dynamically-bound variable `org-line'.
(when (and org-line (string-match "^ORG-\\(.*\\)-\\(START\\|END\\)$" org-line))
(message "%s" (match-string 1))
(when (equal (match-string 2 org-line) "START")
(org-close-par-maybe)
(insert "\n<div class=\"" (match-string 1 org-line) "\">")
(org-open-par))
(when (equal (match-string 2 org-line) "END")
(org-close-par-maybe)
(insert "\n</div>")
(org-open-par))
(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

180
lisp/org/org-vm.el
View File

@ -1,180 +0,0 @@
;;; org-vm.el --- Support for links to VM messages from within Org-mode
;; Copyright (C) 2004-2013 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
;;
;; Support for IMAP folders added
;; by Konrad Hinsen <konrad dot hinsen at fastmail dot net>
;; Requires VM 8.2.0a or later.
;;
;; This file is part of GNU Emacs.
;;
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;; This file implements links to VM messages and folders from within Org-mode.
;; Org-mode loads this module by default - if this is not what you want,
;; configure the variable `org-modules'.
;;; Code:
(require 'org)
;; Declare external functions and variables
(declare-function vm-preview-current-message "ext:vm-page" ())
(declare-function vm-follow-summary-cursor "ext:vm-motion" ())
(declare-function vm-get-header-contents "ext:vm-summary"
(message header-name-regexp &optional clump-sep))
(declare-function vm-isearch-narrow "ext:vm-search" ())
(declare-function vm-isearch-update "ext:vm-search" ())
(declare-function vm-select-folder-buffer "ext:vm-macro" ())
(declare-function vm-su-message-id "ext:vm-summary" (m))
(declare-function vm-su-subject "ext:vm-summary" (m))
(declare-function vm-summarize "ext:vm-summary" (&optional display raise))
(declare-function vm-imap-folder-p "ext:vm-save" ())
(declare-function vm-imap-find-spec-for-buffer "ext:vm-imap" (buffer))
(declare-function vm-imap-folder-for-spec "ext:vm-imap" (spec))
(declare-function vm-imap-parse-spec-to-list "ext:vm-imap" (spec))
(declare-function vm-imap-spec-for-account "ext:vm-imap" (account))
(defvar vm-message-pointer)
(defvar vm-folder-directory)
;; Install the link type
(org-add-link-type "vm" 'org-vm-open)
(org-add-link-type "vm-imap" 'org-vm-imap-open)
(add-hook 'org-store-link-functions 'org-vm-store-link)
;; Implementation
(defun org-vm-store-link ()
"Store a link to a VM folder or message."
(when (and (or (eq major-mode 'vm-summary-mode)
(eq major-mode 'vm-presentation-mode))
(save-window-excursion
(vm-select-folder-buffer) buffer-file-name))
(and (eq major-mode 'vm-presentation-mode) (vm-summarize))
(vm-follow-summary-cursor)
(save-excursion
(vm-select-folder-buffer)
(let* ((message (car vm-message-pointer))
(subject (vm-su-subject message))
(to (vm-get-header-contents message "To"))
(from (vm-get-header-contents message "From"))
(message-id (vm-su-message-id message))
(link-type (if (vm-imap-folder-p) "vm-imap" "vm"))
(date (vm-get-header-contents message "Date"))
(date-ts (and date (format-time-string
(org-time-stamp-format t)
(date-to-time date))))
(date-ts-ia (and date (format-time-string
(org-time-stamp-format t t)
(date-to-time date))))
folder desc link)
(if (vm-imap-folder-p)
(let ((spec (vm-imap-find-spec-for-buffer (current-buffer))))
(setq folder (vm-imap-folder-for-spec spec)))
(progn
(setq folder (abbreviate-file-name buffer-file-name))
(if (and vm-folder-directory
(string-match (concat "^" (regexp-quote vm-folder-directory))
folder))
(setq folder (replace-match "" t t folder)))))
(setq message-id (org-remove-angle-brackets message-id))
(org-store-link-props :type link-type :from from :to to :subject subject
:message-id message-id)
(when date
(org-add-link-props :date date :date-timestamp date-ts
:date-timestamp-inactive date-ts-ia))
(setq desc (org-email-link-description))
(setq link (concat (concat link-type ":") folder "#" message-id))
(org-add-link-props :link link :description desc)
link))))
(defun org-vm-open (path)
"Follow a VM message link specified by PATH."
(let (folder article)
(if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path))
(error "Error in VM link"))
(setq folder (match-string 1 path)
article (match-string 3 path))
;; The prefix argument will be interpreted as read-only
(org-vm-follow-link folder article current-prefix-arg)))
(defun org-vm-follow-link (&optional folder article readonly)
"Follow a VM link to FOLDER and ARTICLE."
(require 'vm)
(setq article (org-add-angle-brackets article))
(if (string-match "^//\\([a-zA-Z]+@\\)?\\([^:]+\\):\\(.*\\)" folder)
;; ange-ftp or efs or tramp access
(let ((user (or (match-string 1 folder) (user-login-name)))
(host (match-string 2 folder))
(file (match-string 3 folder)))
(cond
((featurep 'tramp)
;; use tramp to access the file
(if (featurep 'xemacs)
(setq folder (format "[%s@%s]%s" user host file))
(setq folder (format "/%s@%s:%s" user host file))))
(t
;; use ange-ftp or efs
(require (if (featurep 'xemacs) 'efs 'ange-ftp))
(setq folder (format "/%s@%s:%s" user host file))))))
(when folder
(funcall (cdr (assq 'vm org-link-frame-setup)) folder readonly)
(when article
(org-vm-select-message (org-add-angle-brackets article)))))
(defun org-vm-imap-open (path)
"Follow a VM link to an IMAP folder."
(require 'vm-imap)
(when (string-match "\\([^:]+\\):\\([^#]+\\)#?\\(.+\\)?" path)
(let* ((account-name (match-string 1 path))
(mailbox-name (match-string 2 path))
(message-id (match-string 3 path))
(account-spec (vm-imap-parse-spec-to-list
(vm-imap-spec-for-account account-name)))
(mailbox-spec (mapconcat 'identity
(append (butlast account-spec 4)
(cons mailbox-name
(last account-spec 3)))
":")))
(funcall (cdr (assq 'vm-imap org-link-frame-setup))
mailbox-spec)
(when message-id
(org-vm-select-message (org-add-angle-brackets message-id))))))
(defun org-vm-select-message (message-id)
"Go to the message with message-id in the current folder."
(require 'vm-search)
(sit-for 0.1)
(vm-select-folder-buffer)
(widen)
(let ((case-fold-search t))
(goto-char (point-min))
(if (not (re-search-forward
(concat "^" "message-id: *" (regexp-quote message-id))))
(error "Could not find the specified message in this folder"))
(vm-isearch-update)
(vm-isearch-narrow)
(vm-preview-current-message)
(vm-summarize)))
(provide 'org-vm)
;;; org-vm.el ends here

316
lisp/org/org-wl.el
View File

@ -1,316 +0,0 @@
;;; org-wl.el --- Support for links to Wanderlust messages from within Org-mode
;; Copyright (C) 2004-2013 Free Software Foundation, Inc.
;; Author: Tokuya Kameshima <kames at fa2 dot so-net dot ne dot jp>
;; David Maus <dmaus at ictsoc dot de>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
;;
;; This file is part of GNU Emacs.
;;
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;; This file implements links to Wanderlust messages from within Org-mode.
;; Org-mode loads this module by default - if this is not what you want,
;; configure the variable `org-modules'.
;;; Code:
(require 'org)
(defgroup org-wl nil
"Options concerning the Wanderlust link."
:tag "Org Startup"
:group 'org-link)
(defcustom org-wl-link-to-refile-destination t
"Create a link to the refile destination if the message is marked as refile."
:group 'org-wl
:type 'boolean)
(defcustom org-wl-link-remove-filter nil
"Remove filter condition if message is filter folder."
:group 'org-wl
:version "24.1"
:type 'boolean)
(defcustom org-wl-shimbun-prefer-web-links nil
"If non-nil create web links for shimbun messages."
:group 'org-wl
:version "24.1"
:type 'boolean)
(defcustom org-wl-nntp-prefer-web-links nil
"If non-nil create web links for nntp messages.
When folder name contains string \"gmane\" link to gmane,
googlegroups otherwise."
:type 'boolean
:version "24.1"
:group 'org-wl)
(defcustom org-wl-disable-folder-check t
"Disable check for new messages when open a link."
:type 'boolean
:version "24.1"
:group 'org-wl)
(defcustom org-wl-namazu-default-index nil
"Default namazu search index."
:type 'directory
:version "24.1"
:group 'org-wl)
;; Declare external functions and variables
(declare-function elmo-folder-exists-p "ext:elmo" (folder) t)
(declare-function elmo-message-entity-field "ext:elmo-msgdb"
(entity field &optional type))
(declare-function elmo-message-field "ext:elmo"
(folder number field &optional type) t)
(declare-function elmo-msgdb-overview-get-entity "ext:elmo" (id msgdb) t)
;; Backward compatibility to old version of wl
(declare-function wl "ext:wl" () t)
(declare-function wl-summary-buffer-msgdb "ext:wl-folder" () t)
(declare-function wl-summary-jump-to-msg-by-message-id "ext:wl-summary"
(&optional id))
(declare-function wl-summary-jump-to-msg "ext:wl-summary"
(&optional number beg end))
(declare-function wl-summary-line-from "ext:wl-summary" ())
(declare-function wl-summary-line-subject "ext:wl-summary" ())
(declare-function wl-summary-message-number "ext:wl-summary" ())
(declare-function wl-summary-redisplay "ext:wl-summary" (&optional arg))
(declare-function wl-summary-registered-temp-mark "ext:wl-action" (number))
(declare-function wl-folder-goto-folder-subr "ext:wl-folder"
(&optional folder sticky))
(declare-function wl-folder-get-petname "ext:wl-folder" (name))
(declare-function wl-folder-get-entity-from-buffer "ext:wl-folder"
(&optional getid))
(declare-function wl-folder-buffer-group-p "ext:wl-folder")
(defvar wl-init)
(defvar wl-summary-buffer-elmo-folder)
(defvar wl-summary-buffer-folder-name)
(defvar wl-folder-group-regexp)
(defvar wl-auto-check-folder-name)
(defvar elmo-nntp-default-server)
(defconst org-wl-folder-types
'(("%" . imap) ("-" . nntp) ("+" . mh) ("=" . spool)
("$" . archive) ("&" . pop) ("@" . shimbun) ("[" . search)
("*" . multi) ("/" . filter) ("|" . pipe) ("'" . internal))
"List of folder indicators. See Wanderlust manual, section 3.")
;; Install the link type
(org-add-link-type "wl" 'org-wl-open)
(add-hook 'org-store-link-functions 'org-wl-store-link)
;; Implementation
(defun org-wl-folder-type (folder)
"Return symbol that indicates the type of FOLDER.
FOLDER is the wanderlust folder name. The first character of the
folder name determines the folder type."
(let* ((indicator (substring folder 0 1))
(type (cdr (assoc indicator org-wl-folder-types))))
;; maybe access or file folder
(when (not type)
(setq type
(cond
((and (>= (length folder) 5)
(string= (substring folder 0 5) "file:"))
'file)
((and (>= (length folder) 7)
(string= (substring folder 0 7) "access:"))
'access)
(t
nil))))
type))
(defun org-wl-message-field (field entity)
"Return content of FIELD in ENTITY.
FIELD is a symbol of a rfc822 message header field.
ENTITY is a message entity."
(let ((content (elmo-message-entity-field entity field 'string)))
(if (listp content) (car content) content)))
(defun org-wl-store-link ()
"Store a link to a WL message or folder."
(unless (eobp)
(cond
((memq major-mode '(wl-summary-mode mime-view-mode))
(org-wl-store-link-message))
((eq major-mode 'wl-folder-mode)
(org-wl-store-link-folder))
(t
nil))))
(defun org-wl-store-link-folder ()
"Store a link to a WL folder."
(let* ((folder (wl-folder-get-entity-from-buffer))
(petname (wl-folder-get-petname folder))
(link (concat "wl:" folder)))
(save-excursion
(beginning-of-line)
(unless (and (wl-folder-buffer-group-p)
(looking-at wl-folder-group-regexp))
(org-store-link-props :type "wl" :description petname
:link link)
link))))
(defun org-wl-store-link-message ()
"Store a link to a WL message."
(save-excursion
(let ((buf (if (eq major-mode 'wl-summary-mode)
(current-buffer)
(and (boundp 'wl-message-buffer-cur-summary-buffer)
wl-message-buffer-cur-summary-buffer))))
(when buf
(with-current-buffer buf
(let* ((msgnum (wl-summary-message-number))
(mark-info (wl-summary-registered-temp-mark msgnum))
(folder-name
(if (and org-wl-link-to-refile-destination
mark-info
(equal (nth 1 mark-info) "o")) ; marked as refile
(nth 2 mark-info)
wl-summary-buffer-folder-name))
(folder-type (org-wl-folder-type folder-name))
(wl-message-entity
(if (fboundp 'elmo-message-entity)
(elmo-message-entity
wl-summary-buffer-elmo-folder msgnum)
(elmo-msgdb-overview-get-entity
msgnum (wl-summary-buffer-msgdb))))
(message-id
(org-wl-message-field 'message-id wl-message-entity))
(message-id-no-brackets
(org-remove-angle-brackets message-id))
(from (org-wl-message-field 'from wl-message-entity))
(to (org-wl-message-field 'to wl-message-entity))
(xref (org-wl-message-field 'xref wl-message-entity))
(subject (org-wl-message-field 'subject wl-message-entity))
(date (org-wl-message-field 'date wl-message-entity))
(date-ts (and date (format-time-string
(org-time-stamp-format t)
(date-to-time date))))
(date-ts-ia (and date (format-time-string
(org-time-stamp-format t t)
(date-to-time date))))
desc link)
;; remove text properties of subject string to avoid possible bug
;; when formatting the subject
;; (Emacs bug #5306, fixed)
(set-text-properties 0 (length subject) nil subject)
;; maybe remove filter condition
(when (and (eq folder-type 'filter) org-wl-link-remove-filter)
(while (eq (org-wl-folder-type folder-name) 'filter)
(setq folder-name
(replace-regexp-in-string "^/[^/]+/" "" folder-name))))
;; maybe create http link
(cond
((and (eq folder-type 'shimbun)
org-wl-shimbun-prefer-web-links xref)
(org-store-link-props :type "http" :link xref :description subject
:from from :to to :message-id message-id
:message-id-no-brackets message-id-no-brackets
:subject subject))
((and (eq folder-type 'nntp) org-wl-nntp-prefer-web-links)
(setq link
(format
(if (string-match "gmane\\." folder-name)
"http://mid.gmane.org/%s"
"http://groups.google.com/groups/search?as_umsgid=%s")
(org-fixup-message-id-for-http message-id)))
(org-store-link-props :type "http" :link link :description subject
:from from :to to :message-id message-id
:message-id-no-brackets message-id-no-brackets
:subject subject))
(t
(org-store-link-props :type "wl" :from from :to to
:subject subject :message-id message-id
:message-id-no-brackets message-id-no-brackets)
(setq desc (org-email-link-description))
(setq link (concat "wl:" folder-name "#" message-id-no-brackets))
(org-add-link-props :link link :description desc)))
(when date
(org-add-link-props :date date :date-timestamp date-ts
:date-timestamp-inactive date-ts-ia))
(or link xref)))))))
(defun org-wl-open-nntp (path)
"Follow the nntp: link specified by PATH."
(let* ((spec (split-string path "/"))
(server (split-string (nth 2 spec) "@"))
(group (nth 3 spec))
(article (nth 4 spec)))
(org-wl-open
(concat "-" group ":" (if (cdr server)
(car (split-string (car server) ":"))
"")
(if (string= elmo-nntp-default-server (nth 2 spec))
""
(concat "@" (or (cdr server) (car server))))
(if article (concat "#" article) "")))))
(defun org-wl-open (path)
"Follow the WL message link specified by PATH.
When called with one prefix, open message in namazu search folder
with `org-wl-namazu-default-index' as search index. When called
with two prefixes or `org-wl-namazu-default-index' is nil, ask
for namazu index."
(require 'wl)
(let ((wl-auto-check-folder-name
(if org-wl-disable-folder-check
'none
wl-auto-check-folder-name)))
(unless wl-init (wl))
;; XXX: The imap-uw's MH folder names start with "%#".
(if (not (string-match "\\`\\(\\(?:%#\\)?[^#]+\\)\\(#\\(.*\\)\\)?" path))
(error "Error in Wanderlust link"))
(let ((folder (match-string 1 path))
(article (match-string 3 path)))
;; maybe open message in namazu search folder
(when current-prefix-arg
(setq folder (concat "[" article "]"
(if (and (equal current-prefix-arg '(4))
org-wl-namazu-default-index)
org-wl-namazu-default-index
(read-directory-name "Namazu index: ")))))
(if (not (elmo-folder-exists-p (org-no-warnings
(wl-folder-get-elmo-folder folder))))
(error "No such folder: %s" folder))
(let ((old-buf (current-buffer))
(old-point (point-marker)))
(wl-folder-goto-folder-subr folder)
(with-current-buffer old-buf
;; XXX: `wl-folder-goto-folder-subr' moves point to the
;; beginning of the current line. So, restore the point
;; in the old buffer.
(goto-char old-point))
(when article
(if (org-string-match-p "@" article)
(wl-summary-jump-to-msg-by-message-id (org-add-angle-brackets
article))
(or (wl-summary-jump-to-msg (string-to-number article))
(error "No such message: %s" article)))
(wl-summary-redisplay))))))
(provide 'org-wl)
;;; org-wl.el ends here

129
lisp/org/org-xoxo.el
View File

@ -1,129 +0,0 @@
;;; org-xoxo.el --- XOXO export for Org-mode
;; Copyright (C) 2004-2013 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
;;
;; 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:
;; XOXO export
;;; Code:
(require 'org-exp)
(defvar org-export-xoxo-final-hook nil
"Hook run after XOXO export, in the new buffer.")
(defun org-export-as-xoxo-insert-into (buffer &rest output)
(with-current-buffer buffer
(apply 'insert output)))
(put 'org-export-as-xoxo-insert-into 'lisp-indent-function 1)
;;;###autoload
(defun org-export-as-xoxo (&optional buffer)
"Export the org buffer as XOXO.
The XOXO buffer is named *xoxo-<source buffer name>*"
(interactive (list (current-buffer)))
(run-hooks 'org-export-first-hook)
;; A quickie abstraction
;; Output everything as XOXO
(with-current-buffer (get-buffer buffer)
(let* ((pos (point))
(opt-plist (org-combine-plists (org-default-export-plist)
(org-infile-export-plist)))
(filename (concat (file-name-as-directory
(org-export-directory :xoxo opt-plist))
(file-name-sans-extension
(file-name-nondirectory buffer-file-name))
".html"))
(out (find-file-noselect filename))
(last-level 1)
(hanging-li nil))
(goto-char (point-min)) ;; CD: beginning-of-buffer is not allowed.
;; Check the output buffer is empty.
(with-current-buffer out (erase-buffer))
;; Kick off the output
(org-export-as-xoxo-insert-into out "<ol class='xoxo'>\n")
(while (re-search-forward "^\\(\\*+\\)[ \t]+\\(.+\\)" (point-max) 't)
(let* ((hd (match-string-no-properties 1))
(level (length hd))
(text (concat
(match-string-no-properties 2)
(save-excursion
(goto-char (match-end 0))
(let ((str ""))
(catch 'loop
(while 't
(forward-line)
(if (looking-at "^[ \t]\\(.*\\)")
(setq str (concat str (match-string-no-properties 1)))
(throw 'loop str)))))))))
;; Handle level rendering
(cond
((> level last-level)
(org-export-as-xoxo-insert-into out "\n<ol>\n"))
((< level last-level)
(dotimes (- (- last-level level) 1)
(if hanging-li
(org-export-as-xoxo-insert-into out "</li>\n"))
(org-export-as-xoxo-insert-into out "</ol>\n"))
(when hanging-li
(org-export-as-xoxo-insert-into out "</li>\n")
(setq hanging-li nil)))
((equal level last-level)
(if hanging-li
(org-export-as-xoxo-insert-into out "</li>\n")))
)
(setq last-level level)
;; And output the new li
(setq hanging-li 't)
(if (equal ?+ (elt text 0))
(org-export-as-xoxo-insert-into out "<li class='" (substring text 1) "'>")
(org-export-as-xoxo-insert-into out "<li>" text))))
;; Finally finish off the ol
(dotimes (- last-level 1)
(if hanging-li
(org-export-as-xoxo-insert-into out "</li>\n"))
(org-export-as-xoxo-insert-into out "</ol>\n"))
(goto-char pos)
;; Finish the buffer off and clean it up.
(switch-to-buffer-other-window out)
(indent-region (point-min) (point-max) nil)
(run-hooks 'org-export-xoxo-final-hook)
(save-buffer)
(goto-char (point-min))
)))
(provide 'org-xoxo)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; org-xoxo.el ends here