diff options
| author | Carsten Dominik <dominik@nb-dominik2.science.uva.nl> | 2008-01-31 11:33:26 +0100 |
|---|---|---|
| committer | Carsten Dominik <dominik@nb-dominik2.science.uva.nl> | 2008-01-31 11:33:26 +0100 |
| commit | bd2ceb1b545cd75b682b21f5f1dbdbf497cb48ed (patch) | |
| tree | 763f9f41f13c94b81cbf8bee50b867f8c13d1912 | |
| parent | 134bebbeb5d70157a2ba5d93874e48a4ca7340f8 (diff) | |
Release 4.59release_4.59
| -rw-r--r-- | org | 410 | ||||
| -rw-r--r-- | org-install.el | 1 | ||||
| -rw-r--r-- | org.el | 11610 | ||||
| -rw-r--r-- | org.pdf | bin | 638838 -> 638748 bytes | |||
| -rw-r--r-- | org.texi | 26 | ||||
| -rw-r--r-- | orgcard.pdf | bin | 59693 -> 59989 bytes | |||
| -rw-r--r-- | orgcard.tex | 7 |
7 files changed, 6085 insertions, 5969 deletions
@@ -5,7 +5,7 @@ START-INFO-DIR-ENTRY * Org Mode: (org). outline-based notes management and organizer END-INFO-DIR-ENTRY - This manual is for Org-mode (version 4.58). + This manual is for Org-mode (version 4.59). Copyright (C) 2004, 2005, 2006 Free Software Foundation @@ -27,7 +27,7 @@ File: org, Node: Top, Next: Introduction, Prev: (dir), Up: (dir) Org Mode Manual *************** -This manual is for Org-mode (version 4.58). +This manual is for Org-mode (version 4.59). Copyright (C) 2004, 2005, 2006 Free Software Foundation @@ -540,11 +540,10 @@ the visibility in the buffer. trees::) or an agenda command (*note Agenda commands::). `C-c C-x b' - Show the current subtree in an indirect buffer(3), in a separate, - dedicated frame. With positive numerical prefix N, go up to level - N before selecting the subtree. With negative prefix -N, go up N - levels. With `C-u' prefix, don't use the dedicated frame, but - another, new frame. + Show the current subtree in an indirect buffer(3). With numerical + prefix ARG, go up to this level and then take that tree. If ARG + is negative, go up that many levels. With `C-u' prefix, do not + remove the previously used indirect buffer. When Emacs first visits an Org-mode file, the global state is set to OVERVIEW, i.e. only the top level headlines are visible. This can be @@ -564,7 +563,7 @@ basis by adding one of the following lines anywhere in the buffer: (3) The indirect buffer (*note Indirect Buffers: (emacs)Indirect Buffers.) will contain the entire buffer, but will be narrowed to the current tree. Editing the indirect buffer will also change the -original buffer, but without affecting visibility in that buffer . +original buffer, but without affecting visibility in that buffer. File: org, Node: Motion, Next: Structure editing, Prev: Visibility cycling, Up: Document structure @@ -3397,10 +3396,9 @@ View/GoTo org file `b' Display the entire subtree of the current item in an indirect - buffer, in a separate, dedicated frame. With positive numerical - prefix N, go up to level N before selecting the subtree. With - negative prefix -N, go up N levels. With `C-u' prefix, don't use - the dedicated frame, but another, new frame. + buffer. With numerical prefix ARG, go up to this level and then + take that tree. If ARG is negative, go up that many levels. With + `C-u' prefix, do not remove the previously used indirect buffer. `l' Toggle Logbook mode. In Logbook mode, entries that where marked @@ -5366,7 +5364,7 @@ Index * agenda: Weekly/Daily agenda. (line 6) * agenda dispatcher: Agenda dispatcher. (line 6) * agenda files: Agenda files. (line 6) -* agenda files, removing buffers: Agenda commands. (line 231) +* agenda files, removing buffers: Agenda commands. (line 230) * agenda views: Agenda views. (line 6) * agenda views, custom: Custom agenda views. (line 6) * agenda, batch production: Batch processing. (line 6) @@ -5394,7 +5392,7 @@ Index * calculations, in tables <1>: Table calculations. (line 6) * calculations, in tables: Built-in table editor. (line 141) -* calendar commands, from agenda: Agenda commands. (line 192) +* calendar commands, from agenda: Agenda commands. (line 191) * calendar integration: Weekly/Daily agenda. (line 24) * calendar, for selecting date: The date/time prompt. (line 26) @@ -5448,13 +5446,13 @@ Index * DEADLINE keyword: Time stamps. (line 53) * deadlines: Time stamps. (line 6) * demotion, of subtrees: Structure editing. (line 6) -* diary entries, creating from agenda: Agenda commands. (line 199) +* diary entries, creating from agenda: Agenda commands. (line 198) * diary integration: Weekly/Daily agenda. (line 24) * dictionary word completion: Completion. (line 6) * directories, for publishing: Sources and destinations. (line 6) * dispatching agenda commands: Agenda dispatcher. (line 6) -* display changing, in agenda: Agenda commands. (line 66) +* display changing, in agenda: Agenda commands. (line 65) * document structure: Document structure. (line 6) * DONE, final TODO keyword: Per file keywords. (line 20) * editing tables: Tables. (line 6) @@ -5614,8 +5612,8 @@ Index * regular expressions, with tags search: Tag searches. (line 63) * remember.el <1>: Cooperation. (line 33) * remember.el: Remember. (line 6) -* remote editing, from agenda: Agenda commands. (line 107) -* remote editing, undo: Agenda commands. (line 110) +* remote editing, from agenda: Agenda commands. (line 106) +* remote editing, undo: Agenda commands. (line 109) * richer text: Enhancing text. (line 6) * RMAIL links: External links. (line 6) * SCHEDULED keyword: Time stamps. (line 40) @@ -5713,7 +5711,7 @@ Index * tty keybindings: TTY keys. (line 6) * types as TODO keywords: TODO types. (line 6) * underlined text: Enhancing text. (line 15) -* undoing remote-editing events: Agenda commands. (line 110) +* undoing remote-editing events: Agenda commands. (line 109) * URL links: External links. (line 6) * USENET links: External links. (line 6) * variables, for customization: Customization. (line 6) @@ -5737,23 +5735,23 @@ Key Index * Menu: -* $: Agenda commands. (line 124) +* $: Agenda commands. (line 123) * ': CDLaTeX mode. (line 43) -* +: Agenda commands. (line 146) -* ,: Agenda commands. (line 138) -* -: Agenda commands. (line 152) -* .: Agenda commands. (line 101) -* :: Agenda commands. (line 132) +* +: Agenda commands. (line 145) +* ,: Agenda commands. (line 137) +* -: Agenda commands. (line 151) +* .: Agenda commands. (line 100) +* :: Agenda commands. (line 131) * <: The date/time prompt. (line 29) -* <left>: Agenda commands. (line 98) +* <left>: Agenda commands. (line 97) * <RET> <1>: Agenda commands. (line 41) * <RET> <2>: Setting tags. (line 76) * <RET> <3>: The date/time prompt. (line 54) * <RET>: Built-in table editor. (line 64) -* <right>: Agenda commands. (line 93) +* <right>: Agenda commands. (line 92) * <SPC> <1>: Agenda commands. (line 28) * <SPC>: Setting tags. (line 73) * <TAB> <1>: CDLaTeX mode. (line 23) @@ -5763,20 +5761,20 @@ Key Index (line 57) * <TAB> <5>: Plain lists. (line 37) * <TAB>: Visibility cycling. (line 10) -* > <1>: Agenda commands. (line 174) +* > <1>: Agenda commands. (line 173) * >: The date/time prompt. (line 30) * ^: CDLaTeX mode. (line 33) * _: CDLaTeX mode. (line 33) * `: CDLaTeX mode. (line 39) -* a: Agenda commands. (line 135) +* a: Agenda commands. (line 134) * b: Agenda commands. (line 51) -* C: Agenda commands. (line 214) -* c: Agenda commands. (line 192) +* C: Agenda commands. (line 213) +* c: Agenda commands. (line 191) * C-#: Built-in table editor. (line 161) * C-,: Agenda files. (line 18) -* C-_: Agenda commands. (line 110) +* C-_: Agenda commands. (line 109) * C-a a L: Timeline. (line 10) * C-c !: Creating timestamps. (line 21) * C-c #: Checkboxes. (line 56) @@ -5843,7 +5841,7 @@ Key Index * C-c C-c <7>: Built-in table editor. (line 54) * C-c C-c: Plain lists. (line 74) -* C-c C-d <1>: Agenda commands. (line 159) +* C-c C-d <1>: Agenda commands. (line 158) * C-c C-d: Creating timestamps. (line 37) * C-c C-e: Exporting. (line 19) * C-c C-e a: ASCII export. (line 9) @@ -5871,7 +5869,7 @@ Key Index * C-c C-q: Built-in table editor. (line 125) * C-c C-r: Visibility cycling. (line 32) -* C-c C-s <1>: Agenda commands. (line 156) +* C-c C-s <1>: Agenda commands. (line 155) * C-c C-s: Creating timestamps. (line 48) * C-c C-t <1>: Clocking work time. (line 26) * C-c C-t: TODO basics. (line 13) @@ -5881,7 +5879,7 @@ Key Index * C-c C-x b: Visibility cycling. (line 38) * C-c C-x C-a: ARCHIVE tag. (line 28) * C-c C-x C-b: Checkboxes. (line 38) -* C-c C-x C-c: Agenda commands. (line 221) +* C-c C-x C-c: Agenda commands. (line 220) * C-c C-x C-d: Clocking work time. (line 34) * C-c C-x C-i: Clocking work time. (line 12) * C-c C-x C-k: Structure editing. (line 39) @@ -5908,7 +5906,7 @@ Key Index * C-c |: Built-in table editor. (line 40) * C-c ~: table.el. (line 18) -* C-k: Agenda commands. (line 118) +* C-k: Agenda commands. (line 117) * C-TAB: ARCHIVE tag. (line 38) * C-u C-c $: Moving subtrees. (line 12) * C-u C-c .: Creating timestamps. (line 16) @@ -5918,16 +5916,16 @@ Key Index * C-u C-c C-x C-a: ARCHIVE tag. (line 31) * C-u C-c C-x C-u <1>: Dynamic blocks. (line 22) * C-u C-c C-x C-u: Clocking work time. (line 69) -* D: Agenda commands. (line 75) -* d: Agenda commands. (line 72) +* D: Agenda commands. (line 74) +* d: Agenda commands. (line 71) * f: Agenda commands. (line 44) -* g: Agenda commands. (line 79) -* H: Agenda commands. (line 218) -* i: Agenda commands. (line 199) -* I: Agenda commands. (line 179) -* l: Agenda commands. (line 58) +* g: Agenda commands. (line 78) +* H: Agenda commands. (line 217) +* i: Agenda commands. (line 198) +* I: Agenda commands. (line 178) +* l: Agenda commands. (line 57) * L: Agenda commands. (line 32) -* M: Agenda commands. (line 205) +* M: Agenda commands. (line 204) * M-<down>: Built-in table editor. (line 82) * M-<left> <1>: Built-in table editor. @@ -5975,29 +5973,29 @@ Key Index * mouse-3 <1>: Agenda commands. (line 28) * mouse-3: Handling links. (line 77) * n: Agenda commands. (line 19) -* O: Agenda commands. (line 181) -* o: Agenda commands. (line 66) -* P: Agenda commands. (line 143) +* O: Agenda commands. (line 180) +* o: Agenda commands. (line 65) +* P: Agenda commands. (line 142) * p: Agenda commands. (line 20) -* q: Agenda commands. (line 228) -* r <1>: Agenda commands. (line 83) +* q: Agenda commands. (line 227) +* r <1>: Agenda commands. (line 82) * r: Global TODO list. (line 20) -* S: Agenda commands. (line 209) -* s: Agenda commands. (line 90) -* S-<down> <1>: Agenda commands. (line 152) +* S: Agenda commands. (line 208) +* s: Agenda commands. (line 89) +* S-<down> <1>: Agenda commands. (line 151) * S-<down> <2>: The date/time prompt. (line 42) * S-<down> <3>: Creating timestamps. (line 58) * S-<down> <4>: Priorities. (line 25) * S-<down>: Plain lists. (line 55) -* S-<left> <1>: Agenda commands. (line 170) +* S-<left> <1>: Agenda commands. (line 169) * S-<left> <2>: The date/time prompt. (line 39) * S-<left> <3>: Creating timestamps. (line 53) * S-<left>: TODO basics. (line 20) * S-<RET>: Built-in table editor. (line 176) -* S-<right> <1>: Agenda commands. (line 162) +* S-<right> <1>: Agenda commands. (line 161) * S-<right> <2>: The date/time prompt. (line 36) * S-<right> <3>: Creating timestamps. (line 53) @@ -6005,17 +6003,17 @@ Key Index * S-<TAB> <1>: Built-in table editor. (line 61) * S-<TAB>: Visibility cycling. (line 22) -* S-<up> <1>: Agenda commands. (line 146) +* S-<up> <1>: Agenda commands. (line 145) * S-<up> <2>: The date/time prompt. (line 45) * S-<up> <3>: Creating timestamps. (line 58) * S-<up> <4>: Priorities. (line 25) * S-<up>: Plain lists. (line 55) -* T: Agenda commands. (line 127) -* t: Agenda commands. (line 114) -* w: Agenda commands. (line 69) -* x: Agenda commands. (line 231) -* X: Agenda commands. (line 184) +* T: Agenda commands. (line 126) +* t: Agenda commands. (line 113) +* w: Agenda commands. (line 68) +* x: Agenda commands. (line 230) +* X: Agenda commands. (line 183) @@ -6030,151 +6028,151 @@ Node: Document structure18484 Node: Outlines19258 Node: Headlines19918 Node: Visibility cycling20541 -Ref: Visibility cycling-Footnote-122614 -Ref: Visibility cycling-Footnote-222672 -Ref: Visibility cycling-Footnote-322722 -Node: Motion22992 -Node: Structure editing23776 -Node: Archiving26602 -Node: ARCHIVE tag27160 -Node: Moving subtrees28953 -Node: Sparse trees29994 -Ref: Sparse trees-Footnote-132125 -Ref: Sparse trees-Footnote-232217 -Node: Plain lists32332 -Ref: Plain lists-Footnote-135857 -Ref: Plain lists-Footnote-236214 -Node: Tables36398 -Node: Built-in table editor36946 -Node: Narrow columns44974 -Ref: Narrow columns-Footnote-146913 -Node: Table calculations46959 -Node: Formula syntax48279 -Ref: Formula syntax-Footnote-151184 -Node: Lisp formulas51484 -Node: Column formulas52273 -Node: Advanced features54035 -Node: Named-field formulas57289 -Node: Editing/debugging formulas57929 -Node: Appetizer59687 -Node: orgtbl-mode60790 -Node: table.el61281 -Node: Hyperlinks62258 -Node: Link format63031 -Node: Internal links64324 -Ref: Internal links-Footnote-166313 -Node: Radio targets66445 -Node: CamelCase links67160 -Node: External links67754 -Node: Handling links69885 -Ref: Handling links-Footnote-174537 -Ref: Handling links-Footnote-274774 -Node: Link abbreviations74848 -Node: Search options76527 -Ref: Search options-Footnote-178307 -Node: Custom searches78388 -Node: Remember79436 -Node: TODO items83130 -Node: TODO basics84112 -Node: TODO extensions85639 -Node: Workflow states86434 -Node: TODO types87302 -Ref: TODO types-Footnote-188960 -Node: Per file keywords89042 -Ref: Per file keywords-Footnote-190496 -Node: Priorities90697 -Node: Breaking down tasks91941 -Ref: Breaking down tasks-Footnote-192460 -Node: Checkboxes92556 -Node: Timestamps95311 -Node: Time stamps95772 -Ref: Time stamps-Footnote-199266 -Ref: Time stamps-Footnote-299382 -Node: Creating timestamps99537 -Node: The date/time prompt102163 -Ref: The date/time prompt-Footnote-1103929 -Node: Custom time format104035 -Node: Progress logging105594 -Node: Closing items106123 -Node: Clocking work time107027 -Ref: Clocking work time-Footnote-1110651 -Node: Tags110777 -Node: Tag inheritance111539 -Node: Setting tags112476 -Ref: Setting tags-Footnote-1116675 -Ref: Setting tags-Footnote-2116787 -Node: Tag searches116870 -Node: Agenda views119582 -Node: Agenda files121522 -Ref: Agenda files-Footnote-1122482 -Ref: Agenda files-Footnote-2122631 -Node: Agenda dispatcher122824 -Node: Built-in agenda views124515 -Node: Weekly/Daily agenda125093 -Node: Global TODO list127222 -Node: Matching headline tags129395 -Node: Timeline130466 -Node: Stuck projects131132 -Node: Presentation and sorting132831 -Node: Categories133622 -Node: Time-of-day specifications134286 -Node: Sorting of agenda items136257 -Node: Agenda commands137539 -Node: Custom agenda views144239 -Node: Storing searches144914 -Node: Block agenda146826 -Node: Setting Options148056 -Node: Batch processing150768 -Node: Embedded LaTeX151898 -Ref: Embedded LaTeX-Footnote-1152990 -Node: Math symbols153180 -Node: Subscripts and Superscripts153945 -Node: LaTeX fragments154789 -Ref: LaTeX fragments-Footnote-1156897 -Node: Processing LaTeX fragments157159 -Node: CDLaTeX mode158105 -Ref: CDLaTeX mode-Footnote-1160589 -Node: Exporting160737 -Node: ASCII export162051 -Node: HTML export163341 -Node: XOXO export166177 -Node: iCalendar export166616 -Node: Text interpretation168439 -Node: Comment lines168918 -Node: Enhancing text169389 -Node: Export options171081 -Node: Publishing172748 -Ref: Publishing-Footnote-1173544 -Node: Configuration173740 -Node: Project alist174458 -Node: Sources and destinations175524 -Node: Selecting files176254 -Node: Publishing action177002 -Node: Publishing options178235 -Node: Publishing links180387 -Node: Project page index181900 -Node: Sample configuration182678 -Node: Simple example183170 -Node: Complex example183843 -Node: Triggering publication185919 -Node: Miscellaneous186604 -Node: Completion187238 -Node: Customization188709 -Node: In-buffer settings189292 -Node: The very busy C-c C-c key192911 -Node: Clean view194555 -Node: TTY keys197132 -Node: Interaction198741 -Node: Cooperation199138 -Node: Conflicts201005 -Node: Bugs202597 -Node: Extensions and Hacking203991 -Node: Extensions204495 -Node: Dynamic blocks206282 -Node: Special agenda views208238 -Ref: Special agenda views-Footnote-1210519 -Node: History and Acknowledgments210779 -Node: Index215786 -Node: Key Index243028 +Ref: Visibility cycling-Footnote-122567 +Ref: Visibility cycling-Footnote-222625 +Ref: Visibility cycling-Footnote-322675 +Node: Motion22944 +Node: Structure editing23728 +Node: Archiving26554 +Node: ARCHIVE tag27112 +Node: Moving subtrees28905 +Node: Sparse trees29946 +Ref: Sparse trees-Footnote-132077 +Ref: Sparse trees-Footnote-232169 +Node: Plain lists32284 +Ref: Plain lists-Footnote-135809 +Ref: Plain lists-Footnote-236166 +Node: Tables36350 +Node: Built-in table editor36898 +Node: Narrow columns44926 +Ref: Narrow columns-Footnote-146865 +Node: Table calculations46911 +Node: Formula syntax48231 +Ref: Formula syntax-Footnote-151136 +Node: Lisp formulas51436 +Node: Column formulas52225 +Node: Advanced features53987 +Node: Named-field formulas57241 +Node: Editing/debugging formulas57881 +Node: Appetizer59639 +Node: orgtbl-mode60742 +Node: table.el61233 +Node: Hyperlinks62210 +Node: Link format62983 +Node: Internal links64276 +Ref: Internal links-Footnote-166265 +Node: Radio targets66397 +Node: CamelCase links67112 +Node: External links67706 +Node: Handling links69837 +Ref: Handling links-Footnote-174489 +Ref: Handling links-Footnote-274726 +Node: Link abbreviations74800 +Node: Search options76479 +Ref: Search options-Footnote-178259 +Node: Custom searches78340 +Node: Remember79388 +Node: TODO items83082 +Node: TODO basics84064 +Node: TODO extensions85591 +Node: Workflow states86386 +Node: TODO types87254 +Ref: TODO types-Footnote-188912 +Node: Per file keywords88994 +Ref: Per file keywords-Footnote-190448 +Node: Priorities90649 +Node: Breaking down tasks91893 +Ref: Breaking down tasks-Footnote-192412 +Node: Checkboxes92508 +Node: Timestamps95263 +Node: Time stamps95724 +Ref: Time stamps-Footnote-199218 +Ref: Time stamps-Footnote-299334 +Node: Creating timestamps99489 +Node: The date/time prompt102115 +Ref: The date/time prompt-Footnote-1103881 +Node: Custom time format103987 +Node: Progress logging105546 +Node: Closing items106075 +Node: Clocking work time106979 +Ref: Clocking work time-Footnote-1110603 +Node: Tags110729 +Node: Tag inheritance111491 +Node: Setting tags112428 +Ref: Setting tags-Footnote-1116627 +Ref: Setting tags-Footnote-2116739 +Node: Tag searches116822 +Node: Agenda views119534 +Node: Agenda files121474 +Ref: Agenda files-Footnote-1122434 +Ref: Agenda files-Footnote-2122583 +Node: Agenda dispatcher122776 +Node: Built-in agenda views124467 +Node: Weekly/Daily agenda125045 +Node: Global TODO list127174 +Node: Matching headline tags129347 +Node: Timeline130418 +Node: Stuck projects131084 +Node: Presentation and sorting132783 +Node: Categories133574 +Node: Time-of-day specifications134238 +Node: Sorting of agenda items136209 +Node: Agenda commands137491 +Node: Custom agenda views144144 +Node: Storing searches144819 +Node: Block agenda146731 +Node: Setting Options147961 +Node: Batch processing150673 +Node: Embedded LaTeX151803 +Ref: Embedded LaTeX-Footnote-1152895 +Node: Math symbols153085 +Node: Subscripts and Superscripts153850 +Node: LaTeX fragments154694 +Ref: LaTeX fragments-Footnote-1156802 +Node: Processing LaTeX fragments157064 +Node: CDLaTeX mode158010 +Ref: CDLaTeX mode-Footnote-1160494 +Node: Exporting160642 +Node: ASCII export161956 +Node: HTML export163246 +Node: XOXO export166082 +Node: iCalendar export166521 +Node: Text interpretation168344 +Node: Comment lines168823 +Node: Enhancing text169294 +Node: Export options170986 +Node: Publishing172653 +Ref: Publishing-Footnote-1173449 +Node: Configuration173645 +Node: Project alist174363 +Node: Sources and destinations175429 +Node: Selecting files176159 +Node: Publishing action176907 +Node: Publishing options178140 +Node: Publishing links180292 +Node: Project page index181805 +Node: Sample configuration182583 +Node: Simple example183075 +Node: Complex example183748 +Node: Triggering publication185824 +Node: Miscellaneous186509 +Node: Completion187143 +Node: Customization188614 +Node: In-buffer settings189197 +Node: The very busy C-c C-c key192816 +Node: Clean view194460 +Node: TTY keys197037 +Node: Interaction198646 +Node: Cooperation199043 +Node: Conflicts200910 +Node: Bugs202502 +Node: Extensions and Hacking203896 +Node: Extensions204400 +Node: Dynamic blocks206187 +Node: Special agenda views208143 +Ref: Special agenda views-Footnote-1210424 +Node: History and Acknowledgments210684 +Node: Index215691 +Node: Key Index242933 End Tag Table diff --git a/org-install.el b/org-install.el index bb6441e0d..167d16f7f 100644 --- a/org-install.el +++ b/org-install.el @@ -12,6 +12,7 @@ (autoload 'org-cycle-agenda-files "org" "Cycle through agenda-files." t) (autoload 'org-todo-list "org" "Produce global TODO list." t) (autoload 'org-tags-view "org" "Produce global TAGS agenda view." t) +(autoload 'org-agenda-list-stuck-projects "org" "List stuck projects." t) (autoload 'org-remember-annotation "org") (autoload 'org-remember-apply-template "org") (autoload 'org-remember-handler "org") @@ -5,7 +5,7 @@ ;; Author: Carsten Dominik <dominik at science dot uva dot nl> ;; Keywords: outlines, hypermedia, calendar, wp ;; Homepage: http://www.astro.uva.nl/~dominik/Tools/org/ -;; Version: 4.58 +;; Version: 4.59 ;; ;; This file is part of GNU Emacs. ;; @@ -61,6 +61,9 @@ ;; ;; Recent changes ;; -------------- +;; Version 4.59 +;; - Cleanup code, bug fixes. +;; ;; Version 4.58 ;; - Full undo support in the agenda buffer. ;; - Listing stuck GTD projects (projects without any NEXT ACTIONS). @@ -124,6 +127,8 @@ ;; ;;; Code: +;;;; Require other packages + (eval-when-compile (require 'cl) (require 'gnus-sum) @@ -139,6 +144,8 @@ ;;;; Customization variables +;;; Version + (defvar org-version "4.58" "The version number of the file org.el.") (defun org-version () @@ -153,6 +160,8 @@ (get-text-property 0 'test (format "%s" x))) "Does format transport text properties?") +;;; The custom variables + (defgroup org nil "Outline-based notes management and organizer." :tag "Org" @@ -1819,23 +1828,22 @@ This is only effective if `org-agenda-window-setup' is `reorganize-frame'." :group 'org-agenda-windows :type 'boolean) - -(defcustom org-indirect-tree-new-frame 'dedicated +(defcustom org-indirect-buffer-display 'other-window "How should indirect tree buffers be displayed? This applies to indirect buffers created with the commands \\[org-tree-to-indirect-buffer] and \\[org-agenda-tree-to-indirect-buffer]. Valid values are: -nil Just display in another window. -t Use a new frame for each indirect buffer created in this way. -dedicated Create one new frame, and re-use it each time the command is - used. This also means that old indirect buffers will be - deleted when a new one is displayed. This is the default." +current-window Display in the current window +other-window Just display in another window. +dedicated-frame Create one new frame, and re-use it each time. +new-frame Make a new frame each time." :group 'org-structure :group 'org-agenda-windows :type '(choice - (const :tag "In current frame" nil) - (const :tag "Each time a new frame" t) - (const :tag "One dedicated frame" 'dedicated))) + (const :tag "In current window" current-window) + (const :tag "In current frame, other window" other-window) + (const :tag "Each time a new frame" new-frame) + (const :tag "One dedicated frame" dedicated-frame))) (defgroup org-agenda-daily/weekly nil "Options concerning the daily/weekly agenda." @@ -2638,7 +2646,7 @@ Changing this variable requires a restart of Emacs to take effect." "\\([" post (if stacked markers) "]\\|$\\)"))))) (defcustom org-emphasis-regexp-components - '(" \t(" " \t.,?;'\")" " \t\r\n," "." 1 nil) + '(" \t('\"" " \t.,?;'\")" " \t\r\n," "." 1 nil) "Components used to build the reqular expression for emphasis. This is a list with 6 entries. Terminology: In an emphasis string like \" *strong word* \", we call the initial space PREMATCH, the final @@ -2692,6 +2700,8 @@ Use customize to modify this, or restart Emacs after changing it." (string :tag "HTML start tag") (string :tag "HTML end tag")))) +;;; The faces + (defgroup org-faces nil "Faces in Org-mode." :tag "Org Faces" @@ -2946,7 +2956,8 @@ This face is only used if `org-fontify-done-headline' is set." (defconst org-n-levels (length org-level-faces)) -;; Variables for pre-computed regular expressions, all buffer local +;;; Variables for pre-computed regular expressions, all buffer local + (defvar org-done-string nil "The last string in `org-todo-keywords', indicating an item is DONE.") (make-variable-buffer-local 'org-done-string) @@ -3185,72 +3196,183 @@ Also put tags into group 4 if tags are present.") (org-set-font-lock-defaults))) -;;; Tell the compiler about dynamically scoped variables, or foreign vars -(defvar calc-embedded-close-formula) ; defined by the calc package -(defvar calc-embedded-open-formula) ; defined by the calc package -(defvar font-lock-unfontify-region-function) ; defined by font-lock.el + +;;; Some variables ujsed in various places + +(defvar org-window-configuration nil + "Used in various places to store a window configuration.") +(defvar org-finish-function nil + "Function to be called when `C-c C-c' is used. +This is for getting out of special buffers like remember.") + +;;; Foreign variables, to inform the compiler + +;; XEmacs only +(defvar outline-mode-menu-heading) +(defvar outline-mode-menu-show) +(defvar outline-mode-menu-hide) (defvar zmacs-regions) ; XEmacs regions -(defvar original-date) ; dynamically scoped in calendar -(defvar org-old-auto-fill-inhibit-regexp) ; local variable used by `orgtbl-mode' -(defvar orgtbl-mode-menu) ; defined when orgtbl mode get initialized -(defvar org-html-entities) ; defined later in this file -(defvar org-goto-start-pos) ; dynamically scoped parameter -(defvar org-time-was-given) ; dynamically scoped parameter -(defvar org-ts-what) ; dynamically scoped parameter -(defvar org-current-export-file) ; dynamically scoped parameter -(defvar org-current-export-dir) ; dynamically scoped parameter -(defvar mark-active) ; Emacs only, not available in XEmacs. -(defvar timecnt) ; dynamically scoped parameter -(defvar levels-open) ; dynamically scoped parameter -(defvar entry) ; dynamically scoped parameter -(defvar state) ; dynamically scoped into `org-after-todo-state-change-hook' -(defvar date) ; dynamically scoped parameter -(defvar description) ; dynamically scoped parameter -(defvar ans1) ; dynamically scoped parameter -(defvar ans2) ; dynamically scoped parameter -(defvar starting-day) ; local variable -(defvar include-all-loc) ; local variable -(defvar vm-message-pointer) ; from vm -(defvar vm-folder-directory) ; from vm -(defvar gnus-other-frame-object) ; from gnus -(defvar wl-summary-buffer-elmo-folder) ; from wanderlust -(defvar wl-summary-buffer-folder-name) ; from wanderlust -(defvar gnus-group-name) ; from gnus -(defvar gnus-article-current) ; from gnus -(defvar w3m-current-url) ; from w3m -(defvar w3m-current-title) ; from w3m -(defvar mh-progs) ; from MH-E -(defvar mh-current-folder) ; from MH-E -(defvar mh-show-folder-buffer) ; from MH-E -(defvar mh-index-folder) ; from MH-E -(defvar mh-searcher) ; from MH-E -(defvar org-selected-point) ; dynamically scoped parameter -(defvar calendar-mode-map) ; from calendar.el -(defvar last-arg) ; local variable -(defvar remember-save-after-remembering) ; from remember.el -(defvar remember-data-file) ; from remember.el +;; Emacs only +(defvar mark-active) + +;; Packages that org-mode interacts with +(defvar calc-embedded-close-formula) +(defvar calc-embedded-open-formula) +(defvar font-lock-unfontify-region-function) +(defvar org-goto-start-pos) +(defvar vm-message-pointer) +(defvar vm-folder-directory) +(defvar wl-summary-buffer-elmo-folder) +(defvar wl-summary-buffer-folder-name) +(defvar gnus-other-frame-object) +(defvar gnus-group-name) +(defvar gnus-article-current) +(defvar w3m-current-url) +(defvar w3m-current-title) +(defvar mh-progs) +(defvar mh-current-folder) +(defvar mh-show-folder-buffer) +(defvar mh-index-folder) +(defvar mh-searcher) +(defvar calendar-mode-map) +(defvar Info-current-file) +(defvar Info-current-node) +(defvar texmathp-why) +(defvar remember-save-after-remembering) +(defvar remember-data-file) (defvar annotation) ; from remember.el, dynamically scoped in `remember-mode' (defvar initial) ; from remember.el, dynamically scoped in `remember-mode' -(defvar orgtbl-mode) ; defined later in this file -(defvar Info-current-file) ; from info.el -(defvar Info-current-node) ; from info.el -(defvar texmathp-why) ; from texmathp.el (defvar org-latex-regexps) -(defvar outline-mode-menu-heading) -(defvar outline-mode-menu-show) -(defvar outline-mode-menu-hide) -(defvar org-agenda-undo-list) ;; Defined later in this file -(defvar org-agenda-pending-undo-list) ;; Defined later in this file -(defvar org-agenda-overriding-header) ;; Defined later in this file -;;;; Define the mode +(defvar original-date) ; dynamically scoped in calendar.el does scope this + +;; FIXME: Occasionally check by commenting these, to make sure +;; no other functions uses these, forgetting to let-bind them. +(defvar entry) +(defvar state) +(defvar date) +(defvar description) + + +;; Defined somewhere in this file, but used before definition. +(defvar orgtbl-mode-menu) ; defined when orgtbl mode get initialized +(defvar org-agenda-undo-list) +(defvar org-agenda-pending-undo-list) +(defvar org-agenda-overriding-header) +(defvar orgtbl-mode) +(defvar org-html-entities) +(defvar org-struct-menu) +(defvar org-org-menu) +(defvar org-tbl-menu) +(defvar org-agenda-keymap) +(defvar org-category-table) + +;;;; Emacs/XEmacs compatibility + +;; Overlay compatibility functions +(defun org-make-overlay (beg end &optional buffer) + (if (featurep 'xemacs) + (make-extent beg end buffer) + (make-overlay beg end buffer))) +(defun org-delete-overlay (ovl) + (if (featurep 'xemacs) (delete-extent ovl) (delete-overlay ovl))) +(defun org-detach-overlay (ovl) + (if (featurep 'xemacs) (detach-extent ovl) (delete-overlay ovl))) +(defun org-move-overlay (ovl beg end &optional buffer) + (if (featurep 'xemacs) + (set-extent-endpoints ovl beg end (or buffer (current-buffer))) + (move-overlay ovl beg end buffer))) +(defun org-overlay-put (ovl prop value) + (if (featurep 'xemacs) + (set-extent-property ovl prop value) + (overlay-put ovl prop value))) +(defun org-overlay-display (ovl text &optional face) + "Make overlay OVL display TEXT with face FACE." + (if (featurep 'xemacs) + (let ((gl (make-glyph text))) + (and face (set-glyph-face gl face)) + (set-extent-property ovl 'invisible t) + (set-extent-property ovl 'end-glyph gl)) + (overlay-put ovl 'display text) + (if face (overlay-put ovl 'face face)))) +(defun org-overlay-get (ovl prop) + (if (featurep 'xemacs) + (extent-property ovl prop) + (overlay-get ovl prop))) +(defun org-overlays-at (pos) + (if (featurep 'xemacs) (extents-at pos) (overlays-at pos))) +(defun org-overlays-in (&optional start end) + (if (featurep 'xemacs) + (extent-list nil start end) + (overlays-in start end))) +(defun org-overlay-start (o) + (if (featurep 'xemacs) (extent-start-position o) (overlay-start o))) +(defun org-overlay-end (o) + (if (featurep 'xemacs) (extent-end-position o) (overlay-end o))) +(defun org-find-overlays (prop &optional pos delete) + "Find all overlays specifying PROP at POS or point. +If DELETE is non-nil, delete all those overlays." + (let ((overlays (org-overlays-at (or pos (point)))) + ov found) + (while (setq ov (pop overlays)) + (if (org-overlay-get ov prop) + (if delete (org-delete-overlay ov) (push ov found)))) + found)) + +;; Region compatibility + +(defun org-add-hook (hook function &optional append local) + "Add-hook, compatible with both Emacsen." + (if (and local (featurep 'xemacs)) + (add-local-hook hook function append) + (add-hook hook function append local))) + +(defvar org-ignore-region nil + "To temporarily disable the active region.") + +(defun org-region-active-p () + "Is `transient-mark-mode' on and the region active? +Works on both Emacs and XEmacs." + (if org-ignore-region + nil + (if (featurep 'xemacs) + (and zmacs-regions (region-active-p)) + (and transient-mark-mode mark-active)))) + +;; Invisibility compatibility + +(defun org-add-to-invisibility-spec (arg) + "Add elements to `buffer-invisibility-spec'. +See documentation for `buffer-invisibility-spec' for the kind of elements +that can be added." + (cond + ((fboundp 'add-to-invisibility-spec) + (add-to-invisibility-spec arg)) + ((or (null buffer-invisibility-spec) (eq buffer-invisibility-spec t)) + (setq buffer-invisibility-spec (list arg))) + (t + (setq buffer-invisibility-spec + (cons arg buffer-invisibility-spec))))) + +(defun org-remove-from-invisibility-spec (arg) + "Remove elements from `buffer-invisibility-spec'." + (if (fboundp 'remove-from-invisibility-spec) + (remove-from-invisibility-spec arg) + (if (consp buffer-invisibility-spec) + (setq buffer-invisibility-spec + (delete arg buffer-invisibility-spec))))) + +(defun org-in-invisibility-spec-p (arg) + "Is ARG a member of `buffer-invisibility-spec'?" + (if (consp buffer-invisibility-spec) + (member arg buffer-invisibility-spec) + nil)) + +;;;; Define the Org-mode (if (and (not (keymapp outline-mode-map)) (featurep 'allout)) (error "Conflict with outdated version of allout.el. Load org.el before allout.el, or ugrade to newer allout, for example by switching to Emacs 22.")) -(defvar org-struct-menu) ; defined later in this file -(defvar org-org-menu) ; defined later in this file -(defvar org-tbl-menu) ; defined later in this file ;; We use a before-change function to check if a table might need ;; an update. @@ -3379,7 +3501,7 @@ that will be added to PLIST. Returns the string that was modified." (put 'org-add-props 'lisp-indent-function 2) -;;;; Font-Lock stuff +;;;; Font-Lock stuff, including the activators (defvar org-mouse-map (make-sparse-keymap)) (define-key org-mouse-map @@ -3554,10 +3676,6 @@ We use a macro so that the test can happen at compilation time." (defun org-activate-dates (limit) "Run through the buffer and add overlays to dates." -; (if (re-search-forward org-tsr-regexp limit t) -; (if (re-search-forward -; (if org-display-custom-times org-ts-regexp-both org-tsr-regexp-both) -; limit t) (if (re-search-forward org-tsr-regexp-both limit t) (progn (add-text-properties (match-beginning 0) (match-end 0) @@ -3771,7 +3889,9 @@ between words." rear-nonsticky t invisible t intangible t)))) -;;;; Visibility cycling +;;;; Visibility cycling, including org-goto and indirect buffer + +;;; Cycling (defvar org-cycle-global-status nil) (make-variable-buffer-local 'org-cycle-global-status) @@ -4007,6 +4127,8 @@ Optional argument N means, put the headline into the Nth line of the window." (beginning-of-line) (recenter (prefix-numeric-value N)))) +;;; Org-goto + (defvar org-goto-window-configuration nil) (defvar org-goto-marker nil) (defvar org-goto-map (make-sparse-keymap)) @@ -4064,6 +4186,8 @@ to the new location, making it and the headline hierarchy above it visible." (org-show-context 'org-goto))) (error "Quit")))) +(defvar org-selected-point nil) ; dynamically scoped parameter + (defun org-get-location (buf help) "Let the user select a location in the Org-mode buffer BUF. This function uses a recursive edit. It returns the selected position @@ -4146,18 +4270,20 @@ or nil." (defun org-tree-to-indirect-buffer (&optional arg) "Create indirect buffer and narrow it to current subtree. -With numerical prefix arg ARG, go up to this level and then take that tree. +With numerical prefix ARG, go up to this level and then take that tree. If ARG is negative, go up that many levels. -With a C-u prefix, make a separate frame for this tree (i.e. don't use the -dedicated frame)." +Normally this command removes the indirect buffer previously made +with this command. However, when called with a C-u prefix, the last buffer +is kept so that you can work with several indirect buffers at the same time. +If `org-indirect-buffer-display' is `dedicated-frame', the C-u prefix also +requests that a new frame be made for the new buffer, so that the dedicated +frame is not changed." (interactive "P") (let ((cbuf (current-buffer)) + (cwin (selected-window)) (pos (point)) (bname (buffer-name (current-buffer))) - (org-indirect-tree-new-frame - (if (equal arg '(4)) t org-indirect-tree-new-frame)) - beg end level heading) - + beg end level heading ibuf) (save-excursion (org-back-to-heading t) (when (numberp arg) @@ -4168,37 +4294,39 @@ dedicated frame)." (setq beg (point) heading (org-get-heading)) (org-end-of-subtree t) (setq end (point))) + (if (and (not arg) + (buffer-live-p org-last-indirect-buffer)) + (kill-buffer org-last-indirect-buffer)) + (setq ibuf (org-get-indirect-buffer cbuf) + org-last-indirect-buffer ibuf) (cond - ((eq org-indirect-tree-new-frame 'dedicated) + ((or (eq org-indirect-buffer-display 'new-frame) + (and arg (eq org-indirect-buffer-display 'dedicated-frame))) + (select-frame (make-frame)) + (delete-other-windows) + (switch-to-buffer ibuf) + (org-set-frame-title heading)) + ((eq org-indirect-buffer-display 'dedicated-frame) (raise-frame (select-frame (or (and org-indirect-dedicated-frame (frame-live-p org-indirect-dedicated-frame) org-indirect-dedicated-frame) (setq org-indirect-dedicated-frame (make-frame))))) (delete-other-windows) - (if (equal cbuf (buffer-base-buffer)) - ;; Re-use this buffer - (widen) - ;; clean up from last time - (if (buffer-base-buffer (current-buffer)) - (kill-buffer (current-buffer))) - (if (buffer-live-p org-last-indirect-buffer) - (kill-buffer org-last-indirect-buffer)) - ;; make and select the new indirect buffer - (switch-to-buffer - (setq org-last-indirect-buffer (org-get-indirect-buffer cbuf)))) + (switch-to-buffer ibuf) (org-set-frame-title (concat "Indirect: " heading))) - ((eq org-indirect-tree-new-frame t) - (select-frame (make-frame)) - (delete-other-windows) - (switch-to-buffer (org-get-indirect-buffer cbuf)) - (org-set-frame-title heading)) - (t (pop-to-buffer (org-get-indirect-buffer cbuf)))) + ((eq org-indirect-buffer-display 'current-window) + (switch-to-buffer ibuf)) + ((eq org-indirect-buffer-display 'other-window) + (pop-to-buffer ibuf)) + (t (error "Invalid value."))) (if (featurep 'xemacs) (save-excursion (org-mode) (turn-on-font-lock))) (narrow-to-region beg end) (show-all) - (goto-char pos))) + (goto-char pos) + (debug) + (and (window-live-p cwin) (select-window cwin)))) (defun org-get-indirect-buffer (&optional buffer) (setq buffer (or buffer (current-buffer))) @@ -4216,10 +4344,9 @@ dedicated frame)." (unless (featurep 'xemacs) (modify-frame-parameters (selected-frame) (list (cons 'name title))))) -;;;; Promotion, Demotion, Inserting new headlines +;;;; Structure editing -(defvar org-ignore-region nil - "To temporarily disable the active region.") +;;; Inserting headlines (defun org-insert-heading (&optional force-heading) "Insert a new heading or item with same depth at point. @@ -4254,49 +4381,6 @@ the current headline." (unless (= (point) pos) (just-one-space) (backward-delete-char 1)) (run-hooks 'org-insert-heading-hook))))) -(defun org-in-item-p () - "It the cursor inside a plain list item. -Does not have to be the first line." - (save-excursion - (condition-case nil - (progn - (org-beginning-of-item) - (org-at-item-p) - t) - (error nil)))) - -(defun org-insert-item (&optional checkbox) - "Insert a new item at the current level. -Return t when things worked, nil when we are not in an item." - (when (save-excursion - (condition-case nil - (progn - (org-beginning-of-item) - (org-at-item-p) - (if (org-invisible-p) (error "Invisible item")) - t) - (error nil))) - (let* ((bul (match-string 0)) - (eow (save-excursion (beginning-of-line 1) (looking-at "[ \t]*") - (match-end 0))) - (blank (cdr (assq 'plain-list-item org-blank-before-new-entry))) - pos) - (cond - ((and (org-at-item-p) (<= (point) eow)) - ;; before the bullet - (beginning-of-line 1) - (open-line (if blank 2 1))) - ((<= (point) eow) - (beginning-of-line 1)) - (t (newline (if blank 2 1)))) - (insert bul (if checkbox "[ ]" "")) - (just-one-space) - (setq pos (point)) - (end-of-line 1) - (unless (= (point) pos) (just-one-space) (backward-delete-char 1))) - (org-maybe-renumber-ordered-list) - (and checkbox (org-update-checkbox-count-maybe)) - t)) (defun org-insert-todo-heading (arg) "Insert a new heading with the same level and TODO state as current heading. @@ -4315,6 +4399,8 @@ state (TODO by default). Also with prefix arg, force first state." (insert (car org-todo-keywords) " ") (insert (match-string 2) " ")))) +;;; Promotion and Demotion + (defun org-promote-subtree () "Promote the entire subtree. See also `org-promote'." @@ -4403,120 +4489,6 @@ in the region." (and org-auto-align-tags (org-set-tags nil t)) (if org-adapt-indentation (org-fixup-indentation diff)))) -(defun org-sort (with-case) - "Call `org-sort-entries' or `org-table-sort-lines', depending on context." - (interactive "P") - (if (org-at-table-p) - (org-call-with-arg 'org-table-sort-lines with-case) - (org-call-with-arg 'org-sort-entries with-case))) - -(defun org-sort-entries (&optional with-case sorting-type) - "Sort entries on a certain level of an outline tree. -If there is an active region, the entries in the region are sorted. -If not, the children of the entry at point are sorted. - -Sorting can be alphabetically, numerically, and by date/time as given by -the first time stamp in the entry. The command prompts for the sorting -type unless it has been given to the function through the SORTING-TYPE -argument, which needs to a character, any of (?n ?N ?a ?A ?t ?T). - -Comparing entries ignores case by default. However, with an optional argument -WITH-CASE, the sorting considers case as well. With two prefix arguments -`C-u C-u', sorting is case-sensitive and duplicate entries will be removed." - (interactive "P") - (let ((unique (equal with-case '(16))) - start beg end entries stars re re2 p nentries (nremoved 0) last txt) - - ;; Find beginning and end of region to sort - (if (org-region-active-p) - (progn - ;; we will sort the region - (setq end (region-end)) - (goto-char (1- (setq start (region-beginning))))) - ;; we will sort the children of the current headline - (setq start (point) end (org-end-of-subtree)) - (goto-char start) - (show-subtree)) - (outline-next-heading) ; this is the first heading to be included - (setq beg (point)) - (if (>= (point) end) (error "Nothing to sort")) - (looking-at "\\(\\*+\\)") - (setq stars (match-string 1) - re (concat "^" (regexp-quote stars) " +") - re2 (concat "^" (regexp-quote (substring stars 0 -1)) "[^*]") - txt (buffer-substring beg end)) - (if (not (equal (substring txt -1) "\n")) (setq txt (concat txt "\n"))) - (if (string-match re2 txt) - (error "Region to sort contains a level above the first entry")) - ;; Make a list that can be sorted. - ;; The car is the string for comparison, the cdr is the subtree - (message "Sorting entries...") - (setq entries - (mapcar - (lambda (x) - (string-match "^.*\\(\n.*\\)?" x) ; take two lines - (cons (match-string 0 x) x)) - (org-split-string txt re))) - - ;; Sort the list - (setq entries (org-do-sort - entries - (if (org-region-active-p) "region" "children") - with-case sorting-type)) - - ;; Delete the old stuff - (goto-char beg) - (kill-region beg end) - (setq nentries (length entries)) - ;; Insert the sorted entries, and remove duplicates if this is required - (while (setq p (pop entries)) - (if (and unique (equal last (setq last (org-trim (cdr p))))) - (setq nremoved (1+ nremoved)) ; same entry as before, skip it - (insert stars " " (cdr p)))) - (goto-char start) - (message "Sorting entries...done (%d entries%s)" - nentries - (if unique (format ", %d duplicates removed" nremoved) "")))) - -(defun org-do-sort (table what &optional with-case sorting-type) - "Sort TABLE of WHAT according to SORTING-TYPE. -The user will be prompted for the SORTING-TYPE if the call to this -function does not specify it. WHAT is only for the prompt, to indicate -what is being sorted. The sorting key will be extracted from -the car of the elements of the table. -If WITH-CASE is non-nil, the sorting will be case-sensitive." - (unless sorting-type - (message - "Sort %s:[a]lphabetically [n]umerically [t]ime. A/N/T means reversed:" - what) - (setq sorting-type (read-char-exclusive))) - (let ((dcst (downcase sorting-type)) - extractfun comparefun) - ;; Define the appropriate functions - (cond - ((= dcst ?n) - (setq extractfun 'string-to-number - comparefun (if (= dcst sorting-type) '< '>))) - ((= dcst ?a) - (setq extractfun (if with-case 'identity 'downcase) - comparefun (if (= dcst sorting-type) - 'string< - (lambda (a b) (and (not (string< a b)) - (not (string= a b))))))) - ((= dcst ?t) - (setq extractfun - (lambda (x) - (if (string-match org-ts-regexp x) - (time-to-seconds - (org-time-string-to-time (match-string 0 x))) - 0)) - comparefun (if (= dcst sorting-type) '< '>))) - (t (error "Invalid sorting type `%c'" sorting-type))) - - (sort (mapcar (lambda (x) (cons (funcall extractfun (car x)) (cdr x))) - table) - (lambda (a b) (funcall comparefun (car a) (car b)))))) - (defun org-map-tree (fun) "Call FUN for every heading underneath the current one." (org-back-to-heading) @@ -4563,6 +4535,47 @@ would end up with no indentation after the change, nothing at all is done." (indent-to (+ diff col)))) (move-marker end nil)))) +(defun org-convert-to-odd-levels () + "Convert an org-mode file with all levels allowed to one with odd levels. +This will leave level 1 alone, convert level 2 to level 3, level 3 to +level 5 etc." + (interactive) + (when (yes-or-no-p "Are you sure you want to globally change levels to odd? ") + (let ((org-odd-levels-only nil) n) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^\\*\\*+" nil t) + (setq n (1- (length (match-string 0)))) + (while (>= (setq n (1- n)) 0) + (org-demote)) + (end-of-line 1)))))) + + +(defun org-convert-to-oddeven-levels () + "Convert an org-mode file with only odd levels to one with odd and even levels. +This promotes level 3 to level 2, level 5 to level 3 etc. If the file contains a +section with an even level, conversion would destroy the structure of the file. An error +is signaled in this case." + (interactive) + (goto-char (point-min)) + ;; First check if there are no even levels + (when (re-search-forward "^\\(\\*\\*\\)+[^*]" nil t) + (org-show-context t) + (error "Not all levels are odd in this file. Conversion not possible.")) + (when (yes-or-no-p "Are you sure you want to globally change levels to odd-even? ") + (let ((org-odd-levels-only nil) n) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^\\*\\*+" nil t) + (setq n (/ (length (match-string 0)) 2)) + (while (>= (setq n (1- n)) 0) + (org-promote)) + (end-of-line 1)))))) + +(defun org-tr-level (n) + "Make N odd if required." + (if org-odd-levels-only (1+ (/ n 2)) n)) + ;;; Vertical tree motion, cutting and pasting of subtrees (defun org-move-subtree-up (&optional arg) @@ -4772,7 +4785,126 @@ If optional TXT is given, check this string instead of the current kill." (progn (org-back-to-heading) (point)) (progn (org-end-of-subtree t) (point))))) -;;;; Plain list items + +;;; Outline Sorting + +(defun org-sort (with-case) + "Call `org-sort-entries' or `org-table-sort-lines', depending on context." + (interactive "P") + (if (org-at-table-p) + (org-call-with-arg 'org-table-sort-lines with-case) + (org-call-with-arg 'org-sort-entries with-case))) + +(defun org-sort-entries (&optional with-case sorting-type) + "Sort entries on a certain level of an outline tree. +If there is an active region, the entries in the region are sorted. +If not, the children of the entry at point are sorted. + +Sorting can be alphabetically, numerically, and by date/time as given by +the first time stamp in the entry. The command prompts for the sorting +type unless it has been given to the function through the SORTING-TYPE +argument, which needs to a character, any of (?n ?N ?a ?A ?t ?T). + +Comparing entries ignores case by default. However, with an optional argument +WITH-CASE, the sorting considers case as well. With two prefix arguments +`C-u C-u', sorting is case-sensitive and duplicate entries will be removed." + (interactive "P") + (let ((unique (equal with-case '(16))) + start beg end entries stars re re2 p nentries (nremoved 0) last txt) + + ;; Find beginning and end of region to sort + (if (org-region-active-p) + (progn + ;; we will sort the region + (setq end (region-end)) + (goto-char (1- (setq start (region-beginning))))) + ;; we will sort the children of the current headline + (setq start (point) end (org-end-of-subtree)) + (goto-char start) + (show-subtree)) + (outline-next-heading) ; this is the first heading to be included + (setq beg (point)) + (if (>= (point) end) (error "Nothing to sort")) + (looking-at "\\(\\*+\\)") + (setq stars (match-string 1) + re (concat "^" (regexp-quote stars) " +") + re2 (concat "^" (regexp-quote (substring stars 0 -1)) "[^*]") + txt (buffer-substring beg end)) + (if (not (equal (substring txt -1) "\n")) (setq txt (concat txt "\n"))) + (if (string-match re2 txt) + (error "Region to sort contains a level above the first entry")) + ;; Make a list that can be sorted. + ;; The car is the string for comparison, the cdr is the subtree + (message "Sorting entries...") + (setq entries + (mapcar + (lambda (x) + (string-match "^.*\\(\n.*\\)?" x) ; take two lines + (cons (match-string 0 x) x)) + (org-split-string txt re))) + + ;; Sort the list + (setq entries (org-do-sort + entries + (if (org-region-active-p) "region" "children") + with-case sorting-type)) + + ;; Delete the old stuff + (goto-char beg) + (kill-region beg end) + (setq nentries (length entries)) + ;; Insert the sorted entries, and remove duplicates if this is required + (while (setq p (pop entries)) + (if (and unique (equal last (setq last (org-trim (cdr p))))) + (setq nremoved (1+ nremoved)) ; same entry as before, skip it + (insert stars " " (cdr p)))) + (goto-char start) + (message "Sorting entries...done (%d entries%s)" + nentries + (if unique (format ", %d duplicates removed" nremoved) "")))) + +(defun org-do-sort (table what &optional with-case sorting-type) + "Sort TABLE of WHAT according to SORTING-TYPE. +The user will be prompted for the SORTING-TYPE if the call to this +function does not specify it. WHAT is only for the prompt, to indicate +what is being sorted. The sorting key will be extracted from +the car of the elements of the table. +If WITH-CASE is non-nil, the sorting will be case-sensitive." + (unless sorting-type + (message + "Sort %s:[a]lphabetically [n]umerically [t]ime. A/N/T means reversed:" + what) + (setq sorting-type (read-char-exclusive))) + (let ((dcst (downcase sorting-type)) + extractfun comparefun) + ;; Define the appropriate functions + (cond + ((= dcst ?n) + (setq extractfun 'string-to-number + comparefun (if (= dcst sorting-type) '< '>))) + ((= dcst ?a) + (setq extractfun (if with-case 'identity 'downcase) + comparefun (if (= dcst sorting-type) + 'string< + (lambda (a b) (and (not (string< a b)) + (not (string= a b))))))) + ((= dcst ?t) + (setq extractfun + (lambda (x) + (if (string-match org-ts-regexp x) + (time-to-seconds + (org-time-string-to-time (match-string 0 x))) + 0)) + comparefun (if (= dcst sorting-type) '< '>))) + (t (error "Invalid sorting type `%c'" sorting-type))) + + (sort (mapcar (lambda (x) (cons (funcall extractfun (car x)) (cdr x))) + table) + (lambda (a b) (funcall comparefun (car a) (car b)))))) + +;;;; Plain list items, including checkboxes + +;;; Plain list items (defun org-at-item-p () "Is point in a line starting a hand-formatted item?" @@ -4786,6 +4918,53 @@ If optional TXT is given, check this string instead of the current kill." ((= llt ?\)) "\\([ \t]*\\([-+]\\|\\([0-9]+)\\)\\)\\|[ \t]+\\*\\)\\( \\|$\\)") (t (error "Invalid value of `org-plain-list-ordered-item-terminator'"))))))) + +(defun org-in-item-p () + "It the cursor inside a plain list item. +Does not have to be the first line." + (save-excursion + (condition-case nil + (progn + (org-beginning-of-item) + (org-at-item-p) + t) + (error nil)))) + +(defun org-insert-item (&optional checkbox) + "Insert a new item at the current level. +Return t when things worked, nil when we are not in an item." + (when (save-excursion + (condition-case nil + (progn + (org-beginning-of-item) + (org-at-item-p) + (if (org-invisible-p) (error "Invisible item")) + t) + (error nil))) + (let* ((bul (match-string 0)) + (eow (save-excursion (beginning-of-line 1) (looking-at "[ \t]*") + (match-end 0))) + (blank (cdr (assq 'plain-list-item org-blank-before-new-entry))) + pos) + (cond + ((and (org-at-item-p) (<= (point) eow)) + ;; before the bullet + (beginning-of-line 1) + (open-line (if blank 2 1))) + ((<= (point) eow) + (beginning-of-line 1)) + (t (newline (if blank 2 1)))) + (insert bul (if checkbox "[ ]" "")) + (just-one-space) + (setq pos (point)) + (end-of-line 1) + (unless (= (point) pos) (just-one-space) (backward-delete-char 1))) + (org-maybe-renumber-ordered-list) + (and checkbox (org-update-checkbox-count-maybe)) + t)) + +;;; Checkboxes + (defun org-at-item-checkbox-p () "Is point at a line starting a plain-list item with a checklet?" (and (org-at-item-p) @@ -5156,7 +5335,7 @@ with something like \"1.\" or \"2)\"." (indent-to-column (+ ind1 arg)) (beginning-of-line 2))))) -;;; Archiving +;;;; Archiving (defun org-archive-subtree (&optional find-done) "Move the current subtree to the archive. @@ -5382,105 +5561,3965 @@ the children that do not contain any open TODO items." (and set (beginning-of-line 1)) (message "Subtree %s" (if set "archived" "unarchived"))))) -(defvar org-agenda-multi nil) ; dynammically scoped -(defvar org-agenda-buffer-name "*Org Agenda*") -(defvar org-pre-agenda-window-conf nil) -(defun org-prepare-agenda () - (if org-agenda-multi - (progn - (setq buffer-read-only nil) + +;;;; Tables + +;;; The table editor + +;; Watch out: Here we are talking about two different kind of tables. +;; Most of the code is for the tables created with the Org-mode table editor. +;; Sometimes, we talk about tables created and edited with the table.el +;; Emacs package. We call the former org-type tables, and the latter +;; table.el-type tables. + +(defun org-before-change-function (beg end) + "Every change indicates that a table might need an update." + (setq org-table-may-need-update t)) + +(defconst org-table-line-regexp "^[ \t]*|" + "Detects an org-type table line.") +(defconst org-table-dataline-regexp "^[ \t]*|[^-]" + "Detects an org-type table line.") +(defconst org-table-auto-recalculate-regexp "^[ \t]*| *# *\\(|\\|$\\)" + "Detects a table line marked for automatic recalculation.") +(defconst org-table-recalculate-regexp "^[ \t]*| *[#*] *\\(|\\|$\\)" + "Detects a table line marked for automatic recalculation.") +(defconst org-table-calculate-mark-regexp "^[ \t]*| *[!$^_#*] *\\(|\\|$\\)" + "Detects a table line marked for automatic recalculation.") +(defconst org-table-hline-regexp "^[ \t]*|-" + "Detects an org-type table hline.") +(defconst org-table1-hline-regexp "^[ \t]*\\+-[-+]" + "Detects a table-type table hline.") +(defconst org-table-any-line-regexp "^[ \t]*\\(|\\|\\+-[-+]\\)" + "Detects an org-type or table-type table.") +(defconst org-table-border-regexp "^[ \t]*[^| \t]" + "Searching from within a table (any type) this finds the first line +outside the table.") +(defconst org-table-any-border-regexp "^[ \t]*[^|+ \t]" + "Searching from within a table (any type) this finds the first line +outside the table.") + +(defun org-table-create-with-table.el () + "Use the table.el package to insert a new table. +If there is already a table at point, convert between Org-mode tables +and table.el tables." + (interactive) + (require 'table) + (cond + ((org-at-table.el-p) + (if (y-or-n-p "Convert table to Org-mode table? ") + (org-table-convert))) + ((org-at-table-p) + (if (y-or-n-p "Convert table to table.el table? ") + (org-table-convert))) + (t (call-interactively 'table-insert)))) + +(defun org-table-create-or-convert-from-region (arg) + "Convert region to table, or create an empty table. +If there is an active region, convert it to a table. If there is no such +region, create an empty table." + (interactive "P") + (if (org-region-active-p) + (org-table-convert-region (region-beginning) (region-end) arg) + (org-table-create arg))) + +(defun org-table-create (&optional size) + "Query for a size and insert a table skeleton. +SIZE is a string Columns x Rows like for example \"3x2\"." + (interactive "P") + (unless size + (setq size (read-string + (concat "Table size Columns x Rows [e.g. " + org-table-default-size "]: ") + "" nil org-table-default-size))) + + (let* ((pos (point)) + (indent (make-string (current-column) ?\ )) + (split (org-split-string size " *x *")) + (rows (string-to-number (nth 1 split))) + (columns (string-to-number (car split))) + (line (concat (apply 'concat indent "|" (make-list columns " |")) + "\n"))) + (if (string-match "^[ \t]*$" (buffer-substring-no-properties + (point-at-bol) (point))) + (beginning-of-line 1) + (newline)) + ;; (mapcar (lambda (x) (insert line)) (make-list rows t)) + (dotimes (i rows) (insert line)) + (goto-char pos) + (if (> rows 1) + ;; Insert a hline after the first row. + (progn + (end-of-line 1) + (insert "\n|-") + (goto-char pos))) + (org-table-align))) + +(defun org-table-convert-region (beg0 end0 &optional nspace) + "Convert region to a table. +The region goes from BEG0 to END0, but these borders will be moved +slightly, to make sure a beginning of line in the first line is included. +When NSPACE is non-nil, it indicates the minimum number of spaces that +separate columns (default: just one space)." + (interactive "rP") + (let* ((beg (min beg0 end0)) + (end (max beg0 end0)) + (tabsep t) + re) + (goto-char beg) + (beginning-of-line 1) + (setq beg (move-marker (make-marker) (point))) + (goto-char end) + (if (bolp) (backward-char 1) (end-of-line 1)) + (setq end (move-marker (make-marker) (point))) + ;; Lets see if this is tab-separated material. If every nonempty line + ;; contains a tab, we will assume that it is tab-separated material + (if nspace + (setq tabsep nil) + (goto-char beg) + (and (re-search-forward "^[^\n\t]+$" end t) (setq tabsep nil))) + (if nspace (setq tabsep nil)) + (if tabsep + (setq re "^\\|\t") + (setq re (format "^ *\\| *\t *\\| \\{%d,\\}" + (max 1 (prefix-numeric-value nspace))))) + (goto-char beg) + (while (re-search-forward re end t) + (replace-match "| " t t)) + (goto-char beg) + (insert " ") + (org-table-align))) + +(defun org-table-import (file arg) + "Import FILE as a table. +The file is assumed to be tab-separated. Such files can be produced by most +spreadsheet and database applications. If no tabs (at least one per line) +are found, lines will be split on whitespace into fields." + (interactive "f\nP") + (or (bolp) (newline)) + (let ((beg (point)) + (pm (point-max))) + (insert-file-contents file) + (org-table-convert-region beg (+ (point) (- (point-max) pm)) arg))) + +(defun org-table-export () + "Export table as a tab-separated file. +Such a file can be imported into a spreadsheet program like Excel." + (interactive) + (let* ((beg (org-table-begin)) + (end (org-table-end)) + (table (buffer-substring beg end)) + (file (read-file-name "Export table to: ")) + buf) + (unless (or (not (file-exists-p file)) + (y-or-n-p (format "Overwrite file %s? " file))) + (error "Abort")) + (with-current-buffer (find-file-noselect file) + (setq buf (current-buffer)) + (erase-buffer) + (fundamental-mode) + (insert table) + (goto-char (point-min)) + (while (re-search-forward "^[ \t]*|[ \t]*" nil t) + (replace-match "" t t) + (end-of-line 1)) + (goto-char (point-min)) + (while (re-search-forward "[ \t]*|[ \t]*$" nil t) + (replace-match "" t t) + (goto-char (min (1+ (point)) (point-max)))) + (goto-char (point-min)) + (while (re-search-forward "^-[-+]*$" nil t) + (replace-match "") + (if (looking-at "\n") + (delete-char 1))) + (goto-char (point-min)) + (while (re-search-forward "[ \t]*|[ \t]*" nil t) + (replace-match "\t" t t)) + (save-buffer)) + (kill-buffer buf))) + +(defvar org-table-aligned-begin-marker (make-marker) + "Marker at the beginning of the table last aligned. +Used to check if cursor still is in that table, to minimize realignment.") +(defvar org-table-aligned-end-marker (make-marker) + "Marker at the end of the table last aligned. +Used to check if cursor still is in that table, to minimize realignment.") +(defvar org-table-last-alignment nil + "List of flags for flushright alignment, from the last re-alignment. +This is being used to correctly align a single field after TAB or RET.") +(defvar org-table-last-column-widths nil + "List of max width of fields in each column. +This is being used to correctly align a single field after TAB or RET.") + +(defvar org-last-recalc-line nil) +(defconst org-narrow-column-arrow "=>" + "Used as display property in narrowed table columns.") + +(defun org-table-align () + "Align the table at point by aligning all vertical bars." + (interactive) + (let* ( + ;; Limits of table + (beg (org-table-begin)) + (end (org-table-end)) + ;; Current cursor position + (linepos (org-current-line)) + (colpos (org-table-current-column)) + (winstart (window-start)) + (winstartline (org-current-line (min winstart (1- (point-max))))) + lines (new "") lengths l typenums ty fields maxfields i + column + (indent "") cnt frac + rfmt hfmt + (spaces '(1 . 1)) + (sp1 (car spaces)) + (sp2 (cdr spaces)) + (rfmt1 (concat + (make-string sp2 ?\ ) "%%%s%ds" (make-string sp1 ?\ ) "|")) + (hfmt1 (concat + (make-string sp2 ?-) "%s" (make-string sp1 ?-) "+")) + emptystrings links dates narrow fmax f1 len c e) + (untabify beg end) + (remove-text-properties beg end '(org-cwidth t org-dwidth t display t)) + ;; Check if we have links or dates + (goto-char beg) + (setq links (re-search-forward org-bracket-link-regexp end t)) + (goto-char beg) + (setq dates (and org-display-custom-times + (re-search-forward org-ts-regexp-both end t))) + ;; Make sure the link properties are right + (when links (goto-char beg) (while (org-activate-bracket-links end))) + ;; Make sure the date properties are right + (when dates (goto-char beg) (while (org-activate-dates end))) + + ;; Check if we are narrowing any columns + (goto-char beg) + (setq narrow (and org-format-transports-properties-p + (re-search-forward "<[0-9]+>" end t))) + ;; Get the rows + (setq lines (org-split-string + (buffer-substring beg end) "\n")) + ;; Store the indentation of the first line + (if (string-match "^ *" (car lines)) + (setq indent (make-string (- (match-end 0) (match-beginning 0)) ?\ ))) + ;; Mark the hlines by setting the corresponding element to nil + ;; At the same time, we remove trailing space. + (setq lines (mapcar (lambda (l) + (if (string-match "^ *|-" l) + nil + (if (string-match "[ \t]+$" l) + (substring l 0 (match-beginning 0)) + l))) + lines)) + ;; Get the data fields by splitting the lines. + (setq fields (mapcar + (lambda (l) + (org-split-string l " *| *")) + (delq nil (copy-sequence lines)))) + ;; How many fields in the longest line? + (condition-case nil + (setq maxfields (apply 'max (mapcar 'length fields))) + (error + (kill-region beg end) + (org-table-create org-table-default-size) + (error "Empty table - created default table"))) + ;; A list of empty strings to fill any short rows on output + (setq emptystrings (make-list maxfields "")) + ;; Check for special formatting. + (setq i -1) + (while (< (setq i (1+ i)) maxfields) ;; Loop over all columns + (setq column (mapcar (lambda (x) (or (nth i x) "")) fields)) + ;; Check if there is an explicit width specified + (when (and org-table-limit-column-width narrow) + (setq c column fmax nil) + (while c + (setq e (pop c)) + (if (and (stringp e) (string-match "^<\\([0-9]+\\)>$" e)) + (setq fmax (string-to-number (match-string 1 e)) c nil))) + ;; Find fields that are wider than fmax, and shorten them + (when fmax + (loop for xx in column do + (when (and (stringp xx) + (> (org-string-width xx) fmax)) + (org-add-props xx nil + 'help-echo + (concat "Clipped table field, use C-c ` to edit. Full value is:\n" (org-no-properties (copy-sequence xx)))) + (setq f1 (min fmax (or (string-match org-bracket-link-regexp xx) fmax))) + (unless (> f1 1) + (error "Cannot narrow field starting with wide link \"%s\"" + (match-string 0 xx))) + (add-text-properties f1 (length xx) (list 'org-cwidth t) xx) + (add-text-properties (- f1 2) f1 + (list 'display org-narrow-column-arrow) + xx))))) + ;; Get the maximum width for each column + (push (apply 'max 1 (mapcar 'org-string-width column)) lengths) + ;; Get the fraction of numbers, to decide about alignment of the column + (setq cnt 0 frac 0.0) + (loop for x in column do + (if (equal x "") + nil + (setq frac ( / (+ (* frac cnt) + (if (string-match org-table-number-regexp x) 1 0)) + (setq cnt (1+ cnt)))))) + (push (>= frac org-table-number-fraction) typenums)) + (setq lengths (nreverse lengths) typenums (nreverse typenums)) + + ;; Store the alignment of this table, for later editing of single fields + (setq org-table-last-alignment typenums + org-table-last-column-widths lengths) + + ;; With invisible characters, `format' does not get the field width right + ;; So we need to make these fields wide by hand. + (when links + (loop for i from 0 upto (1- maxfields) do + (setq len (nth i lengths)) + (loop for j from 0 upto (1- (length fields)) do + (setq c (nthcdr i (car (nthcdr j fields)))) + (if (and (stringp (car c)) + (string-match org-bracket-link-regexp (car c)) + (< (org-string-width (car c)) len)) + (setcar c (concat (car c) (make-string (- len (org-string-width (car c))) ?\ ))))))) + + ;; Compute the formats needed for output of the table + (setq rfmt (concat indent "|") hfmt (concat indent "|")) + (while (setq l (pop lengths)) + (setq ty (if (pop typenums) "" "-")) ; number types flushright + (setq rfmt (concat rfmt (format rfmt1 ty l)) + hfmt (concat hfmt (format hfmt1 (make-string l ?-))))) + (setq rfmt (concat rfmt "\n") + hfmt (concat (substring hfmt 0 -1) "|\n")) + + (setq new (mapconcat + (lambda (l) + (if l (apply 'format rfmt + (append (pop fields) emptystrings)) + hfmt)) + lines "")) + ;; Replace the old one + (delete-region beg end) + (move-marker end nil) + (move-marker org-table-aligned-begin-marker (point)) + (insert new) + (move-marker org-table-aligned-end-marker (point)) + (when (and orgtbl-mode (not (org-mode-p))) + (goto-char org-table-aligned-begin-marker) + (while (org-hide-wide-columns org-table-aligned-end-marker))) + ;; Try to move to the old location + (goto-line winstartline) + (setq winstart (point-at-bol)) + (goto-line linepos) + (set-window-start (selected-window) winstart 'noforce) + (org-table-goto-column colpos) + (setq org-table-may-need-update nil) + )) + +(defun org-string-width (s) + "Compute width of string, ignoring invisible characters. +This ignores character with invisibility property `org-link', and also +characters with property `org-cwidth', because these will become invisible +upon the next fontification round." + (let (b l) + (when (or (eq t buffer-invisibility-spec) + (assq 'org-link buffer-invisibility-spec)) + (while (setq b (text-property-any 0 (length s) + 'invisible 'org-link s)) + (setq s (concat (substring s 0 b) + (substring s (or (next-single-property-change + b 'invisible s) (length s))))))) + (while (setq b (text-property-any 0 (length s) 'org-cwidth t s)) + (setq s (concat (substring s 0 b) + (substring s (or (next-single-property-change + b 'org-cwidth s) (length s)))))) + (setq l (string-width s) b -1) + (while (setq b (text-property-any (1+ b) (length s) 'org-dwidth t s)) + (setq l (- l (get-text-property b 'org-dwidth-n s)))) + l)) + +(defun org-table-begin (&optional table-type) + "Find the beginning of the table and return its position. +With argument TABLE-TYPE, go to the beginning of a table.el-type table." + (save-excursion + (if (not (re-search-backward + (if table-type org-table-any-border-regexp + org-table-border-regexp) + nil t)) + (progn (goto-char (point-min)) (point)) + (goto-char (match-beginning 0)) + (beginning-of-line 2) + (point)))) + +(defun org-table-end (&optional table-type) + "Find the end of the table and return its position. +With argument TABLE-TYPE, go to the end of a table.el-type table." + (save-excursion + (if (not (re-search-forward + (if table-type org-table-any-border-regexp + org-table-border-regexp) + nil t)) (goto-char (point-max)) - (unless (= (point) 1) - (insert "\n" (make-string (window-width) ?=) "\n")) - (narrow-to-region (point) (point-max))) - (org-agenda-maybe-reset-markers 'force) - (org-prepare-agenda-buffers (org-agenda-files)) - (let* ((abuf (get-buffer-create org-agenda-buffer-name)) - (awin (get-buffer-window abuf))) + (goto-char (match-beginning 0))) + (point-marker))) + +(defun org-table-justify-field-maybe (&optional new) + "Justify the current field, text to left, number to right. +Optional argument NEW may specify text to replace the current field content." + (cond + ((and (not new) org-table-may-need-update)) ; Realignment will happen anyway + ((org-at-table-hline-p)) + ((and (not new) + (or (not (equal (marker-buffer org-table-aligned-begin-marker) + (current-buffer))) + (< (point) org-table-aligned-begin-marker) + (>= (point) org-table-aligned-end-marker))) + ;; This is not the same table, force a full re-align + (setq org-table-may-need-update t)) + (t ;; realign the current field, based on previous full realign + (let* ((pos (point)) s + (col (org-table-current-column)) + (num (if (> col 0) (nth (1- col) org-table-last-alignment))) + l f n o e) + (when (> col 0) + (skip-chars-backward "^|\n") + (if (looking-at " *\\([^|\n]*?\\) *\\(|\\|$\\)") + (progn + (setq s (match-string 1) + o (match-string 0) + l (max 1 (- (match-end 0) (match-beginning 0) 3)) + e (not (= (match-beginning 2) (match-end 2)))) + (setq f (format (if num " %%%ds %s" " %%-%ds %s") + l (if e "|" (setq org-table-may-need-update t) "")) + n (format f s)) + (if new + (if (<= (length new) l) ;; FIXME: length -> str-width? + (setq n (format f new)) + (setq n (concat new "|") org-table-may-need-update t))) + (or (equal n o) + (let (org-table-may-need-update) + (replace-match n)))) + (setq org-table-may-need-update t)) + (goto-char pos)))))) + +(defun org-table-next-field () + "Go to the next field in the current table, creating new lines as needed. +Before doing so, re-align the table if necessary." + (interactive) + (org-table-maybe-eval-formula) + (org-table-maybe-recalculate-line) + (if (and org-table-automatic-realign + org-table-may-need-update) + (org-table-align)) + (let ((end (org-table-end))) + (if (org-at-table-hline-p) + (end-of-line 1)) + (condition-case nil + (progn + (re-search-forward "|" end) + (if (looking-at "[ \t]*$") + (re-search-forward "|" end)) + (if (and (looking-at "-") + org-table-tab-jumps-over-hlines + (re-search-forward "^[ \t]*|\\([^-]\\)" end t)) + (goto-char (match-beginning 1))) + (if (looking-at "-") + (progn + (beginning-of-line 0) + (org-table-insert-row 'below)) + (if (looking-at " ") (forward-char 1)))) + (error + (org-table-insert-row 'below))))) + +(defun org-table-previous-field () + "Go to the previous field in the table. +Before doing so, re-align the table if necessary." + (interactive) + (org-table-justify-field-maybe) + (org-table-maybe-recalculate-line) + (if (and org-table-automatic-realign + org-table-may-need-update) + (org-table-align)) + (if (org-at-table-hline-p) + (end-of-line 1)) + (re-search-backward "|" (org-table-begin)) + (re-search-backward "|" (org-table-begin)) + (while (looking-at "|\\(-\\|[ \t]*$\\)") + (re-search-backward "|" (org-table-begin))) + (if (looking-at "| ?") + (goto-char (match-end 0)))) + +(defun org-table-next-row () + "Go to the next row (same column) in the current table. +Before doing so, re-align the table if necessary." + (interactive) + (org-table-maybe-eval-formula) + (org-table-maybe-recalculate-line) + (if (or (looking-at "[ \t]*$") + (save-excursion (skip-chars-backward " \t") (bolp))) + (newline) + (if (and org-table-automatic-realign + org-table-may-need-update) + (org-table-align)) + (let ((col (org-table-current-column))) + (beginning-of-line 2) + (if (or (not (org-at-table-p)) + (org-at-table-hline-p)) + (progn + (beginning-of-line 0) + (org-table-insert-row 'below))) + (org-table-goto-column col) + (skip-chars-backward "^|\n\r") + (if (looking-at " ") (forward-char 1))))) + +(defun org-table-copy-down (n) + "Copy a field down in the current column. +If the field at the cursor is empty, copy into it the content of the nearest +non-empty field above. With argument N, use the Nth non-empty field. +If the current field is not empty, it is copied down to the next row, and +the cursor is moved with it. Therefore, repeating this command causes the +column to be filled row-by-row. +If the variable `org-table-copy-increment' is non-nil and the field is an +integer, it will be incremented while copying." + (interactive "p") + (let* ((colpos (org-table-current-column)) + (field (org-table-get-field)) + (non-empty (string-match "[^ \t]" field)) + (beg (org-table-begin)) + txt) + (org-table-check-inside-data-field) + (if non-empty + (progn + (setq txt (org-trim field)) + (org-table-next-row) + (org-table-blank-field)) + (save-excursion + (setq txt + (catch 'exit + (while (progn (beginning-of-line 1) + (re-search-backward org-table-dataline-regexp + beg t)) + (org-table-goto-column colpos t) + (if (and (looking-at + "|[ \t]*\\([^| \t][^|]*?\\)[ \t]*|") + (= (setq n (1- n)) 0)) + (throw 'exit (match-string 1)))))))) + (if txt + (progn + (if (and org-table-copy-increment + (string-match "^[0-9]+$" txt)) + (setq txt (format "%d" (+ (string-to-number txt) 1)))) + (insert txt) + (org-table-maybe-recalculate-line) + (org-table-align)) + (error "No non-empty field found")))) + +(defun org-table-check-inside-data-field () + "Is point inside a table data field? +I.e. not on a hline or before the first or after the last column? +This actually throws an error, so it aborts the current command." + (if (or (not (org-at-table-p)) + (= (org-table-current-column) 0) + (org-at-table-hline-p) + (looking-at "[ \t]*$")) + (error "Not in table data field"))) + +(defvar org-table-clip nil + "Clipboard for table regions.") + +(defun org-table-blank-field () + "Blank the current table field or active region." + (interactive) + (org-table-check-inside-data-field) + (if (and (interactive-p) (org-region-active-p)) + (let (org-table-clip) + (org-table-cut-region (region-beginning) (region-end))) + (skip-chars-backward "^|") + (backward-char 1) + (if (looking-at "|[^|\n]+") + (let* ((pos (match-beginning 0)) + (match (match-string 0)) + (len (org-string-width match))) + (replace-match (concat "|" (make-string (1- len) ?\ ))) + (goto-char (+ 2 pos)) + (substring match 1))))) + +(defun org-table-get-field (&optional n replace) + "Return the value of the field in column N of current row. +N defaults to current field. +If REPLACE is a string, replace field with this value. The return value +is always the old value." + (and n (org-table-goto-column n)) + (skip-chars-backward "^|\n") + (backward-char 1) + (if (looking-at "|[^|\r\n]*") + (let* ((pos (match-beginning 0)) + (val (buffer-substring (1+ pos) (match-end 0)))) + (if replace + (replace-match (concat "|" replace))) + (goto-char (min (point-at-eol) (+ 2 pos))) + val) + (forward-char 1) "")) + +(defun org-table-current-column () + "Find out which column we are in. +When called interactively, column is also displayed in echo area." + (interactive) + (if (interactive-p) (org-table-check-inside-data-field)) + (save-excursion + (let ((cnt 0) (pos (point))) + (beginning-of-line 1) + (while (search-forward "|" pos t) + (setq cnt (1+ cnt))) + (if (interactive-p) (message "This is table column %d" cnt)) + cnt))) + +(defun org-table-goto-column (n &optional on-delim force) + "Move the cursor to the Nth column in the current table line. +With optional argument ON-DELIM, stop with point before the left delimiter +of the field. +If there are less than N fields, just go to after the last delimiter. +However, when FORCE is non-nil, create new columns if necessary." + (interactive "p") + (let ((pos (point-at-eol))) + (beginning-of-line 1) + (when (> n 0) + (while (and (> (setq n (1- n)) -1) + (or (search-forward "|" pos t) + (and force + (progn (end-of-line 1) + (skip-chars-backward "^|") + (insert " | ")))))) +; (backward-char 2) t))))) + (when (and force (not (looking-at ".*|"))) + (save-excursion (end-of-line 1) (insert " | "))) + (if on-delim + (backward-char 1) + (if (looking-at " ") (forward-char 1)))))) + +(defun org-at-table-p (&optional table-type) + "Return t if the cursor is inside an org-type table. +If TABLE-TYPE is non-nil, also check for table.el-type tables." + (if org-enable-table-editor + (save-excursion + (beginning-of-line 1) + (looking-at (if table-type org-table-any-line-regexp + org-table-line-regexp))) + nil)) + +(defun org-at-table.el-p () + "Return t if and only if we are at a table.el table." + (and (org-at-table-p 'any) + (save-excursion + (goto-char (org-table-begin 'any)) + (looking-at org-table1-hline-regexp)))) + +(defun org-table-recognize-table.el () + "If there is a table.el table nearby, recognize it and move into it." + (if org-table-tab-recognizes-table.el + (if (org-at-table.el-p) + (progn + (beginning-of-line 1) + (if (looking-at org-table-dataline-regexp) + nil + (if (looking-at org-table1-hline-regexp) + (progn + (beginning-of-line 2) + (if (looking-at org-table-any-border-regexp) + (beginning-of-line -1))))) + (if (re-search-forward "|" (org-table-end t) t) + (progn + (require 'table) + (if (table--at-cell-p (point)) + t + (message "recognizing table.el table...") + (table-recognize-table) + (message "recognizing table.el table...done"))) + (error "This should not happen...")) + t) + nil) + nil)) + +(defun org-at-table-hline-p () + "Return t if the cursor is inside a hline in a table." + (if org-enable-table-editor + (save-excursion + (beginning-of-line 1) + (looking-at org-table-hline-regexp)) + nil)) + +(defun org-table-insert-column () + "Insert a new column into the table." + (interactive) + (if (not (org-at-table-p)) + (error "Not at a table")) + (org-table-find-dataline) + (let* ((col (max 1 (org-table-current-column))) + (beg (org-table-begin)) + (end (org-table-end)) + ;; Current cursor position + (linepos (org-current-line)) + (colpos col)) + (goto-char beg) + (while (< (point) end) + (if (org-at-table-hline-p) + nil + (org-table-goto-column col t) + (insert "| ")) + (beginning-of-line 2)) + (move-marker end nil) + (goto-line linepos) + (org-table-goto-column colpos) + (org-table-align) + (org-table-modify-formulas 'insert col))) + +(defun org-table-find-dataline () + "Find a dataline in the current table, which is needed for column commands." + (if (and (org-at-table-p) + (not (org-at-table-hline-p))) + t + (let ((col (current-column)) + (end (org-table-end))) + (move-to-column col) + (while (and (< (point) end) + (or (not (= (current-column) col)) + (org-at-table-hline-p))) + (beginning-of-line 2) + (move-to-column col)) + (if (and (org-at-table-p) + (not (org-at-table-hline-p))) + t + (error + "Please position cursor in a data line for column operations"))))) + +(defun org-table-delete-column () + "Delete a column from the table." + (interactive) + (if (not (org-at-table-p)) + (error "Not at a table")) + (org-table-find-dataline) + (org-table-check-inside-data-field) + (let* ((col (org-table-current-column)) + (beg (org-table-begin)) + (end (org-table-end)) + ;; Current cursor position + (linepos (org-current-line)) + (colpos col)) + (goto-char beg) + (while (< (point) end) + (if (org-at-table-hline-p) + nil + (org-table-goto-column col t) + (and (looking-at "|[^|\n]+|") + (replace-match "|"))) + (beginning-of-line 2)) + (move-marker end nil) + (goto-line linepos) + (org-table-goto-column colpos) + (org-table-align) + (org-table-modify-formulas 'remove col))) + +(defun org-table-move-column-right () + "Move column to the right." + (interactive) + (org-table-move-column nil)) +(defun org-table-move-column-left () + "Move column to the left." + (interactive) + (org-table-move-column 'left)) + +(defun org-table-move-column (&optional left) + "Move the current column to the right. With arg LEFT, move to the left." + (interactive "P") + (if (not (org-at-table-p)) + (error "Not at a table")) + (org-table-find-dataline) + (org-table-check-inside-data-field) + (let* ((col (org-table-current-column)) + (col1 (if left (1- col) col)) + (beg (org-table-begin)) + (end (org-table-end)) + ;; Current cursor position + (linepos (org-current-line)) + (colpos (if left (1- col) (1+ col)))) + (if (and left (= col 1)) + (error "Cannot move column further left")) + (if (and (not left) (looking-at "[^|\n]*|[^|\n]*$")) + (error "Cannot move column further right")) + (goto-char beg) + (while (< (point) end) + (if (org-at-table-hline-p) + nil + (org-table-goto-column col1 t) + (and (looking-at "|\\([^|\n]+\\)|\\([^|\n]+\\)|") + (replace-match "|\\2|\\1|"))) + (beginning-of-line 2)) + (move-marker end nil) + (goto-line linepos) + (org-table-goto-column colpos) + (org-table-align) + (org-table-modify-formulas 'swap col (if left (1- col) (1+ col))))) + +(defun org-table-move-row-down () + "Move table row down." + (interactive) + (org-table-move-row nil)) +(defun org-table-move-row-up () + "Move table row up." + (interactive) + (org-table-move-row 'up)) + +(defun org-table-move-row (&optional up) + "Move the current table line down. With arg UP, move it up." + (interactive "P") + (let ((col (current-column)) + (pos (point)) + (tonew (if up 0 2)) + txt) + (beginning-of-line tonew) + (if (not (org-at-table-p)) + (progn + (goto-char pos) + (error "Cannot move row further"))) + (goto-char pos) + (beginning-of-line 1) + (setq pos (point)) + (setq txt (buffer-substring (point) (1+ (point-at-eol)))) + (delete-region (point) (1+ (point-at-eol))) + (beginning-of-line tonew) + (insert txt) + (beginning-of-line 0) + (move-to-column col))) + +(defun org-table-insert-row (&optional arg) + "Insert a new row above the current line into the table. +With prefix ARG, insert below the current line." + (interactive "P") + (if (not (org-at-table-p)) + (error "Not at a table")) + (let* ((line (buffer-substring (point-at-bol) (point-at-eol))) + (new (org-table-clean-line line))) + ;; Fix the first field if necessary + (if (string-match "^[ \t]*| *[#$] *|" line) + (setq new (replace-match (match-string 0 line) t t new))) + (beginning-of-line (if arg 2 1)) + (let (org-table-may-need-update) (insert-before-markers new "\n")) + (beginning-of-line 0) + (re-search-forward "| ?" (point-at-eol) t) + (and org-table-may-need-update (org-table-align)))) + +(defun org-table-insert-hline (&optional arg) + "Insert a horizontal-line below the current line into the table. +With prefix ARG, insert above the current line." + (interactive "P") + (if (not (org-at-table-p)) + (error "Not at a table")) + (let ((line (org-table-clean-line + (buffer-substring (point-at-bol) (point-at-eol)))) + (col (current-column))) + (while (string-match "|\\( +\\)|" line) + (setq line (replace-match + (concat "+" (make-string (- (match-end 1) (match-beginning 1)) + ?-) "|") t t line))) + (and (string-match "\\+" line) (setq line (replace-match "|" t t line))) + (beginning-of-line (if arg 1 2)) + (insert line "\n") + (beginning-of-line (if arg 1 -1)) + (move-to-column col))) + +(defun org-table-clean-line (s) + "Convert a table line S into a string with only \"|\" and space. +In particular, this does handle wide and invisible characters." + (if (string-match "^[ \t]*|-" s) + ;; It's a hline, just map the characters + (setq s (mapconcat (lambda (x) (if (member x '(?| ?+)) "|" " ")) s "")) + (while (string-match "|\\([ \t]*?[^ \t\r\n|][^\r\n|]*\\)|" s) + (setq s (replace-match + (concat "|" (make-string (org-string-width (match-string 1 s)) + ?\ ) "|") + t t s))) + s)) + +(defun org-table-kill-row () + "Delete the current row or horizontal line from the table." + (interactive) + (if (not (org-at-table-p)) + (error "Not at a table")) + (let ((col (current-column))) + (kill-region (point-at-bol) (min (1+ (point-at-eol)) (point-max))) + (if (not (org-at-table-p)) (beginning-of-line 0)) + (move-to-column col))) + +(defun org-table-sort-lines (with-case &optional sorting-type) + "Sort table lines according to the column at point. + +The position of point indicates the column to be used for +sorting, and the range of lines is the range between the nearest +horizontal separator lines, or the entire table of no such lines +exist. If point is before the first column, you will be prompted +for the sorting column. If there is an active region, the mark +specifies the first line and the sorting column, while point +should be in the last line to be included into the sorting. + +The command then prompts for the sorting type which can be +alphabetically, numerically, or by time (as given in a time stamp +in the field). Sorting in reverse order is also possible. + +With prefix argument WITH-CASE, alphabetic sorting will be case-sensitive. + +If SORTING-TYPE is specified when this function is called from a Lisp +program, no prompting will take place. SORTING-TYPE must be a character, +any of (?a ?A ?n ?N ?t ?T) where the capital letter indicate that sorting +should be done in reverse order." + (interactive "P") + (let* ((thisline (org-current-line)) + (thiscol (org-table-current-column)) + beg end bcol ecol tend tbeg column lns pos) + (when (equal thiscol 0) + (if (interactive-p) + (setq thiscol + (string-to-number + (read-string "Use column N for sorting: "))) + (setq thiscol 1)) + (org-table-goto-column thiscol)) + (org-table-check-inside-data-field) + (if (org-region-active-p) + (progn + (setq beg (region-beginning) end (region-end)) + (goto-char beg) + (setq column (org-table-current-column) + beg (point-at-bol)) + (goto-char end) + (setq end (point-at-bol 2))) + (setq column (org-table-current-column) + pos (point) + tbeg (org-table-begin) + tend (org-table-end)) + (if (re-search-backward org-table-hline-regexp tbeg t) + (setq beg (point-at-bol 2)) + (goto-char tbeg) + (setq beg (point-at-bol 1))) + (goto-char pos) + (if (re-search-forward org-table-hline-regexp tend t) + (setq beg (point-at-bol 0)) + (goto-char tend) + (setq end (point-at-bol)))) + (setq beg (move-marker (make-marker) beg) + end (move-marker (make-marker) end)) + (untabify beg end) + (goto-char beg) + (org-table-goto-column column) + (skip-chars-backward "^|") + (setq bcol (current-column)) + (org-table-goto-column (1+ column)) + (skip-chars-backward "^|") + (setq ecol (1- (current-column))) + (org-table-goto-column column) + (setq lns (mapcar (lambda(x) (cons (org-trim (substring x bcol ecol)) x)) + (org-split-string (buffer-substring beg end) "\n"))) + (setq lns (org-do-sort lns "Table" with-case sorting-type)) + (delete-region beg end) + (move-marker beg nil) + (move-marker end nil) + (insert (mapconcat 'cdr lns "\n") "\n") + (goto-line thisline) + (org-table-goto-column thiscol) + (message "%d lines sorted, based on column %d" (length lns) column))) + +(defun org-table-cut-region (beg end) + "Copy region in table to the clipboard and blank all relevant fields." + (interactive "r") + (org-table-copy-region beg end 'cut)) + +(defun org-table-copy-region (beg end &optional cut) + "Copy rectangular region in table to clipboard. +A special clipboard is used which can only be accessed +with `org-table-paste-rectangle'." + (interactive "rP") + (let* (l01 c01 l02 c02 l1 c1 l2 c2 ic1 ic2 + region cols + (rpl (if cut " " nil))) + (goto-char beg) + (org-table-check-inside-data-field) + (setq l01 (count-lines (point-min) (point)) + c01 (org-table-current-column)) + (goto-char end) + (org-table-check-inside-data-field) + (setq l02 (count-lines (point-min) (point)) + c02 (org-table-current-column)) + (setq l1 (min l01 l02) l2 (max l01 l02) + c1 (min c01 c02) c2 (max c01 c02)) + (catch 'exit + (while t + (catch 'nextline + (if (> l1 l2) (throw 'exit t)) + (goto-line l1) + (if (org-at-table-hline-p) (throw 'nextline (setq l1 (1+ l1)))) + (setq cols nil ic1 c1 ic2 c2) + (while (< ic1 (1+ ic2)) + (push (org-table-get-field ic1 rpl) cols) + (setq ic1 (1+ ic1))) + (push (nreverse cols) region) + (setq l1 (1+ l1))))) + (setq org-table-clip (nreverse region)) + (if cut (org-table-align)) + org-table-clip)) + +(defun org-table-paste-rectangle () + "Paste a rectangular region into a table. +The upper right corner ends up in the current field. All involved fields +will be overwritten. If the rectangle does not fit into the present table, +the table is enlarged as needed. The process ignores horizontal separator +lines." + (interactive) + (unless (and org-table-clip (listp org-table-clip)) + (error "First cut/copy a region to paste!")) + (org-table-check-inside-data-field) + (let* ((clip org-table-clip) + (line (count-lines (point-min) (point))) + (col (org-table-current-column)) + (org-enable-table-editor t) + (org-table-automatic-realign nil) + c cols field) + (while (setq cols (pop clip)) + (while (org-at-table-hline-p) (beginning-of-line 2)) + (if (not (org-at-table-p)) + (progn (end-of-line 0) (org-table-next-field))) + (setq c col) + (while (setq field (pop cols)) + (org-table-goto-column c nil 'force) + (org-table-get-field nil field) + (setq c (1+ c))) + (beginning-of-line 2)) + (goto-line line) + (org-table-goto-column col) + (org-table-align))) + +(defun org-table-convert () + "Convert from `org-mode' table to table.el and back. +Obviously, this only works within limits. When an Org-mode table is +converted to table.el, all horizontal separator lines get lost, because +table.el uses these as cell boundaries and has no notion of horizontal lines. +A table.el table can be converted to an Org-mode table only if it does not +do row or column spanning. Multiline cells will become multiple cells. +Beware, Org-mode does not test if the table can be successfully converted - it +blindly applies a recipe that works for simple tables." + (interactive) + (require 'table) + (if (org-at-table.el-p) + ;; convert to Org-mode table + (let ((beg (move-marker (make-marker) (org-table-begin t))) + (end (move-marker (make-marker) (org-table-end t)))) + (table-unrecognize-region beg end) + (goto-char beg) + (while (re-search-forward "^\\([ \t]*\\)\\+-.*\n" end t) + (replace-match "")) + (goto-char beg)) + (if (org-at-table-p) + ;; convert to table.el table + (let ((beg (move-marker (make-marker) (org-table-begin))) + (end (move-marker (make-marker) (org-table-end)))) + ;; first, get rid of all horizontal lines + (goto-char beg) + (while (re-search-forward "^\\([ \t]*\\)|-.*\n" end t) + (replace-match "")) + ;; insert a hline before first + (goto-char beg) + (org-table-insert-hline 'above) + (beginning-of-line -1) + ;; insert a hline after each line + (while (progn (beginning-of-line 3) (< (point) end)) + (org-table-insert-hline)) + (goto-char beg) + (setq end (move-marker end (org-table-end))) + ;; replace "+" at beginning and ending of hlines + (while (re-search-forward "^\\([ \t]*\\)|-" end t) + (replace-match "\\1+-")) + (goto-char beg) + (while (re-search-forward "-|[ \t]*$" end t) + (replace-match "-+")) + (goto-char beg))))) + +(defun org-table-wrap-region (arg) + "Wrap several fields in a column like a paragraph. +This is useful if you'd like to spread the contents of a field over several +lines, in order to keep the table compact. + +If there is an active region, and both point and mark are in the same column, +the text in the column is wrapped to minimum width for the given number of +lines. Generally, this makes the table more compact. A prefix ARG may be +used to change the number of desired lines. For example, `C-2 \\[org-table-wrap]' +formats the selected text to two lines. If the region was longer than two +lines, the remaining lines remain empty. A negative prefix argument reduces +the current number of lines by that amount. The wrapped text is pasted back +into the table. If you formatted it to more lines than it was before, fields +further down in the table get overwritten - so you might need to make space in +the table first. + +If there is no region, the current field is split at the cursor position and +the text fragment to the right of the cursor is prepended to the field one +line down. + +If there is no region, but you specify a prefix ARG, the current field gets +blank, and the content is appended to the field above." + (interactive "P") + (org-table-check-inside-data-field) + (if (org-region-active-p) + ;; There is a region: fill as a paragraph + (let ((beg (region-beginning)) + nlines) + (org-table-cut-region (region-beginning) (region-end)) + (if (> (length (car org-table-clip)) 1) + (error "Region must be limited to single column")) + (setq nlines (if arg + (if (< arg 1) + (+ (length org-table-clip) arg) + arg) + (length org-table-clip))) + (setq org-table-clip + (mapcar 'list (org-wrap (mapconcat 'car org-table-clip " ") + nil nlines))) + (goto-char beg) + (org-table-paste-rectangle)) + ;; No region, split the current field at point + (if arg + ;; combine with field above + (let ((s (org-table-blank-field)) + (col (org-table-current-column))) + (beginning-of-line 0) + (while (org-at-table-hline-p) (beginning-of-line 0)) + (org-table-goto-column col) + (skip-chars-forward "^|") + (skip-chars-backward " ") + (insert " " (org-trim s)) + (org-table-align)) + ;; split field + (when (looking-at "\\([^|]+\\)+|") + (let ((s (match-string 1))) + (replace-match " |") + (goto-char (match-beginning 0)) + (org-table-next-row) + (insert (org-trim s) " ") + (org-table-align)))))) + +(defvar org-field-marker nil) + +(defun org-table-edit-field (arg) + "Edit table field in a different window. +This is mainly useful for fields that contain hidden parts. +When called with a \\[universal-argument] prefix, just make the full field visible so that +it can be edited in place." + (interactive "P") + (if arg + (let ((b (save-excursion (skip-chars-backward "^|") (point))) + (e (save-excursion (skip-chars-forward "^|\r\n") (point)))) + (remove-text-properties b e '(org-cwidth t invisible t + display t intangible t)) + (if (and (boundp 'font-lock-mode) font-lock-mode) + (font-lock-fontify-block))) + (let ((pos (move-marker (make-marker) (point))) + (field (org-table-get-field)) + (cw (current-window-configuration)) + p) + (switch-to-buffer-other-window "*Org tmp*") + (erase-buffer) + (insert "#\n# Edit field and finish with C-c C-c\n#\n") + (org-mode) + (goto-char (setq p (point-max))) + (insert (org-trim field)) + (remove-text-properties p (point-max) + '(invisible t org-cwidth t display t + intangible t)) + (goto-char p) + (org-set-local 'org-finish-function + 'org-table-finish-edit-field) + (org-set-local 'org-window-configuration cw) + (org-set-local 'org-field-marker pos) + (message "Edit and finish with C-c C-c")))) + +(defun org-table-finish-edit-field () + "Finish editing a table data field. +Remove all newline characters, insert the result into the table, realign +the table and kill the editing buffer." + (let ((pos org-field-marker) + (cw org-window-configuration) + (cb (current-buffer)) + text) + (goto-char (point-min)) + (while (re-search-forward "^#.*\n?" nil t) (replace-match "")) + (while (re-search-forward "\\([ \t]*\n[ \t]*\\)+" nil t) + (replace-match " ")) + (setq text (org-trim (buffer-string))) + (set-window-configuration cw) + (kill-buffer cb) + (select-window (get-buffer-window (marker-buffer pos))) + (goto-char pos) + (move-marker pos nil) + (org-table-check-inside-data-field) + (org-table-get-field nil text) + (org-table-align) + (message "New field value inserted"))) + +(defun org-trim (s) + "Remove whitespace at beginning and end of string." + (if (string-match "^[ \t]+" s) (setq s (replace-match "" t t s))) + (if (string-match "[ \t]+$" s) (setq s (replace-match "" t t s))) + s) + +(defun org-wrap (string &optional width lines) + "Wrap string to either a number of lines, or a width in characters. +If WIDTH is non-nil, the string is wrapped to that width, however many lines +that costs. If there is a word longer than WIDTH, the text is actually +wrapped to the length of that word. +IF WIDTH is nil and LINES is non-nil, the string is forced into at most that +many lines, whatever width that takes. +The return value is a list of lines, without newlines at the end." + (let* ((words (org-split-string string "[ \t\n]+")) + (maxword (apply 'max (mapcar 'org-string-width words))) + w ll) + (cond (width + (org-do-wrap words (max maxword width))) + (lines + (setq w maxword) + (setq ll (org-do-wrap words maxword)) + (if (<= (length ll) lines) + ll + (setq ll words) + (while (> (length ll) lines) + (setq w (1+ w)) + (setq ll (org-do-wrap words w))) + ll)) + (t (error "Cannot wrap this"))))) + + +(defun org-do-wrap (words width) + "Create lines of maximum width WIDTH (in characters) from word list WORDS." + (let (lines line) + (while words + (setq line (pop words)) + (while (and words (< (+ (length line) (length (car words))) width)) + (setq line (concat line " " (pop words)))) + (setq lines (push line lines))) + (nreverse lines))) + +(defun org-split-string (string &optional separators) + "Splits STRING into substrings at SEPARATORS. +No empty strings are returned if there are matches at the beginning +and end of string." + (let ((rexp (or separators "[ \f\t\n\r\v]+")) + (start 0) + notfirst + (list nil)) + (while (and (string-match rexp string + (if (and notfirst + (= start (match-beginning 0)) + (< start (length string))) + (1+ start) start)) + (< (match-beginning 0) (length string))) + (setq notfirst t) + (or (eq (match-beginning 0) 0) + (and (eq (match-beginning 0) (match-end 0)) + (eq (match-beginning 0) start)) + (setq list + (cons (substring string start (match-beginning 0)) + list))) + (setq start (match-end 0))) + (or (eq start (length string)) + (setq list + (cons (substring string start) + list))) + (nreverse list))) + +(defun org-table-map-tables (function) + "Apply FUNCTION to the start of all tables in the buffer." + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (while (re-search-forward org-table-any-line-regexp nil t) + (message "Mapping tables: %d%%" (/ (* 100.0 (point)) (buffer-size))) + (beginning-of-line 1) + (if (looking-at org-table-line-regexp) + (save-excursion (funcall function))) + (re-search-forward org-table-any-border-regexp nil 1)))) + (message "Mapping tables: done")) + +(defvar org-timecnt) ; dynamically scoped parameter + +(defun org-table-sum (&optional beg end nlast) + "Sum numbers in region of current table column. +The result will be displayed in the echo area, and will be available +as kill to be inserted with \\[yank]. + +If there is an active region, it is interpreted as a rectangle and all +numbers in that rectangle will be summed. If there is no active +region and point is located in a table column, sum all numbers in that +column. + +If at least one number looks like a time HH:MM or HH:MM:SS, all other +numbers are assumed to be times as well (in decimal hours) and the +numbers are added as such. + +If NLAST is a number, only the NLAST fields will actually be summed." + (interactive) + (save-excursion + (let (col (org-timecnt 0) diff h m s org-table-clip) (cond - ((equal (current-buffer) abuf) nil) - (awin (select-window awin)) - ((not (setq org-pre-agenda-window-conf (current-window-configuration)))) - ((equal org-agenda-window-setup 'current-window) - (switch-to-buffer abuf)) - ((equal org-agenda-window-setup 'other-window) - (switch-to-buffer-other-window abuf)) - ((equal org-agenda-window-setup 'other-frame) - (switch-to-buffer-other-frame abuf)) - ((equal org-agenda-window-setup 'reorganize-frame) - (delete-other-windows) - (switch-to-buffer-other-window abuf)))) - (setq buffer-read-only nil) + ((and beg end)) ; beg and end given explicitly + ((org-region-active-p) + (setq beg (region-beginning) end (region-end))) + (t + (setq col (org-table-current-column)) + (goto-char (org-table-begin)) + (unless (re-search-forward "^[ \t]*|[^-]" nil t) + (error "No table data")) + (org-table-goto-column col) +;not needed? (skip-chars-backward "^|") + (setq beg (point)) + (goto-char (org-table-end)) + (unless (re-search-backward "^[ \t]*|[^-]" nil t) + (error "No table data")) + (org-table-goto-column col) +;not needed? (skip-chars-forward "^|") + (setq end (point)))) + (let* ((items (apply 'append (org-table-copy-region beg end))) + (items1 (cond ((not nlast) items) + ((>= nlast (length items)) items) + (t (setq items (reverse items)) + (setcdr (nthcdr (1- nlast) items) nil) + (nreverse items)))) + (numbers (delq nil (mapcar 'org-table-get-number-for-summing + items1))) + (res (apply '+ numbers)) + (sres (if (= org-timecnt 0) + (format "%g" res) + (setq diff (* 3600 res) + h (floor (/ diff 3600)) diff (mod diff 3600) + m (floor (/ diff 60)) diff (mod diff 60) + s diff) + (format "%d:%02d:%02d" h m s)))) + (kill-new sres) + (if (interactive-p) + (message "%s" + (substitute-command-keys + (format "Sum of %d items: %-20s (\\[yank] will insert result into buffer)" + (length numbers) sres)))) + sres)))) + +(defun org-table-get-number-for-summing (s) + (let (n) + (if (string-match "^ *|? *" s) + (setq s (replace-match "" nil nil s))) + (if (string-match " *|? *$" s) + (setq s (replace-match "" nil nil s))) + (setq n (string-to-number s)) + (cond + ((and (string-match "0" s) + (string-match "\\`[-+ \t0.edED]+\\'" s)) 0) + ((string-match "\\`[ \t]+\\'" s) nil) + ((string-match "\\`\\([0-9]+\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?\\'" s) + (let ((h (string-to-number (or (match-string 1 s) "0"))) + (m (string-to-number (or (match-string 2 s) "0"))) + (s (string-to-number (or (match-string 4 s) "0")))) + (if (boundp 'org-timecnt) (setq org-timecnt (1+ org-timecnt))) + (* 1.0 (+ h (/ m 60.0) (/ s 3600.0))))) + ((equal n 0) nil) + (t n)))) + +(defun org-table-get-vertical-vector (desc &optional tbeg col) + "Get a calc vector from a column, accorting to descriptor DESC. +Optional arguments TBEG and COL can give the beginning of the table and +the current column, to avoid unnecessary parsing." + (save-excursion + (or tbeg (setq tbeg (org-table-begin))) + (or col (setq col (org-table-current-column))) + (let (beg end nn n n1 n2 l (thisline (org-current-line)) hline-list) + (cond + ((string-match "\\(I+\\)\\(-\\(I+\\)\\)?" desc) + (setq n1 (- (match-end 1) (match-beginning 1))) + (if (match-beginning 3) + (setq n2 (- (match-end 2) (match-beginning 3)))) + (setq n (if n2 (max n1 n2) n1)) + (setq n1 (if n2 (min n1 n2))) + (setq nn n) + (while (and (> nn 0) + (re-search-backward org-table-hline-regexp tbeg t)) + (push (org-current-line) hline-list) + (setq nn (1- nn))) + (setq hline-list (nreverse hline-list)) + (goto-line (nth (1- n) hline-list)) + (when (re-search-forward org-table-dataline-regexp) + (org-table-goto-column col) + (setq beg (point))) + (goto-line (if n1 (nth (1- n1) hline-list) thisline)) + (when (re-search-backward org-table-dataline-regexp) + (org-table-goto-column col) + (setq end (point))) + (setq l (apply 'append (org-table-copy-region beg end))) + (concat "[" (mapconcat (lambda (x) (setq x (org-trim x)) + (if (equal x "") "0" x)) + l ",") "]")) + ((string-match "\\([0-9]+\\)-\\([0-9]+\\)" desc) + (setq n1 (string-to-number (match-string 1 desc)) + n2 (string-to-number (match-string 2 desc))) + (beginning-of-line 1) + (save-excursion + (when (re-search-backward org-table-dataline-regexp tbeg t n1) + (org-table-goto-column col) + (setq beg (point)))) + (when (re-search-backward org-table-dataline-regexp tbeg t n2) + (org-table-goto-column col) + (setq end (point))) + (setq l (apply 'append (org-table-copy-region beg end))) + (concat "[" (mapconcat + (lambda (x) (setq x (org-trim x)) + (if (equal x "") "0" x)) + l ",") "]")) + ((string-match "\\([0-9]+\\)" desc) + (beginning-of-line 1) + (when (re-search-backward org-table-dataline-regexp tbeg t + (string-to-number (match-string 0 desc))) + (org-table-goto-column col) + (org-trim (org-table-get-field)))))))) + +(defvar org-table-formula-history nil) + +(defvar org-table-column-names nil + "Alist with column names, derived from the `!' line.") +(defvar org-table-column-name-regexp nil + "Regular expression matching the current column names.") +(defvar org-table-local-parameters nil + "Alist with parameter names, derived from the `$' line.") +(defvar org-table-named-field-locations nil + "Alist with locations of named fields.") + +(defun org-table-get-formula (&optional equation named) + "Read a formula from the minibuffer, offer stored formula as default." + (let* ((name (car (rassoc (list (org-current-line) + (org-table-current-column)) + org-table-named-field-locations))) + (scol (if named + (if name name + (error "Not in a named field")) + (int-to-string (org-table-current-column)))) + (dummy (and name (not named) + (not (y-or-n-p "Replace named-field formula with column equation? " )) + (error "Abort"))) + (org-table-may-need-update nil) + (stored-list (org-table-get-stored-formulas)) + (stored (cdr (assoc scol stored-list))) + (eq (cond + ((and stored equation (string-match "^ *=? *$" equation)) + stored) + ((stringp equation) + equation) + (t (read-string + (format "%s formula $%s=" (if named "Field" "Column") scol) + (or stored "") 'org-table-formula-history + ;stored + )))) + mustsave) + (when (not (string-match "\\S-" eq)) + ;; remove formula + (setq stored-list (delq (assoc scol stored-list) stored-list)) + (org-table-store-formulas stored-list) + (error "Formula removed")) + (if (string-match "^ *=?" eq) (setq eq (replace-match "" t t eq))) + (if (string-match " *$" eq) (setq eq (replace-match "" t t eq))) + (if (and name (not named)) + ;; We set the column equation, delete the named one. + (setq stored-list (delq (assoc name stored-list) stored-list) + mustsave t)) + (if stored + (setcdr (assoc scol stored-list) eq) + (setq stored-list (cons (cons scol eq) stored-list))) + (if (or mustsave (not (equal stored eq))) + (org-table-store-formulas stored-list)) + eq)) + +(defun org-table-store-formulas (alist) + "Store the list of formulas below the current table." + (setq alist (sort alist (lambda (a b) (string< (car a) (car b))))) + (save-excursion + (goto-char (org-table-end)) + (if (looking-at "\\([ \t]*\n\\)*#\\+TBLFM:.*\n?") + (delete-region (point) (match-end 0))) + (insert "#+TBLFM: " + (mapconcat (lambda (x) + (concat "$" (car x) "=" (cdr x))) + alist "::") + "\n"))) + +(defun org-table-get-stored-formulas () + "Return an alist with the stored formulas directly after current table." + (interactive) + (let (scol eq eq-alist strings string seen) + (save-excursion + (goto-char (org-table-end)) + (when (looking-at "\\([ \t]*\n\\)*#\\+TBLFM: *\\(.*\\)") + (setq strings (org-split-string (match-string 2) " *:: *")) + (while (setq string (pop strings)) + (when (string-match "\\$\\([a-zA-Z0-9]+\\) *= *\\(.*[^ \t]\\)" string) + (setq scol (match-string 1 string) + eq (match-string 2 string) + eq-alist (cons (cons scol eq) eq-alist)) + (if (member scol seen) + (error "Double definition `$%s=' in TBLFM line, please fix by hand" scol) + (push scol seen)))))) + (nreverse eq-alist))) + +(defun org-table-modify-formulas (action &rest columns) + "Modify the formulas stored below the current table. +ACTION can be `remove', `insert', `swap'. For `swap', two column numbers are +expected, for the other actions only a single column number is needed." + (let ((list (org-table-get-stored-formulas)) + (nmax (length (org-split-string + (buffer-substring (point-at-bol) (point-at-eol)) + "|"))) + col col1 col2 scol si sc1 sc2) + (cond + ((null list)) ; No action needed if there are no stored formulas + ((eq action 'remove) + (setq col (car columns) + scol (int-to-string col)) + (org-table-replace-in-formulas list scol "INVALID") + (if (assoc scol list) (setq list (delq (assoc scol list) list))) + (loop for i from (1+ col) upto nmax by 1 do + (setq si (int-to-string i)) + (org-table-replace-in-formulas list si (int-to-string (1- i))) + (if (assoc si list) (setcar (assoc si list) + (int-to-string (1- i)))))) + ((eq action 'insert) + (setq col (car columns)) + (loop for i from nmax downto col by 1 do + (setq si (int-to-string i)) + (org-table-replace-in-formulas list si (int-to-string (1+ i))) + (if (assoc si list) (setcar (assoc si list) + (int-to-string (1+ i)))))) + ((eq action 'swap) + (setq col1 (car columns) col2 (nth 1 columns) + sc1 (int-to-string col1) sc2 (int-to-string col2)) + ;; Hopefully, ZqZtZ will never be a name in a table + (org-table-replace-in-formulas list sc1 "ZqZtZ") + (org-table-replace-in-formulas list sc2 sc1) + (org-table-replace-in-formulas list "ZqZtZ" sc2) + (if (assoc sc1 list) (setcar (assoc sc1 list) "ZqZtZ")) + (if (assoc sc2 list) (setcar (assoc sc2 list) sc1)) + (if (assoc "ZqZtZ" list) (setcar (assoc "ZqZtZ" list) sc2))) + (t (error "Invalid action in `org-table-modify-formulas'"))) + (if list (org-table-store-formulas list)))) + +(defun org-table-replace-in-formulas (list s1 s2) + (let (elt re s) + (setq s1 (concat "$" (if (integerp s1) (int-to-string s1) s1)) + s2 (concat "$" (if (integerp s2) (int-to-string s2) s2)) + re (concat (regexp-quote s1) "\\>")) + (while (setq elt (pop list)) + (setq s (cdr elt)) + (while (string-match re s) + (setq s (replace-match s2 t t s))) + (setcdr elt s)))) + +(defun org-table-get-specials () + "Get the column names and local parameters for this table." + (save-excursion + (let ((beg (org-table-begin)) (end (org-table-end)) + names name fields fields1 field cnt c v line col) + (setq org-table-column-names nil + org-table-local-parameters nil + org-table-named-field-locations nil) + (goto-char beg) + (when (re-search-forward "^[ \t]*| *! *\\(|.*\\)" end t) + (setq names (org-split-string (match-string 1) " *| *") + cnt 1) + (while (setq name (pop names)) + (setq cnt (1+ cnt)) + (if (string-match "^[a-zA-Z][a-zA-Z0-9]*$" name) + (push (cons name (int-to-string cnt)) org-table-column-names)))) + (setq org-table-column-names (nreverse org-table-column-names)) + (setq org-table-column-name-regexp + (concat "\\$\\(" (mapconcat 'car org-table-column-names "\\|") "\\)\\>")) + (goto-char beg) + (while (re-search-forward "^[ \t]*| *\\$ *\\(|.*\\)" end t) + (setq fields (org-split-string (match-string 1) " *| *")) + (while (setq field (pop fields)) + (if (string-match "^\\([a-zA-Z][a-zA-Z0-9]*\\|%\\) *= *\\(.*\\)" field) + (push (cons (match-string 1 field) (match-string 2 field)) + org-table-local-parameters)))) + (goto-char beg) + (while (re-search-forward "^[ \t]*| *\\([_^]\\) *\\(|.*\\)" end t) + (setq c (match-string 1) + fields (org-split-string (match-string 2) " *| *")) + (save-excursion + (beginning-of-line (if (equal c "_") 2 0)) + (setq line (org-current-line) col 1) + (and (looking-at "^[ \t]*|[^|]*\\(|.*\\)") + (setq fields1 (org-split-string (match-string 1) " *| *")))) + (while (and fields1 (setq field (pop fields))) + (setq v (pop fields1) col (1+ col)) + (when (and (stringp field) (stringp v) + (string-match "^[a-zA-Z][a-zA-Z0-9]*$" field)) + (push (cons field v) org-table-local-parameters) + (push (list field line col) org-table-named-field-locations))))))) + +(defun org-this-word () + ;; Get the current word + (save-excursion + (let ((beg (progn (skip-chars-backward "^ \t\n") (point))) + (end (progn (skip-chars-forward "^ \t\n") (point)))) + (buffer-substring-no-properties beg end)))) + +(defun org-table-maybe-eval-formula () + "Check if the current field starts with \"=\" or \":=\". +If yes, store the formula and apply it." + ;; We already know we are in a table. Get field will only return a formula + ;; when appropriate. It might return a separator line, but no problem. + (when org-table-formula-evaluate-inline + (let* ((field (org-trim (or (org-table-get-field) ""))) + named eq) + (when (string-match "^:?=\\(.*\\)" field) + (setq named (equal (string-to-char field) ?:) + eq (match-string 1 field)) + (if (fboundp 'calc-eval) + (org-table-eval-formula (if named '(4) nil) eq)))))) + +(defvar org-recalc-commands nil + "List of commands triggering the recalculation of a line. +Will be filled automatically during use.") + +(defvar org-recalc-marks + '((" " . "Unmarked: no special line, no automatic recalculation") + ("#" . "Automatically recalculate this line upon TAB, RET, and C-c C-c in the line") + ("*" . "Recalculate only when entire table is recalculated with `C-u C-c *'") + ("!" . "Column name definition line. Reference in formula as $name.") + ("$" . "Parameter definition line name=value. Reference in formula as $name.") + ("_" . "Names for values in row below this one.") + ("^" . "Names for values in row above this one."))) + +(defun org-table-rotate-recalc-marks (&optional newchar) + "Rotate the recalculation mark in the first column. +If in any row, the first field is not consistent with a mark, +insert a new column for the markers. +When there is an active region, change all the lines in the region, +after prompting for the marking character. +After each change, a message will be displayed indicating the meaning +of the new mark." + (interactive) + (unless (org-at-table-p) (error "Not at a table")) + (let* ((marks (append (mapcar 'car org-recalc-marks) '(" "))) + (beg (org-table-begin)) + (end (org-table-end)) + (l (org-current-line)) + (l1 (if (org-region-active-p) (org-current-line (region-beginning)))) + (l2 (if (org-region-active-p) (org-current-line (region-end)))) + (have-col + (save-excursion + (goto-char beg) + (not (re-search-forward "^[ \t]*|[^-|][^|]*[^#!$*_^| \t][^|]*|" end t)))) + (col (org-table-current-column)) + (forcenew (car (assoc newchar org-recalc-marks))) + epos new) + (when l1 + (message "Change region to what mark? Type # * ! $ or SPC: ") + (setq newchar (char-to-string (read-char-exclusive)) + forcenew (car (assoc newchar org-recalc-marks)))) + (if (and newchar (not forcenew)) + (error "Invalid NEWCHAR `%s' in `org-table-rotate-recalc-marks'" + newchar)) + (if l1 (goto-line l1)) + (save-excursion + (beginning-of-line 1) + (unless (looking-at org-table-dataline-regexp) + (error "Not at a table data line"))) + (unless have-col + (org-table-goto-column 1) + (org-table-insert-column) + (org-table-goto-column (1+ col))) + (setq epos (point-at-eol)) + (save-excursion + (beginning-of-line 1) + (org-table-get-field + 1 (if (looking-at "^[ \t]*| *\\([#!$*^_ ]\\) *|") + (concat " " + (setq new (or forcenew + (cadr (member (match-string 1) marks)))) + " ") + " # "))) + (if (and l1 l2) + (progn + (goto-line l1) + (while (progn (beginning-of-line 2) (not (= (org-current-line) l2))) + (and (looking-at org-table-dataline-regexp) + (org-table-get-field 1 (concat " " new " ")))) + (goto-line l1))) + (if (not (= epos (point-at-eol))) (org-table-align)) + (goto-line l) + (and (interactive-p) (message (cdr (assoc new org-recalc-marks)))))) + +(defun org-table-maybe-recalculate-line () + "Recompute the current line if marked for it, and if we haven't just done it." + (interactive) + (and org-table-allow-automatic-line-recalculation + (not (and (memq last-command org-recalc-commands) + (equal org-last-recalc-line (org-current-line)))) + (save-excursion (beginning-of-line 1) + (looking-at org-table-auto-recalculate-regexp)) + (fboundp 'calc-eval) + (org-table-recalculate) t)) + +(defvar org-table-formula-debug nil + "Non-nil means, debug table formulas. +When nil, simply write \"#ERROR\" in corrupted fields.") + +(defvar modes) +(defsubst org-set-calc-mode (var &optional value) + (if (stringp var) + (setq var (assoc var '(("D" calc-angle-mode deg) + ("R" calc-angle-mode rad) + ("F" calc-prefer-frac t) + ("S" calc-symbolic-mode t))) + value (nth 2 var) var (nth 1 var))) + (if (memq var modes) + (setcar (cdr (memq var modes)) value) + (cons var (cons value modes))) + modes) + +(defun org-table-eval-formula (&optional arg equation + suppress-align suppress-const + suppress-store) + "Replace the table field value at the cursor by the result of a calculation. + +This function makes use of Dave Gillespie's Calc package, in my view the +most exciting program ever written for GNU Emacs. So you need to have Calc +installed in order to use this function. + +In a table, this command replaces the value in the current field with the +result of a formula. It also installs the formula as the \"current\" column +formula, by storing it in a special line below the table. When called +with a `C-u' prefix, the current field must ba a named field, and the +formula is installed as valid in only this specific field. + +When called, the command first prompts for a formula, which is read in +the minibuffer. Previously entered formulas are available through the +history list, and the last used formula is offered as a default. +These stored formulas are adapted correctly when moving, inserting, or +deleting columns with the corresponding commands. + +The formula can be any algebraic expression understood by the Calc package. +For details, see the Org-mode manual. + +This function can also be called from Lisp programs and offers +additional arguments: EQUATION can be the formula to apply. If this +argument is given, the user will not be prompted. SUPPRESS-ALIGN is +used to speed-up recursive calls by by-passing unnecessary aligns. +SUPPRESS-CONST suppresses the interpretation of constants in the +formula, assuming that this has been done already outside the function. +SUPPRESS-STORE means the formula should not be stored, either because +it is already stored, or because it is a modified equation that should +not overwrite the stored one." + (interactive "P") + (require 'calc) + (org-table-check-inside-data-field) + (org-table-get-specials) + (let* (fields + (ndown (if (integerp arg) arg 1)) + (org-table-automatic-realign nil) + (case-fold-search nil) + (down (> ndown 1)) + (formula (if (and equation suppress-store) + equation + (org-table-get-formula equation (equal arg '(4))))) + (n0 (org-table-current-column)) + (modes (copy-sequence org-calc-default-modes)) + n form fmt x ev orig c lispp) + ;; Parse the format string. Since we have a lot of modes, this is + ;; a lot of work. However, I think calc still uses most of the time. + (if (string-match ";" formula) + (let ((tmp (org-split-string formula ";"))) + (setq formula (car tmp) + fmt (concat (cdr (assoc "%" org-table-local-parameters)) + (nth 1 tmp))) + (while (string-match "\\([pnfse]\\)\\(-?[0-9]+\\)" fmt) + (setq c (string-to-char (match-string 1 fmt)) + n (string-to-number (match-string 2 fmt))) + (if (= c ?p) + (setq modes (org-set-calc-mode 'calc-internal-prec n)) + (setq modes (org-set-calc-mode + 'calc-float-format + (list (cdr (assoc c '((?n . float) (?f . fix) + (?s . sci) (?e . eng)))) + n)))) + (setq fmt (replace-match "" t t fmt))) + (while (string-match "[DRFS]" fmt) + (setq modes (org-set-calc-mode (match-string 0 fmt))) + (setq fmt (replace-match "" t t fmt))) + (unless (string-match "\\S-" fmt) + (setq fmt nil)))) + (if (and (not suppress-const) org-table-formula-use-constants) + (setq formula (org-table-formula-substitute-names formula))) + (setq orig (or (get-text-property 1 :orig-formula formula) "?")) + (while (> ndown 0) + (setq fields (org-split-string + (buffer-substring + (point-at-bol) (point-at-eol)) " *| *")) + (if org-table-formula-numbers-only + (setq fields (mapcar + (lambda (x) (number-to-string (string-to-number x))) + fields))) + (setq ndown (1- ndown)) + (setq form (copy-sequence formula) + lispp (equal (substring form 0 2) "'(")) + ;; Insert the references to fields in same row + (while (string-match "\\$\\([0-9]+\\)?" form) + (setq n (if (match-beginning 1) + (string-to-number (match-string 1 form)) + n0) + x (nth (1- n) fields)) + (unless x (error "Invalid field specifier \"%s\"" + (match-string 0 form))) + (if (equal x "") (setq x "0")) + (setq form (replace-match + (if lispp x (concat "(" x ")")) + t t form))) + ;; Insert ranges in current column + (while (string-match "\\&[-I0-9]+" form) + (setq form (replace-match + (save-match-data + (org-table-get-vertical-vector (match-string 0 form) + nil n0)) + t t form))) + (if lispp + (setq ev (eval (eval (read form))) + ev (if (numberp ev) (number-to-string ev) ev)) + (setq ev (calc-eval (cons form modes) + (if org-table-formula-numbers-only 'num)))) + + (when org-table-formula-debug + (with-output-to-temp-buffer "*Help*" + (princ (format "Substitution history of formula +Orig: %s +$xyz-> %s +$1-> %s\n" orig formula form)) + (if (listp ev) + (princ (format " %s^\nError: %s" + (make-string (car ev) ?\-) (nth 1 ev))) + (princ (format "Result: %s\nFormat: %s\nFinal: %s" + ev (or fmt "NONE") + (if fmt (format fmt (string-to-number ev)) ev))))) + (shrink-window-if-larger-than-buffer (get-buffer-window "*Help*")) + (unless (and (interactive-p) (not ndown)) + (unless (let (inhibit-redisplay) + (y-or-n-p "Debugging Formula. Continue to next? ")) + (org-table-align) + (error "Abort")) + (delete-window (get-buffer-window "*Help*")) + (message ""))) + (if (listp ev) (setq fmt nil ev "#ERROR")) + (org-table-justify-field-maybe + (if fmt (format fmt (string-to-number ev)) ev)) + (if (and down (> ndown 0) (looking-at ".*\n[ \t]*|[^-]")) + (call-interactively 'org-return) + (setq ndown 0))) + (and down (org-table-maybe-recalculate-line)) + (or suppress-align (and org-table-may-need-update + (org-table-align))))) + +(defun org-table-recalculate (&optional all noalign) + "Recalculate the current table line by applying all stored formulas. +With prefix arg ALL, do this for all lines in the table." + (interactive "P") + (or (memq this-command org-recalc-commands) + (setq org-recalc-commands (cons this-command org-recalc-commands))) + (unless (org-at-table-p) (error "Not at a table")) + (org-table-get-specials) + (let* ((eqlist (sort (org-table-get-stored-formulas) + (lambda (a b) (string< (car a) (car b))))) + (inhibit-redisplay t) + (line-re org-table-dataline-regexp) + (thisline (org-current-line)) + (thiscol (org-table-current-column)) + beg end entry eqlnum eqlname eql (cnt 0) eq a name) + ;; Insert constants in all formulas + (setq eqlist + (mapcar (lambda (x) + (setcdr x (org-table-formula-substitute-names (cdr x))) + x) + eqlist)) + ;; Split the equation list + (while (setq eq (pop eqlist)) + (if (<= (string-to-char (car eq)) ?9) + (push eq eqlnum) + (push eq eqlname))) + (setq eqlnum (nreverse eqlnum) eqlname (nreverse eqlname)) + (if all + (progn + (setq end (move-marker (make-marker) (1+ (org-table-end)))) + (goto-char (setq beg (org-table-begin))) + (if (re-search-forward org-table-calculate-mark-regexp end t) + ;; This is a table with marked lines, only compute selected lines + (setq line-re org-table-recalculate-regexp) + ;; Move forward to the first non-header line + (if (and (re-search-forward org-table-dataline-regexp end t) + (re-search-forward org-table-hline-regexp end t) + (re-search-forward org-table-dataline-regexp end t)) + (setq beg (match-beginning 0)) + nil))) ;; just leave beg where it is + (setq beg (point-at-bol) + end (move-marker (make-marker) (1+ (point-at-eol))))) + (goto-char beg) + (and all (message "Re-applying formulas to full table...")) + (while (re-search-forward line-re end t) + (unless (string-match "^ *[_^!$] *$" (org-table-get-field 1)) + ;; Unprotected line, recalculate + (and all (message "Re-applying formulas to full table...(line %d)" + (setq cnt (1+ cnt)))) + (setq org-last-recalc-line (org-current-line)) + (setq eql eqlnum) + (while (setq entry (pop eql)) + (goto-line org-last-recalc-line) + (org-table-goto-column (string-to-number (car entry)) nil 'force) + (org-table-eval-formula nil (cdr entry) 'noalign 'nocst 'nostore)))) + (goto-line thisline) + (org-table-goto-column thiscol) + (or noalign (and org-table-may-need-update (org-table-align)) + (and all (message "Re-applying formulas to %d lines...done" cnt))) + ;; Now do the names fields + (while (setq eq (pop eqlname)) + (setq name (car eq) + a (assoc name org-table-named-field-locations)) + (when a + (message "Re-applying formula to named field: %s" name) + (goto-line (nth 1 a)) + (org-table-goto-column (nth 2 a)) + (org-table-eval-formula nil (cdr eq) 'noalign 'nocst 'nostore))) + ;; back to initial position + (goto-line thisline) + (org-table-goto-column thiscol) + (or noalign (and org-table-may-need-update (org-table-align)) + (and all (message "Re-applying formulas...done"))))) + +(defun org-table-formula-substitute-names (f) + "Replace $const with values in string F." + (let ((start 0) a n1 n2 nn1 nn2 s (f1 f)) + ;; First, check for column names + (while (setq start (string-match org-table-column-name-regexp f start)) + (setq start (1+ start)) + (setq a (assoc (match-string 1 f) org-table-column-names)) + (setq f (replace-match (concat "$" (cdr a)) t t f))) + ;; Expand ranges to vectors + (while (string-match "\\$\\([0-9]+\\)\\.\\.\\.?\\$\\([0-9]+\\)" f) + (setq n1 (string-to-number (match-string 1 f)) + n2 (string-to-number (match-string 2 f)) + nn1 (1+ (min n1 n2)) nn2 (max n1 n2) + s (concat "[($" (number-to-string (1- nn1)) ")")) + (loop for i from nn1 upto nn2 do + (setq s (concat s ",($" (int-to-string i) ")"))) + (setq s (concat s "]")) + (if (< n2 n1) (setq s (concat "rev(" s ")"))) + (setq f (replace-match s t t f))) + ;; Parameters and constants + (setq start 0) + (while (setq start (string-match "\\$\\([a-zA-Z][a-zA-Z0-9]*\\)" f start)) + (setq start (1+ start)) + (if (setq a (save-match-data + (org-table-get-constant (match-string 1 f)))) + (setq f (replace-match (concat "(" a ")") t t f)))) + (if org-table-formula-debug + (put-text-property 0 (length f) :orig-formula f1 f)) + f)) + +(defun org-table-get-constant (const) + "Find the value for a parameter or constant in a formula. +Parameters get priority." + (or (cdr (assoc const org-table-local-parameters)) + (cdr (assoc const org-table-formula-constants)) + (and (fboundp 'constants-get) (constants-get const)) + "#UNDEFINED_NAME")) + +(defvar org-edit-formulas-map (make-sparse-keymap)) +(define-key org-edit-formulas-map "\C-c\C-c" 'org-finish-edit-formulas) +(define-key org-edit-formulas-map "\C-c\C-q" 'org-abort-edit-formulas) +(define-key org-edit-formulas-map "\C-c?" 'org-show-variable) + +(defvar org-pos) + +(defun org-table-edit-formulas () + "Edit the formulas of the current table in a separate buffer." + (interactive) + (unless (org-at-table-p) + (error "Not at a table")) + (org-table-get-specials) + (let ((eql (org-table-get-stored-formulas)) + (pos (move-marker (make-marker) (point))) + (wc (current-window-configuration)) + entry loc s) + (switch-to-buffer-other-window "*Edit Formulas*") (erase-buffer) - (org-agenda-mode)) - (setq buffer-read-only nil)) + (fundamental-mode) + (org-set-local 'org-pos pos) + (org-set-local 'org-window-configuration wc) + (use-local-map org-edit-formulas-map) + (setq s "# Edit formulas and finish with `C-c C-c'. +# Use `C-u C-c C-c' to also appy them immediately to the entire table. +# Use `C-c ?' to get information about $name at point. +# To cancel editing, press `C-c C-q'.\n") + (put-text-property 0 (length s) 'face 'font-lock-comment-face s) + (insert s) + (while (setq entry (pop eql)) + (when (setq loc (assoc (car entry) org-table-named-field-locations)) + (setq s (format "# Named formula, referring to column %d in line %d\n" + (nth 2 loc) (nth 1 loc))) + (put-text-property 0 (length s) 'face 'font-lock-comment-face s) + (insert s)) + (setq s (concat "$" (car entry) "=" (cdr entry) "\n")) + (remove-text-properties 0 (length s) '(face nil) s) + (insert s)) + (goto-char (point-min)) + (message "Edit formulas and finish with `C-c C-c'."))) -(defun org-finalize-agenda () - "Finishing touch for the agenda buffer, called just before displaying it." - (unless org-agenda-multi - (org-agenda-align-tags) +(defun org-show-variable () + "Show the location/value of the $ expression at point." + (interactive) + (let (var (pos org-pos) (win (selected-window)) e) (save-excursion - (let ((buffer-read-only)) + (or (looking-at "\\$") (skip-chars-backward "$a-zA-Z0-9")) + (if (looking-at "\\$\\([a-zA-Z0-9]+\\)") + (setq var (match-string 1)) + (error "No variable at point"))) + (cond + ((setq e (assoc var org-table-named-field-locations)) + (switch-to-buffer-other-window (marker-buffer pos)) + (goto-line (nth 1 e)) + (org-table-goto-column (nth 2 e)) + (select-window win) + (message "Named field, column %d of line %d" (nth 2 e) (nth 1 e))) + ((setq e (assoc var org-table-column-names)) + (switch-to-buffer-other-window (marker-buffer pos)) + (goto-char pos) + (goto-char (org-table-begin)) + (if (re-search-forward (concat "^[ \t]*| *! *.*?| *\\(" var "\\) *|") + (org-table-end) t) + (progn + (goto-char (match-beginning 1)) + (message "Named column (column %s)" (cdr e))) + (error "Column name not found")) + (select-window win)) + ((string-match "^[0-9]$" var) + ;; column number + (switch-to-buffer-other-window (marker-buffer pos)) + (goto-char pos) + (goto-char (org-table-begin)) + (recenter 1) + (if (re-search-forward org-table-dataline-regexp + (org-table-end) t) + (progn + (goto-char (match-beginning 0)) + (org-table-goto-column (string-to-number var)) + (message "Column %s" var)) + (error "Column name not found")) + (select-window win)) + ((setq e (assoc var org-table-local-parameters)) + (switch-to-buffer-other-window (marker-buffer pos)) + (goto-char pos) + (goto-char (org-table-begin)) + (if (re-search-forward (concat "^[ \t]*| *\\$ *.*?| *\\(" var "=\\)") nil t) + (progn + (goto-char (match-beginning 1)) + (message "Local parameter.")) + (error "Parameter not found")) + (select-window win)) + (t + (cond + ((setq e (assoc var org-table-formula-constants)) + (message "Constant: $%s=%s in `org-table-formula-constants'." var (cdr e))) + ((setq e (and (fboundp 'constants-get) (constants-get var))) + (message "Constant: $%s=%s, retrieved from `constants.el'." var e)) + (t (error "Undefined name $%s" var))))))) + +(defun org-finish-edit-formulas (&optional arg) + "Parse the buffer for formula definitions and install them. +With prefix ARG, apply the new formulas to the table." + (interactive "P") + (let ((pos org-pos) eql) + (goto-char (point-min)) + (while (re-search-forward "^\\$\\([a-zA-Z0-9]+\\) *= *\\(.*?\\) *$" nil t) + (push (cons (match-string 1) (match-string 2)) eql)) + (set-window-configuration org-window-configuration) + (select-window (get-buffer-window (marker-buffer pos))) + (goto-char pos) + (unless (org-at-table-p) + (error "Lost table position - cannot install formulae")) + (org-table-store-formulas eql) + (move-marker pos nil) + (kill-buffer "*Edit Formulas*") + (if arg + (org-table-recalculate 'all) + (message "New formulas installed - press C-u C-c C-c to apply.")))) + +(defun org-abort-edit-formulas () + "Abort editing formulas, without installing the changes." + (interactive) + (let ((pos org-pos)) + (set-window-configuration org-window-configuration) + (select-window (get-buffer-window (marker-buffer pos))) + (goto-char pos) + (message "Formula editing aborted without installing changes"))) + +;;; The orgtbl minor mode + +;; Define a minor mode which can be used in other modes in order to +;; integrate the org-mode table editor. + +;; This is really a hack, because the org-mode table editor uses several +;; keys which normally belong to the major mode, for example the TAB and +;; RET keys. Here is how it works: The minor mode defines all the keys +;; necessary to operate the table editor, but wraps the commands into a +;; function which tests if the cursor is currently inside a table. If that +;; is the case, the table editor command is executed. However, when any of +;; those keys is used outside a table, the function uses `key-binding' to +;; look up if the key has an associated command in another currently active +;; keymap (minor modes, major mode, global), and executes that command. +;; There might be problems if any of the keys used by the table editor is +;; otherwise used as a prefix key. + +;; Another challenge is that the key binding for TAB can be tab or \C-i, +;; likewise the binding for RET can be return or \C-m. Orgtbl-mode +;; addresses this by checking explicitly for both bindings. + +;; The optimized version (see variable `orgtbl-optimized') takes over +;; all keys which are bound to `self-insert-command' in the *global map*. +;; Some modes bind other commands to simple characters, for example +;; AUCTeX binds the double quote to `Tex-insert-quote'. With orgtbl-mode +;; active, this binding is ignored inside tables and replaced with a +;; modified self-insert. + +(defvar orgtbl-mode nil + "Variable controlling `orgtbl-mode', a minor mode enabling the `org-mode' +table editor in arbitrary modes.") +(make-variable-buffer-local 'orgtbl-mode) + +(defvar orgtbl-mode-map (make-keymap) + "Keymap for `orgtbl-mode'.") + +;;;###autoload +(defun turn-on-orgtbl () + "Unconditionally turn on `orgtbl-mode'." + (orgtbl-mode 1)) + +(defvar org-old-auto-fill-inhibit-regexp nil + "Local variable used by `orgtbl-mode'") + +;;;###autoload +(defun orgtbl-mode (&optional arg) + "The `org-mode' table editor as a minor mode for use in other modes." + (interactive) + (if (org-mode-p) + ;; Exit without error, in case some hook functions calls this + ;; by accident in org-mode. + (message "Orgtbl-mode is not useful in org-mode, command ignored") + (setq orgtbl-mode + (if arg (> (prefix-numeric-value arg) 0) (not orgtbl-mode))) + (if orgtbl-mode + (progn + (and (orgtbl-setup) (defun orgtbl-setup () nil)) + ;; Make sure we are first in minor-mode-map-alist + (let ((c (assq 'orgtbl-mode minor-mode-map-alist))) + (and c (setq minor-mode-map-alist + (cons c (delq c minor-mode-map-alist))))) + (org-set-local (quote org-table-may-need-update) t) + (org-add-hook 'before-change-functions 'org-before-change-function + nil 'local) + (org-set-local 'org-old-auto-fill-inhibit-regexp + auto-fill-inhibit-regexp) + (org-set-local 'auto-fill-inhibit-regexp + (if auto-fill-inhibit-regexp + (concat "\\([ \t]*|\\|" auto-fill-inhibit-regexp) + "[ \t]*|")) + (org-add-to-invisibility-spec '(org-cwidth)) + (easy-menu-add orgtbl-mode-menu) + (run-hooks 'orgtbl-mode-hook)) + (setq auto-fill-inhibit-regexp org-old-auto-fill-inhibit-regexp) + (org-cleanup-narrow-column-properties) + (org-remove-from-invisibility-spec '(org-cwidth)) + (remove-hook 'before-change-functions 'org-before-change-function t) + (easy-menu-remove orgtbl-mode-menu) + (force-mode-line-update 'all)))) + +(defun org-cleanup-narrow-column-properties () + "Remove all properties related to narrow-column invisibility." + (let ((s 1)) + (while (setq s (text-property-any s (point-max) + 'display org-narrow-column-arrow)) + (remove-text-properties s (1+ s) '(display t))) + (setq s 1) + (while (setq s (text-property-any s (point-max) 'org-cwidth 1)) + (remove-text-properties s (1+ s) '(org-cwidth t))) + (setq s 1) + (while (setq s (text-property-any s (point-max) 'invisible 'org-cwidth)) + (remove-text-properties s (1+ s) '(invisible t))))) + +;; Install it as a minor mode. +(put 'orgtbl-mode :included t) +(put 'orgtbl-mode :menu-tag "Org Table Mode") +(add-minor-mode 'orgtbl-mode " OrgTbl" orgtbl-mode-map) + +(defun orgtbl-make-binding (fun n &rest keys) + "Create a function for binding in the table minor mode. +FUN is the command to call inside a table. N is used to create a unique +command name. KEYS are keys that should be checked in for a command +to execute outside of tables." + (eval + (list 'defun + (intern (concat "orgtbl-hijacker-command-" (int-to-string n))) + '(arg) + (concat "In tables, run `" (symbol-name fun) "'.\n" + "Outside of tables, run the binding of `" + (mapconcat (lambda (x) (format "%s" x)) keys "' or `") + "'.") + '(interactive "p") + (list 'if + '(org-at-table-p) + (list 'call-interactively (list 'quote fun)) + (list 'let '(orgtbl-mode) + (list 'call-interactively + (append '(or) + (mapcar (lambda (k) + (list 'key-binding k)) + keys) + '('orgtbl-error)))))))) + +(defun orgtbl-error () + "Error when there is no default binding for a table key." + (interactive) + (error "This key is has no function outside tables")) + +(defun orgtbl-setup () + "Setup orgtbl keymaps." + (let ((nfunc 0) + (bindings + (list + '([(meta shift left)] org-table-delete-column) + '([(meta left)] org-table-move-column-left) + '([(meta right)] org-table-move-column-right) + '([(meta shift right)] org-table-insert-column) + '([(meta shift up)] org-table-kill-row) + '([(meta shift down)] org-table-insert-row) + '([(meta up)] org-table-move-row-up) + '([(meta down)] org-table-move-row-down) + '("\C-c\C-w" org-table-cut-region) + '("\C-c\M-w" org-table-copy-region) + '("\C-c\C-y" org-table-paste-rectangle) + '("\C-c-" org-table-insert-hline) +; '([(shift tab)] org-table-previous-field) + '("\C-m" org-table-next-row) + (list (org-key 'S-return) 'org-table-copy-down) + '([(meta return)] org-table-wrap-region) + '("\C-c\C-q" org-table-wrap-region) + '("\C-c?" org-table-current-column) + '("\C-c " org-table-blank-field) + '("\C-c+" org-table-sum) + '("\C-c=" org-table-eval-formula) + '("\C-c'" org-table-edit-formulas) + '("\C-c`" org-table-edit-field) + '("\C-c*" org-table-recalculate) + '("\C-c|" org-table-create-or-convert-from-region) + '("\C-c^" org-table-sort-lines) + '([(control ?#)] org-table-rotate-recalc-marks))) + elt key fun cmd) + (while (setq elt (pop bindings)) + (setq nfunc (1+ nfunc)) + (setq key (car elt) + fun (nth 1 elt) + cmd (orgtbl-make-binding fun nfunc key)) + (define-key orgtbl-mode-map key cmd)) + ;; Special treatment needed for TAB and RET + (define-key orgtbl-mode-map [(return)] + (orgtbl-make-binding 'orgtbl-ret 100 [(return)] "\C-m")) + (define-key orgtbl-mode-map "\C-m" + (orgtbl-make-binding 'orgtbl-ret 101 "\C-m" [(return)])) + (define-key orgtbl-mode-map [(tab)] + (orgtbl-make-binding 'orgtbl-tab 102 [(tab)] "\C-i")) + (define-key orgtbl-mode-map "\C-i" + (orgtbl-make-binding 'orgtbl-tab 103 "\C-i" [(tab)]))) + (define-key orgtbl-mode-map "\C-i" + (orgtbl-make-binding 'orgtbl-tab 104 [(shift tab)])) + (define-key orgtbl-mode-map "\C-c\C-c" + (orgtbl-make-binding 'org-ctrl-c-ctrl-c 105 "\C-c\C-c")) + (when orgtbl-optimized + ;; If the user wants maximum table support, we need to hijack + ;; some standard editing functions + (org-remap orgtbl-mode-map + 'self-insert-command 'orgtbl-self-insert-command + 'delete-char 'org-delete-char + 'delete-backward-char 'org-delete-backward-char) + (define-key orgtbl-mode-map "|" 'org-force-self-insert)) + (easy-menu-define orgtbl-mode-menu orgtbl-mode-map "OrgTbl menu" + '("OrgTbl" + ["Align" org-ctrl-c-ctrl-c :active (org-at-table-p) :keys "C-c C-c"] + ["Next Field" org-cycle :active (org-at-table-p) :keys "TAB"] + ["Previous Field" org-shifttab :active (org-at-table-p) :keys "S-TAB"] + ["Next Row" org-return :active (org-at-table-p) :keys "RET"] + "--" + ["Blank Field" org-table-blank-field :active (org-at-table-p) :keys "C-c SPC"] + ["Edit Field" org-table-edit-field :active (org-at-table-p) :keys "C-c ` "] + ["Copy Field from Above" + org-table-copy-down :active (org-at-table-p) :keys "S-RET"] + "--" + ("Column" + ["Move Column Left" org-metaleft :active (org-at-table-p) :keys "M-<left>"] + ["Move Column Right" org-metaright :active (org-at-table-p) :keys "M-<right>"] + ["Delete Column" org-shiftmetaleft :active (org-at-table-p) :keys "M-S-<left>"] + ["Insert Column" org-shiftmetaright :active (org-at-table-p) :keys "M-S-<right>"] + "--" + ["Enable Narrowing" (setq org-table-limit-column-width (not org-table-limit-column-width)) :active (org-at-table-p) :selected org-table-limit-column-width :style toggle]) + ("Row" + ["Move Row Up" org-metaup :active (org-at-table-p) :keys "M-<up>"] + ["Move Row Down" org-metadown :active (org-at-table-p) :keys "M-<down>"] + ["Delete Row" org-shiftmetaup :active (org-at-table-p) :keys "M-S-<up>"] + ["Insert Row" org-shiftmetadown :active (org-at-table-p) :keys "M-S-<down>"] + ["Sort lines in region" org-table-sort-lines (org-at-table-p) :keys "C-c ^"] + "--" + ["Insert Hline" org-table-insert-hline :active (org-at-table-p) :keys "C-c -"]) + ("Rectangle" + ["Copy Rectangle" org-copy-special :active (org-at-table-p)] + ["Cut Rectangle" org-cut-special :active (org-at-table-p)] + ["Paste Rectangle" org-paste-special :active (org-at-table-p)] + ["Fill Rectangle" org-table-wrap-region :active (org-at-table-p)]) + "--" + ["Set Column Formula" org-table-eval-formula :active (org-at-table-p) :keys "C-c ="] + ["Set Named Field Formula" (org-table-eval-formula '(4)) :active (org-at-table-p) :keys "C-u C-c ="] + ["Edit Formulas" org-table-edit-formulas :active (org-at-table-p) :keys "C-c '"] + ["Recalculate line" org-table-recalculate :active (org-at-table-p) :keys "C-c *"] + ["Recalculate all" (org-table-recalculate '(4)) :active (org-at-table-p) :keys "C-u C-c *"] + ["Toggle Recalculate Mark" org-table-rotate-recalc-marks :active (org-at-table-p) :keys "C-c #"] + ["Sum Column/Rectangle" org-table-sum + :active (or (org-at-table-p) (org-region-active-p)) :keys "C-c +"] + ["Which Column?" org-table-current-column :active (org-at-table-p) :keys "C-c ?"] + ["Debug Formulas" + (setq org-table-formula-debug (not org-table-formula-debug)) + :style toggle :selected org-table-formula-debug] + )) + t) + +(defun orgtbl-tab (arg) + "Justification and field motion for `orgtbl-mode'." + (interactive "P") + (if arg (org-table-edit-field t) + (org-table-justify-field-maybe) + (org-table-next-field))) + +(defun orgtbl-ret () + "Justification and field motion for `orgtbl-mode'." + (interactive) + (org-table-justify-field-maybe) + (org-table-next-row)) + +(defun orgtbl-self-insert-command (N) + "Like `self-insert-command', use overwrite-mode for whitespace in tables. +If the cursor is in a table looking at whitespace, the whitespace is +overwritten, and the table is not marked as requiring realignment." + (interactive "p") + (if (and (org-at-table-p) + (or + (and org-table-auto-blank-field + (member last-command + '(orgtbl-hijacker-command-100 + orgtbl-hijacker-command-101 + orgtbl-hijacker-command-102 + orgtbl-hijacker-command-103 + orgtbl-hijacker-command-104 + orgtbl-hijacker-command-105)) + (org-table-blank-field)) + t) + (eq N 1) + (looking-at "[^|\n]* +|")) + (let (org-table-may-need-update) + (goto-char (1- (match-end 0))) + (delete-backward-char 1) + (goto-char (match-beginning 0)) + (self-insert-command N)) + (setq org-table-may-need-update t) + (let (orgtbl-mode) + (call-interactively (key-binding (vector last-input-event)))))) + +(defun org-force-self-insert (N) + "Needed to enforce self-insert under remapping." + (interactive "p") + (self-insert-command N)) + +;;;; Link Stuff + +;;; Link abbreviations + +(defun org-link-expand-abbrev (link) + "Apply replacements as defined in `org-link-abbrev-alist." + (if (string-match "^\\([a-zA-Z]+\\)\\(::\\(.*\\)\\)?$" link) + (let* ((key (match-string 1 link)) + (as (or (assoc key org-link-abbrev-alist-local) + (assoc key org-link-abbrev-alist))) + (tag (and (match-end 2) (match-string 3 link))) + rpl) + (if (not as) + link + (setq rpl (cdr as)) + (cond + ((symbolp rpl) (funcall rpl tag)) + ((string-match "%s" rpl) (replace-match (or tag "") t t rpl)) + (t (concat rpl tag))))) + link)) + +;;; Storing and inserting links + +(defvar org-insert-link-history nil + "Minibuffer history for links inserted with `org-insert-link'.") + +(defvar org-stored-links nil + "Contains the links stored with `org-store-link'.") + +;;;###autoload +(defun org-store-link (arg) + "\\<org-mode-map>Store an org-link to the current location. +This link can later be inserted into an org-buffer with +\\[org-insert-link]. +For some link types, a prefix arg is interpreted: +For links to usenet articles, arg negates `org-usenet-links-prefer-google'. +For file links, arg negates `org-context-in-file-links'." + (interactive "P") + (let (link cpltxt desc description search txt (pos (point))) + (cond + + ((eq major-mode 'bbdb-mode) + (setq cpltxt (concat + "bbdb:" + (or (bbdb-record-name (bbdb-current-record)) + (bbdb-record-company (bbdb-current-record)))) + link (org-make-link cpltxt))) + + ((eq major-mode 'Info-mode) + (setq link (org-make-link "info:" + (file-name-nondirectory Info-current-file) + ":" Info-current-node)) + (setq cpltxt (concat (file-name-nondirectory Info-current-file) + ":" Info-current-node))) + + ((eq major-mode 'calendar-mode) + (let ((cd (calendar-cursor-to-date))) + (setq link + (format-time-string + (car org-time-stamp-formats) + (apply 'encode-time + (list 0 0 0 (nth 1 cd) (nth 0 cd) (nth 2 cd) + nil nil nil)))))) + + ((or (eq major-mode 'vm-summary-mode) + (eq major-mode 'vm-presentation-mode)) + (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)) + (folder buffer-file-name) + (subject (vm-su-subject message)) + (author (vm-su-full-name message)) + (message-id (vm-su-message-id message))) + (setq message-id (org-remove-angle-brackets message-id)) + (setq folder (abbreviate-file-name folder)) + (if (string-match (concat "^" (regexp-quote vm-folder-directory)) + folder) + (setq folder (replace-match "" t t folder))) + (setq cpltxt (concat author " on: " subject)) + (setq link (org-make-link "vm:" folder "#" message-id))))) + + ((eq major-mode 'wl-summary-mode) + (let* ((msgnum (wl-summary-message-number)) + (message-id (elmo-message-field wl-summary-buffer-elmo-folder + msgnum 'message-id)) + (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)))) + (author (wl-summary-line-from)) ; FIXME: correct? + (subject "???")) ; FIXME: + (setq message-id (org-remove-angle-brackets message-id)) + (setq cpltxt (concat author " on: " subject)) + (setq link (org-make-link "wl:" wl-summary-buffer-folder-name + "#" message-id)))) + + ((or (equal major-mode 'mh-folder-mode) + (equal major-mode 'mh-show-mode)) + (let ((from-header (org-mhe-get-header "From:")) + (to-header (org-mhe-get-header "To:")) + (subject (org-mhe-get-header "Subject:"))) + (setq cpltxt (concat from-header " on: " subject)) + (setq link (org-make-link "mhe:" (org-mhe-get-message-real-folder) "#" + (org-remove-angle-brackets + (org-mhe-get-header "Message-Id:")))))) + + ((eq major-mode 'rmail-mode) + (save-excursion + (save-restriction + (rmail-narrow-to-non-pruned-header) + (let ((folder buffer-file-name) + (message-id (mail-fetch-field "message-id")) + (author (mail-fetch-field "from")) + (subject (mail-fetch-field "subject"))) + (setq message-id (org-remove-angle-brackets message-id)) + (setq cpltxt (concat author " on: " subject)) + (setq link (org-make-link "rmail:" folder "#" message-id)))))) + + ((eq major-mode 'gnus-group-mode) + (let ((group (cond ((fboundp 'gnus-group-group-name) ; depending on Gnus + (gnus-group-group-name)) ; version + ((fboundp 'gnus-group-name) + (gnus-group-name)) + (t "???")))) + (setq cpltxt (concat + (if (org-xor arg org-usenet-links-prefer-google) + "http://groups.google.com/groups?group=" + "gnus:") + group) + link (org-make-link cpltxt)))) + + ((memq major-mode '(gnus-summary-mode gnus-article-mode)) + (require 'gnus-sum) ; FIXME: I don't think this is needed, actually + (and (eq major-mode 'gnus-article-mode) (gnus-article-show-summary)) + (gnus-summary-beginning-of-article) + (let* ((group (car gnus-article-current)) + (article (cdr gnus-article-current)) + (header (gnus-summary-article-header article)) + (author (mail-header-from header)) + (message-id (mail-header-id header)) + (date (mail-header-date header)) + (subject (gnus-summary-subject-string))) + (setq cpltxt (concat author " on: " subject)) + (if (org-xor arg org-usenet-links-prefer-google) + (setq link + (concat + cpltxt "\n " + (format "http://groups.google.com/groups?as_umsgid=%s" + (org-fixup-message-id-for-http message-id)))) + (setq link (org-make-link "gnus:" group + "#" (number-to-string article)))))) + + ((eq major-mode 'w3-mode) + (setq cpltxt (url-view-url t) + link (org-make-link cpltxt))) + ((eq major-mode 'w3m-mode) + (setq cpltxt (or w3m-current-title w3m-current-url) + link (org-make-link w3m-current-url))) + + ((setq search (run-hook-with-args-until-success + 'org-create-file-search-functions)) + (setq link (concat "file:" (abbreviate-file-name buffer-file-name) + "::" search)) + (setq cpltxt (or description link))) + + ((eq major-mode 'image-mode) + (setq cpltxt (concat "file:" + (abbreviate-file-name buffer-file-name)) + link (org-make-link cpltxt))) + + ((eq major-mode 'dired-mode) + ;; link to the file in the current line + (setq cpltxt (concat "file:" + (abbreviate-file-name + (expand-file-name + (dired-get-filename nil t)))) + link (org-make-link cpltxt))) + + ((and buffer-file-name (org-mode-p)) + ;; Just link to current headline + (setq cpltxt (concat "file:" + (abbreviate-file-name buffer-file-name))) + ;; Add a context search string + (when (org-xor org-context-in-file-links arg) + ;; Check if we are on a target + (if (save-excursion + (skip-chars-forward "^>\n\r") + (and (re-search-backward "<<" nil t) + (looking-at "<<\\(.*?\\)>>") + (<= (match-beginning 0) pos) + (>= (match-end 0) pos))) + (setq cpltxt (concat cpltxt "::" (match-string 1))) + (setq txt (cond + ((org-on-heading-p) nil) + ((org-region-active-p) + (buffer-substring (region-beginning) (region-end))) + (t (buffer-substring (point-at-bol) (point-at-eol))))) + (when (or (null txt) (string-match "\\S-" txt)) + (setq cpltxt + (concat cpltxt "::" + (if org-file-link-context-use-camel-case + (org-make-org-heading-camel txt) + (org-make-org-heading-search-string txt))) + desc "NONE")))) + (if (string-match "::\\'" cpltxt) + (setq cpltxt (substring cpltxt 0 -2))) + (setq link (org-make-link cpltxt))) + + (buffer-file-name + ;; Just link to this file here. + (setq cpltxt (concat "file:" + (abbreviate-file-name buffer-file-name))) + ;; Add a context string + (when (org-xor org-context-in-file-links arg) + (setq txt (if (org-region-active-p) + (buffer-substring (region-beginning) (region-end)) + (buffer-substring (point-at-bol) (point-at-eol)))) + ;; Only use search option if there is some text. + (when (string-match "\\S-" txt) + (setq cpltxt + (concat cpltxt "::" + (if org-file-link-context-use-camel-case + (org-make-org-heading-camel txt) + (org-make-org-heading-search-string txt))) + desc "NONE"))) + (setq link (org-make-link cpltxt))) + + ((interactive-p) + (error "Cannot link to a buffer which is not visiting a file")) + + (t (setq link nil))) + + (if (consp link) (setq cpltxt (car link) link (cdr link))) + (setq link (or link cpltxt) + desc (or desc cpltxt)) + (if (equal desc "NONE") (setq desc nil)) + + (if (and (interactive-p) link) + (progn + (setq org-stored-links + (cons (list cpltxt link desc) org-stored-links)) + (message "Stored: %s" (or cpltxt link))) + (org-make-link-string link desc)))) + +(defun org-make-org-heading-search-string (&optional string heading) + "Make search string for STRING or current headline." + (interactive) + (let ((s (or string (org-get-heading)))) + (unless (and string (not heading)) + ;; We are using a headline, clean up garbage in there. + (if (string-match org-todo-regexp s) + (setq s (replace-match "" t t s))) + (if (string-match ":[a-zA-Z_@0-9:]+:[ \t]*$" s) + (setq s (replace-match "" t t s))) + (setq s (org-trim s)) + (if (string-match (concat "^\\(" org-quote-string "\\|" + org-comment-string "\\)") s) + (setq s (replace-match "" t t s))) + (while (string-match org-ts-regexp s) + (setq s (replace-match "" t t s)))) + (while (string-match "[^a-zA-Z_0-9 \t]+" s) + (setq s (replace-match " " t t s))) + (or string (setq s (concat "*" s))) ; Add * for headlines + (mapconcat 'identity (org-split-string s "[ \t]+") " "))) + +(defun org-make-org-heading-camel (&optional string heading) + "Make a CamelCase string for STRING or the current headline." + (interactive) + (let ((s (or string (org-get-heading)))) + (unless (and string (not heading)) + ;; We are using a headline, clean up garbage in there. + (if (string-match org-todo-regexp s) + (setq s (replace-match "" t t s))) + (if (string-match ":[a-zA-Z_@0-9:]+:[ \t]*$" s) + (setq s (replace-match "" t t s))) + (setq s (org-trim s)) + (if (string-match (concat "^\\(" org-quote-string "\\|" + org-comment-string "\\)") s) + (setq s (replace-match "" t t s))) + (while (string-match org-ts-regexp s) + (setq s (replace-match "" t t s)))) + (while (string-match "[^a-zA-Z_ \t]+" s) + (setq s (replace-match " " t t s))) + (or string (setq s (concat "*" s))) ; Add * for headlines + (mapconcat 'capitalize (org-split-string s "[ \t]+") ""))) + +(defun org-make-link (&rest strings) + "Concatenate STRINGS, format resulting string with `org-link-format'." + (format org-link-format (apply 'concat strings))) + +(defun org-make-link-string (link &optional description) + "Make a link with brackets, consisting of LINK and DESCRIPTION." + (if (eq org-link-style 'plain) + (if (equal description link) + link + (concat description "\n" link)) + (when (stringp description) + ;; Remove brackets from the description, they are fatal. + (while (string-match "\\[\\|\\]" description) + (setq description (replace-match "" t t description)))) + (when (equal (org-link-escape link) description) + ;; No description needed, it is identical + (setq description nil)) + (when (and (not description) + (not (equal link (org-link-escape link)))) + (setq description link)) + (concat "[[" (org-link-escape link) "]" + (if description (concat "[" description "]") "") + "]"))) + +(defconst org-link-escape-chars '(("[" . "%5B") ("]" . "%5D") (" " . "%20")) + "Association list of escapes for some characters problematic in links.") + +(defun org-link-escape (text) + "Escape charaters in TEXT that are problematic for links." + (when text + (let ((re (mapconcat (lambda (x) (regexp-quote (car x))) + org-link-escape-chars "\\|"))) + (while (string-match re text) + (setq text + (replace-match + (cdr (assoc (match-string 0 text) org-link-escape-chars)) + t t text))) + text))) + +(defun org-link-unescape (text) + "Reverse the action of `org-link-escape'." + (when text + (let ((re (mapconcat (lambda (x) (regexp-quote (cdr x))) + org-link-escape-chars "\\|"))) + (while (string-match re text) + (setq text + (replace-match + (car (rassoc (match-string 0 text) org-link-escape-chars)) + t t text))) + text))) + +(defun org-xor (a b) + "Exclusive or." + (if a (not b) b)) + +(defun org-get-header (header) + "Find a header field in the current buffer." + (save-excursion + (goto-char (point-min)) + (let ((case-fold-search t) s) + (cond + ((eq header 'from) + (if (re-search-forward "^From:\\s-+\\(.*\\)" nil t) + (setq s (match-string 1))) + (while (string-match "\"" s) + (setq s (replace-match "" t t s))) + (if (string-match "[<(].*" s) + (setq s (replace-match "" t t s)))) + ((eq header 'message-id) + (if (re-search-forward "^message-id:\\s-+\\(.*\\)" nil t) + (setq s (match-string 1)))) + ((eq header 'subject) + (if (re-search-forward "^subject:\\s-+\\(.*\\)" nil t) + (setq s (match-string 1))))) + (if (string-match "\\`[ \t\]+" s) (setq s (replace-match "" t t s))) + (if (string-match "[ \t\]+\\'" s) (setq s (replace-match "" t t s))) + s))) + + +(defun org-fixup-message-id-for-http (s) + "Replace special characters in a message id, so it can be used in an http query." + (while (string-match "<" s) + (setq s (replace-match "%3C" t t s))) + (while (string-match ">" s) + (setq s (replace-match "%3E" t t s))) + (while (string-match "@" s) + (setq s (replace-match "%40" t t s))) + s) + +(defun org-insert-link (&optional complete-file) + "Insert a link. At the prompt, enter the link. + +Completion can be used to select a link previously stored with +`org-store-link'. When the empty string is entered (i.e. if you just +press RET at the prompt), the link defaults to the most recently +stored link. As SPC triggers completion in the minibuffer, you need to +use M-SPC or C-q SPC to force the insertion of a space character. + +You will also be prompted for a description, and if one is given, it will +be displayed in the buffer instead of the link. + +If there is already a link at point, this command will allow you to edit link +and description parts. + +With a \\[universal-argument] prefix, prompts for a file to link to. The file name can be +selected using completion. The path to the file will be relative to +the current directory if the file is in the current directory or a +subdirectory. Otherwise, the link will be the absolute path as +completed in the minibuffer (i.e. normally ~/path/to/file). + +With two \\[universal-argument] prefixes, enforce an absolute path even if the file +is in the current directory or below. +With three \\[universal-argument] prefixes, negate the meaning of +`org-keep-stored-link-after-insertion'." + (interactive "P") + (let (link desc entry remove file (pos (point))) + (cond + ((save-excursion + (skip-chars-forward "^]\n\r") + (and (re-search-backward "\\[\\[" nil t) + (looking-at org-bracket-link-regexp) + (<= (match-beginning 0) pos) + (>= (match-end 0) pos))) + ;; We do have a link at point, and we are going to edit it. + (setq remove (list (match-beginning 0) (match-end 0))) + (setq desc (if (match-end 3) (org-match-string-no-properties 3))) + (setq link (read-string "Link: " + (org-link-unescape + (org-match-string-no-properties 1))))) + ((equal complete-file '(4)) + ;; Completing read for file names. + (setq file (read-file-name "File: ")) + (let ((pwd (file-name-as-directory (expand-file-name "."))) + (pwd1 (file-name-as-directory (abbreviate-file-name + (expand-file-name "."))))) + (cond + ((equal complete-file '(16)) + (setq link (org-make-link + "file:" + (abbreviate-file-name (expand-file-name file))))) + ((string-match (concat "^" (regexp-quote pwd1) "\\(.+\\)") file) + (setq link (org-make-link "file:" (match-string 1 file)))) + ((string-match (concat "^" (regexp-quote pwd) "\\(.+\\)") + (expand-file-name file)) + (setq link (org-make-link + "file:" (match-string 1 (expand-file-name file))))) + (t (setq link (org-make-link "file:" file)))))) + (t + ;; Read link, with completion for stored links. + (setq link (org-completing-read + "Link: " org-stored-links nil nil nil + org-insert-link-history + (or (car (car org-stored-links))))) + (setq entry (assoc link org-stored-links)) + (if (funcall (if (equal complete-file '(64)) 'not 'identity) + (not org-keep-stored-link-after-insertion)) + (setq org-stored-links (delq (assoc link org-stored-links) + org-stored-links))) + (setq link (if entry (nth 1 entry) link) + desc (or desc (nth 2 entry))))) + + (if (string-match org-plain-link-re link) + ;; URL-like link, normalize the use of angular brackets. + (setq link (org-make-link (org-remove-angle-brackets link)))) + + ;; Check if we are linking to the current file with a search option + ;; If yes, simplify the link by using only the search option. + (when (and buffer-file-name + (string-match "\\<file:\\(.+?\\)::\\([^>]+\\)" link)) + (let* ((path (match-string 1 link)) + (case-fold-search nil) + (search (match-string 2 link))) + (save-match-data + (if (equal (file-truename buffer-file-name) (file-truename path)) + ;; We are linking to this same file, with a search option + (setq link search))))) + + ;; Check if we can/should use a relative path. If yes, simplify the link + (when (string-match "\\<file:\\(.*\\)" link) + (let* ((path (match-string 1 link)) + (case-fold-search nil)) + (cond + ((eq org-link-file-path-type 'absolute) + (setq path (abbreviate-file-name (expand-file-name path)))) + ((eq org-link-file-path-type 'noabbrev) + (setq path (expand-file-name path))) + ((eq org-link-file-path-type 'relative) + (setq path (file-relative-name path))) + (t + (save-match-data + (if (string-match (concat "^" (regexp-quote + (file-name-as-directory + (expand-file-name ".")))) + (expand-file-name path)) + ;; We are linking a file with relative path name. + (setq path (substring (expand-file-name path) + (match-end 0))))))) + (setq link (concat "file:" path)))) + + (setq desc (read-string "Description: " desc)) + (unless (string-match "\\S-" desc) (setq desc nil)) + (if remove (apply 'delete-region remove)) + (insert (org-make-link-string link desc)))) + +(defun org-completing-read (&rest args) + (let ((minibuffer-local-completion-map + (copy-keymap minibuffer-local-completion-map))) + (define-key minibuffer-local-completion-map " " 'self-insert-command) + (apply 'completing-read args))) + +;;; Opening/following a link + +(defun org-find-file-at-mouse (ev) + "Open file link or URL at mouse." + (interactive "e") + (mouse-set-point ev) + (org-open-at-point 'in-emacs)) + +(defun org-open-at-mouse (ev) + "Open file link or URL at mouse." + (interactive "e") + (mouse-set-point ev) + (org-open-at-point)) + +(defvar org-window-config-before-follow-link nil + "The window configuration before following a link. +This is saved in case the need arises to restore it.") + +;; FIXME: IN-EMACS is used for many purposes, maybe rename this argument??? +(defun org-open-at-point (&optional in-emacs) + "Open link at or after point. +If there is no link at point, this function will search forward up to +the end of the current subtree. +Normally, files will be opened by an appropriate application. If the +optional argument IN-EMACS is non-nil, Emacs will visit the file." + (interactive "P") + (setq org-window-config-before-follow-link (current-window-configuration)) + (org-remove-occur-highlights nil nil t) + (if (org-at-timestamp-p t) + (org-follow-timestamp-link) + (let (type path link line search (pos (point))) + (catch 'match + (save-excursion + (skip-chars-forward "^]\n\r") + (when (and (re-search-backward "\\[\\[" nil t) + (looking-at org-bracket-link-regexp) + (<= (match-beginning 0) pos) + (>= (match-end 0) pos)) + (setq link (org-link-unescape (org-match-string-no-properties 1))) + (while (string-match " *\n *" link) + (setq link (replace-match " " t t link))) + (setq link (org-link-expand-abbrev link)) + (if (string-match org-link-re-with-space2 link) + (setq type (match-string 1 link) + path (match-string 2 link)) + (setq type "thisfile" + path link)) + (throw 'match t))) + + (when (get-text-property (point) 'org-linked-text) + (setq type "thisfile" + pos (if (get-text-property (1+ (point)) 'org-linked-text) + (1+ (point)) (point)) + path (buffer-substring + (previous-single-property-change pos 'org-linked-text) + (next-single-property-change pos 'org-linked-text))) + (throw 'match t)) + + (save-excursion + (skip-chars-backward (concat "^[]" org-non-link-chars " ")) + (if (equal (char-before) ?<) (backward-char 1)) + (when (or (looking-at org-angle-link-re) + (looking-at org-plain-link-re) + (and (or (re-search-forward org-angle-link-re (point-at-eol) t) + (re-search-forward org-plain-link-re (point-at-eol) t)) + (<= (match-beginning 0) pos) + (>= (match-end 0) pos))) + (setq type (match-string 1) + path (match-string 2)) + (throw 'match t))) + (save-excursion + (skip-chars-backward "^ \t\n\r") + (when (looking-at "\\(:[A-Za-z_@0-9:]+\\):[ \t\r\n]") + (setq type "tags" + path (match-string 1)) + (while (string-match ":" path) + (setq path (replace-match "+" t t path))) + (throw 'match t))) + (save-excursion + (skip-chars-backward "a-zA-Z_") + (when (and (memq 'camel org-activate-links) + (looking-at org-camel-regexp)) + (setq type "camel" path (match-string 0)) + (if (equal (char-before) ?*) + (setq path (concat "*" path)))) + (throw 'match t))) + (unless path + (error "No link found")) + ;; Remove any trailing spaces in path + (if (string-match " +\\'" path) + (setq path (replace-match "" t t path))) + + (cond + + ((equal type "mailto") + (let ((cmd (car org-link-mailto-program)) + (args (cdr org-link-mailto-program)) args1 + (address path) (subject "") a) + (if (string-match "\\(.*\\)::\\(.*\\)" path) + (setq address (match-string 1 path) + subject (org-link-escape (match-string 2 path)))) + (while args + (cond + ((not (stringp (car args))) (push (pop args) args1)) + (t (setq a (pop args)) + (if (string-match "%a" a) + (setq a (replace-match address t t a))) + (if (string-match "%s" a) + (setq a (replace-match subject t t a))) + (push a args1)))) + (apply cmd (nreverse args1)))) + + ((member type '("http" "https" "ftp" "news")) + (browse-url (concat type ":" path))) + + ((string= type "tags") + (org-tags-view in-emacs path)) + ((or (string= type "camel") + (string= type "thisfile")) + (if in-emacs + (switch-to-buffer-other-window + (org-get-buffer-for-internal-link (current-buffer))) + (org-mark-ring-push)) + (org-link-search + path + (cond ((equal in-emacs '(4)) 'occur) + ((equal in-emacs '(16)) 'org-occur) + (t nil)))) + + ((string= type "file") + (if (string-match "::\\([0-9]+\\)\\'" path) + (setq line (string-to-number (match-string 1 path)) + path (substring path 0 (match-beginning 0))) + (if (string-match "::\\(.+\\)\\'" path) + (setq search (match-string 1 path) + path (substring path 0 (match-beginning 0))))) + (org-open-file path in-emacs line search)) + + ((string= type "news") + (org-follow-gnus-link path)) + + ((string= type "bbdb") + (org-follow-bbdb-link path)) + + ((string= type "info") + (org-follow-info-link path)) + + ((string= type "gnus") + (let (group article) + (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) + (error "Error in Gnus link")) + (setq group (match-string 1 path) + article (match-string 3 path)) + (org-follow-gnus-link group article))) + + ((string= type "vm") + (let (folder article) + (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) + (error "Error in VM link")) + (setq folder (match-string 1 path) + article (match-string 3 path)) + ;; in-emacs is the prefix arg, will be interpreted as read-only + (org-follow-vm-link folder article in-emacs))) + + ((string= type "wl") + (let (folder article) + (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) + (error "Error in Wanderlust link")) + (setq folder (match-string 1 path) + article (match-string 3 path)) + (org-follow-wl-link folder article))) + + ((string= type "mhe") + (let (folder article) + (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) + (error "Error in MHE link")) + (setq folder (match-string 1 path) + article (match-string 3 path)) + (org-follow-mhe-link folder article))) + + ((string= type "rmail") + (let (folder article) + (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) + (error "Error in RMAIL link")) + (setq folder (match-string 1 path) + article (match-string 3 path)) + (org-follow-rmail-link folder article))) + + ((string= type "shell") + (let ((cmd path)) + (while (string-match "@{" cmd) ; FIXME: not needed for [[]] links + (setq cmd (replace-match "<" t t cmd))) + (while (string-match "@}" cmd) ; FIXME: not needed for [[]] links + (setq cmd (replace-match ">" t t cmd))) + (if (or (not org-confirm-shell-link-function) + (funcall org-confirm-shell-link-function + (format "Execute \"%s\" in shell? " + (org-add-props cmd nil + 'face 'org-warning)))) + (progn + (message "Executing %s" cmd) + (shell-command cmd)) + (error "Abort")))) + + ((string= type "elisp") + (let ((cmd path)) + (if (or (not org-confirm-elisp-link-function) + (funcall org-confirm-elisp-link-function + (format "Execute \"%s\" as elisp? " + (org-add-props cmd nil + 'face 'org-warning)))) + (message "%s => %s" cmd (eval (read cmd))) + (error "Abort")))) + + (t + (browse-url-at-point)))))) + +;;; File search + +(defvar org-create-file-search-functions nil + "List of functions to construct the right search string for a file link. +These functions are called in turn with point at the location to +which the link should point. + +A function in the hook should first test if it would like to +handle this file type, for example by checking the major-mode or +the file extension. If it decides not to handle this file, it +should just return nil to give other functions a chance. If it +does handle the file, it must return the search string to be used +when following the link. The search string will be part of the +file link, given after a double colon, and `org-open-at-point' +will automatically search for it. If special measures must be +taken to make the search successful, another function should be +added to the companion hook `org-execute-file-search-functions', +which see. + +A function in this hook may also use `setq' to set the variable +`description' to provide a suggestion for the descriptive text to +be used for this link when it gets inserted into an Org-mode +buffer with \\[org-insert-link].") + +(defvar org-execute-file-search-functions nil + "List of functions to execute a file search triggered by a link. + +Functions added to this hook must accept a single argument, the +search string that was part of the file link, the part after the +double colon. The function must first check if it would like to +handle this search, for example by checking the major-mode or the +file extension. If it decides not to handle this search, it +should just return nil to give other functions a chance. If it +does handle the search, it must return a non-nil value to keep +other functions from trying. + +Each function can access the current prefix argument through the +variable `current-prefix-argument'. Note that a single prefix is +used to force opening a link in Emacs, so it may be good to only +use a numeric or double prefix to guide the search function. + +In case this is needed, a function in this hook can also restore +the window configuration before `org-open-at-point' was called using: + + (set-window-configuration org-window-config-before-follow-link)") + +(defun org-link-search (s &optional type) + "Search for a link search option. +When S is a CamelCaseWord, search for a target, or for a sentence containing +the words. If S is surrounded by forward slashes, it is interpreted as a +regular expression. In org-mode files, this will create an `org-occur' +sparse tree. In ordinary files, `occur' will be used to list matches. +If the current buffer is in `dired-mode', grep will be used to search +in all files." + (let ((case-fold-search t) + (s0 (mapconcat 'identity (org-split-string s "[ \t\r\n]+") " ")) + (pos (point)) + (pre "") (post "") + words re0 re1 re2 re3 re4 re5 re2a reall camel) + (cond + ;; First check if there are any special + ((run-hook-with-args-until-success 'org-execute-file-search-functions s)) + ;; Now try the builtin stuff + ((save-excursion (goto-char (point-min)) - (while (org-activate-bracket-links (point-max)) - (add-text-properties (match-beginning 0) (match-end 0) - '(face org-link)))) - (run-hooks 'org-finalize-agenda-hook)))) + (and + (re-search-forward + (concat "<<" (regexp-quote s0) ">>") nil t) + (setq pos (match-beginning 0)))) + ;; There is an exact target for this + (goto-char pos)) + ((string-match "^/\\(.*\\)/$" s) + ;; A regular expression + (cond + ((org-mode-p) + (org-occur (match-string 1 s))) + ;;((eq major-mode 'dired-mode) + ;; (grep (concat "grep -n -e '" (match-string 1 s) "' *"))) + (t (org-do-occur (match-string 1 s))))) + ((or (setq camel (string-match (concat "^" org-camel-regexp "$") s)) + t) + ;; A camel or a normal search string + (when (equal (string-to-char s) ?*) + ;; Anchor on headlines, post may include tags. + (setq pre "^\\*+[ \t]*\\(?:\\sw+\\)?[ \t]*" + post "[ \t]*\\(?:[ \t]+:[a-zA-Z_@0-9:+]:[ \t]*\\)?$" + s (substring s 1))) + (remove-text-properties + 0 (length s) + '(face nil mouse-face nil keymap nil fontified nil) s) + ;; Make a series of regular expressions to find a match + (setq words + (if camel + (org-camel-to-words s) + (org-split-string s "[ \n\r\t]+")) + re0 (concat "\\(<<" (regexp-quote s0) ">>\\)") + re2 (concat "[ \t\r\n]\\(" (mapconcat 'downcase words "[ \t]+") "\\)[ \t\r\n]") + re2a (concat "[ \t\r\n]\\(" (mapconcat 'downcase words "[ \t\r\n]+") "\\)[ \t\r\n]") + re4 (concat "[^a-zA-Z_]\\(" (mapconcat 'downcase words "[^a-zA-Z_\r\n]+") "\\)[^a-zA-Z_]") + re1 (concat pre re2 post) + re3 (concat pre re4 post) + re5 (concat pre ".*" re4) + re2 (concat pre re2) + re2a (concat pre re2a) + re4 (concat pre re4) + reall (concat "\\(" re0 "\\)\\|\\(" re1 "\\)\\|\\(" re2 + "\\)\\|\\(" re3 "\\)\\|\\(" re4 "\\)\\|\\(" + re5 "\\)" + )) + (cond + ((eq type 'org-occur) (org-occur reall)) + ((eq type 'occur) (org-do-occur (downcase reall) 'cleanup)) + (t (goto-char (point-min)) + (if (or (org-search-not-link re0 nil t) + (org-search-not-link re1 nil t) + (org-search-not-link re2 nil t) + (org-search-not-link re2a nil t) + (org-search-not-link re3 nil t) + (org-search-not-link re4 nil t) + (org-search-not-link re5 nil t) + ) + (goto-char (match-beginning 1)) + (goto-char pos) + (error "No match"))))) + (t + ;; Normal string-search + (goto-char (point-min)) + (if (search-forward s nil t) + (goto-char (match-beginning 0)) + (error "No match")))) + (and (org-mode-p) (org-show-context 'link-search)))) -(defun org-prepare-agenda-buffers (files) - "Create buffers for all agenda files, protect archived trees and comments." +(defun org-search-not-link (&rest args) + "Execute `re-search-forward', but only accept matches that are not a link." + (catch 'exit + (let (p1) + (while (apply 're-search-forward args) + (setq p1 (point)) + (if (not (save-match-data + (and (re-search-backward "\\[\\[" nil t) + (looking-at org-bracket-link-regexp) + (<= (match-beginning 0) p1) + (>= (match-end 0) p1)))) + (progn (goto-char (match-end 0)) + (throw 'exit (point))) + (goto-char (match-end 0))))))) + +(defun org-get-buffer-for-internal-link (buffer) + "Return a buffer to be used for displaying the link target of internal links." + (cond + ((not org-display-internal-link-with-indirect-buffer) + buffer) + ((string-match "(Clone)$" (buffer-name buffer)) + (message "Buffer is already a clone, not making another one") + ;; we also do not modify visibility in this case + buffer) + (t ; make a new indirect buffer for displaying the link + (let* ((bn (buffer-name buffer)) + (ibn (concat bn "(Clone)")) + (ib (or (get-buffer ibn) (make-indirect-buffer buffer ibn 'clone)))) + (with-current-buffer ib (org-overview)) + ib)))) + +(defun org-do-occur (regexp &optional cleanup) + "Call the Emacs command `occur'. +If CLEANUP is non-nil, remove the printout of the regular expression +in the *Occur* buffer. This is useful if the regex is long and not useful +to read." + (occur regexp) + (when cleanup + (let ((cwin (selected-window)) win beg end) + (when (setq win (get-buffer-window "*Occur*")) + (select-window win)) + (goto-char (point-min)) + (when (re-search-forward "match[a-z]+" nil t) + (setq beg (match-end 0)) + (if (re-search-forward "^[ \t]*[0-9]+" nil t) + (setq end (1- (match-beginning 0))))) + (and beg end (let ((buffer-read-only)) (delete-region beg end))) + (goto-char (point-min)) + (select-window cwin)))) + +;;; The mark ring for links jumps + +(defvar org-mark-ring nil + "Mark ring for positions before jumps in Org-mode.") +(defvar org-mark-ring-last-goto nil + "Last position in the mark ring used to go back.") +;; Fill and close the ring +(setq org-mark-ring nil org-mark-ring-last-goto nil) ;; in case file is reloaded +(loop for i from 1 to org-mark-ring-length do + (push (make-marker) org-mark-ring)) +(setcdr (nthcdr (1- org-mark-ring-length) org-mark-ring) + org-mark-ring) + +(defun org-mark-ring-push (&optional pos buffer) + "Put the current position or POS into the mark ring and rotate it." (interactive) - (let ((pa '(:org-archived t)) - (pc '(:org-comment t)) - (pall '(:org-archived t :org-comment t)) - (rea (concat ":" org-archive-tag ":")) - bmp file re) + (setq pos (or pos (point))) + (setq org-mark-ring (nthcdr (1- org-mark-ring-length) org-mark-ring)) + (move-marker (car org-mark-ring) + (or pos (point)) + (or buffer (current-buffer))) + (message + (substitute-command-keys + "Position saved to mark ring, go back with \\[org-mark-ring-goto]."))) + +(defun org-mark-ring-goto (&optional n) + "Jump to the previous position in the mark ring. +With prefix arg N, jump back that many stored positions. When +called several times in succession, walk through the entire ring. +Org-mode commands jumping to a different position in the current file, +or to another Org-mode file, automatically push the old position +onto the ring." + (interactive "p") + (let (p m) + (if (eq last-command this-command) + (setq p (nthcdr n (or org-mark-ring-last-goto org-mark-ring))) + (setq p org-mark-ring)) + (setq org-mark-ring-last-goto p) + (setq m (car p)) + (switch-to-buffer (marker-buffer m)) + (goto-char m) + (if (or (org-invisible-p) (org-invisible-p2)) (org-show-context 'mark-goto)))) + +(defun org-camel-to-words (s) + "Split \"CamelCaseWords\" to (\"Camel\" \"Case\" \"Words\")." + (let ((case-fold-search nil) + words) + (while (string-match "[a-z][A-Z]" s) + (push (substring s 0 (1+ (match-beginning 0))) words) + (setq s (substring s (1+ (match-beginning 0))))) + (nreverse (cons s words)))) + +(defun org-remove-angle-brackets (s) + (if (equal (substring s 0 1) "<") (setq s (substring s 1))) + (if (equal (substring s -1) ">") (setq s (substring s 0 -1))) + s) +(defun org-add-angle-brackets (s) + (if (equal (substring s 0 1) "<") nil (setq s (concat "<" s))) + (if (equal (substring s -1) ">") nil (setq s (concat s ">"))) + s) + +;;; Following specific links + +(defun org-follow-timestamp-link () + (cond + ((org-at-date-range-p t) + (let ((org-agenda-start-on-weekday) + (t1 (match-string 1)) + (t2 (match-string 2))) + (setq t1 (time-to-days (org-time-string-to-time t1)) + t2 (time-to-days (org-time-string-to-time t2))) + (org-agenda-list nil t1 (1+ (- t2 t1))))) + ((org-at-timestamp-p t) + (org-agenda-list nil (time-to-days (org-time-string-to-time + (substring (match-string 1) 0 10))) + 1)) + (t (error "This should not happen")))) + + +(defun org-follow-bbdb-link (name) + "Follow a BBDB link to NAME." + (require 'bbdb) + (let ((inhibit-redisplay t) + (bbdb-electric-p nil)) + (catch 'exit + ;; Exact match on name + (bbdb-name (concat "\\`" name "\\'") nil) + (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) + ;; Exact match on name + (bbdb-company (concat "\\`" name "\\'") nil) + (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) + ;; Partial match on name + (bbdb-name name nil) + (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) + ;; Partial match on company + (bbdb-company name nil) + (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) + ;; General match including network address and notes + (bbdb name nil) + (when (= 0 (buffer-size (get-buffer "*BBDB*"))) + (delete-window (get-buffer-window "*BBDB*")) + (error "No matching BBDB record"))))) + +(defun org-follow-info-link (name) + "Follow an info file & node link to NAME." + (if (or (string-match "\\(.*\\)::?\\(.*\\)" name) + (string-match "\\(.*\\)" name)) + (progn + (require 'info) + (if (match-string 2 name) ; If there isn't a node, choose "Top" + (Info-find-node (match-string 1 name) (match-string 2 name)) + (Info-find-node (match-string 1 name) "Top"))) + (message (concat "Could not open: " name)))) + +(defun org-follow-gnus-link (&optional group article) + "Follow a Gnus link to GROUP and ARTICLE." + (require 'gnus) + (funcall (cdr (assq 'gnus org-link-frame-setup))) + (if gnus-other-frame-object (select-frame gnus-other-frame-object)) + (if group (gnus-fetch-group group)) + (if article + (or (gnus-summary-goto-article article nil 'force) + (if (fboundp 'gnus-summary-insert-cached-articles) + (progn + (gnus-summary-insert-cached-articles) + (gnus-summary-goto-article article nil 'force)) + (message "Message could not be found."))))) + +(defun org-follow-vm-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) + (sit-for 0.1) + (when article + (vm-select-folder-buffer) + (widen) + (let ((case-fold-search t)) + (goto-char (point-min)) + (if (not (re-search-forward + (concat "^" "message-id: *" (regexp-quote article)))) + (error "Could not find the specified message in this folder")) + (vm-isearch-update) + (vm-isearch-narrow) + (vm-beginning-of-message) + (vm-summarize))))) + +(defun org-follow-wl-link (folder article) + "Follow a Wanderlust link to FOLDER and ARTICLE." + (setq article (org-add-angle-brackets article)) + (wl-summary-goto-folder-subr folder 'no-sync t nil t nil nil) + (if article (wl-summary-jump-to-msg-by-message-id article)) + (wl-summary-redisplay)) + +(defun org-follow-rmail-link (folder article) + "Follow an RMAIL link to FOLDER and ARTICLE." + (setq article (org-add-angle-brackets article)) + (let (message-number) (save-excursion - (while (setq file (pop files)) - (org-check-agenda-file file) - (set-buffer (org-get-agenda-file-buffer file)) - (widen) - (setq bmp (buffer-modified-p)) + (save-window-excursion + (rmail (if (string= folder "RMAIL") rmail-file-name folder)) + (setq message-number + (save-restriction + (widen) + (goto-char (point-max)) + (if (re-search-backward + (concat "^Message-ID:\\s-+" (regexp-quote + (or article ""))) + nil t) + (rmail-what-message)))))) + (if message-number + (progn + (rmail (if (string= folder "RMAIL") rmail-file-name folder)) + (rmail-show-message message-number) + message-number) + (error "Message not found")))) + +;;; mh-e integration based on planner-mode +(defun org-mhe-get-message-real-folder () + "Return the name of the current message real folder, so if you use +sequences, it will now work." + (save-excursion + (let* ((folder + (if (equal major-mode 'mh-folder-mode) + mh-current-folder + ;; Refer to the show buffer + mh-show-folder-buffer)) + (end-index + (if (boundp 'mh-index-folder) + (min (length mh-index-folder) (length folder)))) + ) + ;; a simple test on mh-index-data does not work, because + ;; mh-index-data is always nil in a show buffer. + (if (and (boundp 'mh-index-folder) + (string= mh-index-folder (substring folder 0 end-index))) + (if (equal major-mode 'mh-show-mode) + (save-window-excursion + (when (buffer-live-p (get-buffer folder)) + (progn + (pop-to-buffer folder) + (org-mhe-get-message-folder-from-index) + ) + )) + (org-mhe-get-message-folder-from-index) + ) + folder + ) + ))) + +(defun org-mhe-get-message-folder-from-index () + "Returns the name of the message folder in a index folder buffer." + (save-excursion + (mh-index-previous-folder) + (re-search-forward "^\\(+.*\\)$" nil t) + (message (match-string 1)))) + +(defun org-mhe-get-message-folder () + "Return the name of the current message folder. Be careful if you +use sequences." + (save-excursion + (if (equal major-mode 'mh-folder-mode) + mh-current-folder + ;; Refer to the show buffer + mh-show-folder-buffer))) + +(defun org-mhe-get-message-num () + "Return the number of the current message. Be careful if you +use sequences." + (save-excursion + (if (equal major-mode 'mh-folder-mode) + (mh-get-msg-num nil) + ;; Refer to the show buffer + (mh-show-buffer-message-number)))) + +(defun org-mhe-get-header (header) + "Return a header of the message in folder mode. This will create a +show buffer for the corresponding message. If you have a more clever +idea..." + (let* ((folder (org-mhe-get-message-folder)) + (num (org-mhe-get-message-num)) + (buffer (get-buffer-create (concat "show-" folder))) + (header-field)) + (with-current-buffer buffer + (mh-display-msg num folder) + (if (equal major-mode 'mh-folder-mode) + (mh-header-display) + (mh-show-header-display)) + (set-buffer buffer) + (setq header-field (mh-get-header-field header)) + (if (equal major-mode 'mh-folder-mode) + (mh-show) + (mh-show-show)) + header-field))) + +(defun org-follow-mhe-link (folder article) + "Follow an MHE link to FOLDER and ARTICLE. +If ARTICLE is nil FOLDER is shown. If the configuration variable +`org-mhe-search-all-folders' is t and `mh-searcher' is pick, +ARTICLE is searched in all folders. Indexed searches (swish++, +namazu, and others supported by MH-E) will always search in all +folders." + (require 'mh-e) + (require 'mh-search) + (require 'mh-utils) + (mh-find-path) + (if (not article) + (mh-visit-folder (mh-normalize-folder-name folder)) + (setq article (org-add-angle-brackets article)) + (mh-search-choose) + (if (equal mh-searcher 'pick) + (progn + (mh-search folder (list "--message-id" article)) + (when (and org-mhe-search-all-folders + (not (org-mhe-get-message-real-folder))) + (kill-this-buffer) + (mh-search "+" (list "--message-id" article)))) + (mh-search "+" article)) + (if (org-mhe-get-message-real-folder) + (mh-show-msg 1) + (kill-this-buffer) + (error "Message not found")))) + +;;; BibTeX links + +;; Use the custom search meachnism to construct and use search strings for +;; file links to BibTeX database entries. + +(defun org-create-file-search-in-bibtex () + "Create the search string and description for a BibTeX database entry." + (when (eq major-mode 'bibtex-mode) + ;; yes, we want to construct this search string. + ;; Make a good description for this entry, using names, year and the title + ;; Put it into the `description' variable which is dynamically scoped. + (let ((bibtex-autokey-names 1) + (bibtex-autokey-names-stretch 1) + (bibtex-autokey-name-case-convert-function 'identity) + (bibtex-autokey-name-separator " & ") + (bibtex-autokey-additional-names " et al.") + (bibtex-autokey-year-length 4) + (bibtex-autokey-name-year-separator " ") + (bibtex-autokey-titlewords 3) + (bibtex-autokey-titleword-separator " ") + (bibtex-autokey-titleword-case-convert-function 'identity) + (bibtex-autokey-titleword-length 'infty) + (bibtex-autokey-year-title-separator ": ")) + (setq description (bibtex-generate-autokey))) + ;; Now parse the entry, get the key and return it. + (save-excursion + (bibtex-beginning-of-entry) + (cdr (assoc "=key=" (bibtex-parse-entry)))))) + +(defun org-execute-file-search-in-bibtex (s) + "Find the link search string S as a key for a database entry." + (when (eq major-mode 'bibtex-mode) + ;; Yes, we want to do the search in this file. + ;; We construct a regexp that searches for "@entrytype{" followed by the key + (goto-char (point-min)) + (and (re-search-forward (concat "@[a-zA-Z]+[ \t\n]*{[ \t\n]*" + (regexp-quote s) "[ \t\n]*,") nil t) + (goto-char (match-beginning 0))) + (if (and (match-beginning 0) (equal current-prefix-arg '(16))) + ;; Use double prefix to indicate that any web link should be browsed + (let ((b (current-buffer)) (p (point))) + ;; Restore the window configuration because we just use the web link + (set-window-configuration org-window-config-before-follow-link) + (save-excursion (set-buffer b) (goto-char p) + (bibtex-url))) + (recenter 0)) ; Move entry start to beginning of window + ;; return t to indicate that the search is done. + t)) + +;; Finally add the functions to the right hooks. +(add-hook 'org-create-file-search-functions 'org-create-file-search-in-bibtex) +(add-hook 'org-execute-file-search-functions 'org-execute-file-search-in-bibtex) + +;; end of Bibtex link setup + + +;; FIXME: This function can be removed, I think. +(defun org-upgrade-old-links (&optional query-description) + "Transfer old <...> style links to new [[...]] style links. +With arg query-description, ask at each match for a description text to use +for this link." + (interactive (list (y-or-n-p "Would you like to be queried for a description at each link?"))) + (save-excursion + (goto-char (point-min)) + (let ((re (concat "\\([^[]\\)<\\(" + "\\(" (mapconcat 'identity org-link-types "\\|") + "\\):" + "[^" org-non-link-chars "]+\\)>")) + l1 l2 (cnt 0)) + (while (re-search-forward re nil t) + (setq cnt (1+ cnt) + l1 (org-match-string-no-properties 2) + l2 (save-match-data (org-link-escape l1))) + (when query-description (setq l1 (read-string "Desc: " l1))) + (if (equal l1 l2) + (replace-match (concat (match-string 1) "[[" l1 "]]") t t) + (replace-match (concat (match-string 1) "[[" l2 "][" l1 "]]") t t))) + (message "%d matches have beed treated" cnt)))) + +;;; Following file links + +(defun org-open-file (path &optional in-emacs line search) + "Open the file at PATH. +First, this expands any special file name abbreviations. Then the +configuration variable `org-file-apps' is checked if it contains an +entry for this file type, and if yes, the corresponding command is launched. +If no application is found, Emacs simply visits the file. +With optional argument IN-EMACS, Emacs will visit the file. +Optional LINE specifies a line to go to, optional SEARCH a string to +search for. If LINE or SEARCH is given, the file will always be +opened in Emacs. +If the file does not exist, an error is thrown." + (setq in-emacs (or in-emacs line search)) + (let* ((file (if (equal path "") + buffer-file-name + (substitute-in-file-name (expand-file-name path)))) + (apps (append org-file-apps (org-default-apps))) + (remp (and (assq 'remote apps) (org-file-remote-p file))) + (dirp (if remp nil (file-directory-p file))) + (dfile (downcase file)) + (old-buffer (current-buffer)) + (old-pos (point)) + (old-mode major-mode) + ext cmd) + (if (string-match "^.*\\.\\([a-zA-Z0-9]+\\.gz\\)$" dfile) + (setq ext (match-string 1 dfile)) + (if (string-match "^.*\\.\\([a-zA-Z0-9]+\\)$" dfile) + (setq ext (match-string 1 dfile)))) + (if in-emacs + (setq cmd 'emacs) + (setq cmd (or (and remp (cdr (assoc 'remote apps))) + (and dirp (cdr (assoc 'directory apps))) + (cdr (assoc ext apps)) + (cdr (assoc t apps))))) + (when (eq cmd 'mailcap) + (require 'mailcap) + (mailcap-parse-mailcaps) + (let* ((mime-type (mailcap-extension-to-mime (or ext ""))) + (command (mailcap-mime-info mime-type))) + (if (stringp command) + (setq cmd command) + (setq cmd 'emacs)))) + (if (and (not (eq cmd 'emacs)) ; Emacs has not problems with non-ex files + (not (file-exists-p file)) + (not org-open-non-existing-files)) + (error "No such file: %s" file)) + (cond + ((and (stringp cmd) (not (string-match "^\\s-*$" cmd))) + ;; Remove quotes around the file name - we'll use shell-quote-argument. + (if (string-match "['\"]%s['\"]" cmd) + (setq cmd (replace-match "%s" t t cmd))) + (setq cmd (format cmd (shell-quote-argument file))) + (save-window-excursion + (shell-command (concat cmd " &")))) + ((or (stringp cmd) + (eq cmd 'emacs)) + (funcall (cdr (assq 'file org-link-frame-setup)) file) + (if line (goto-line line) + (if search (org-link-search search)))) + ((consp cmd) + (eval cmd)) + (t (funcall (cdr (assq 'file org-link-frame-setup)) file))) + (and (org-mode-p) (eq old-mode 'org-mode) + (or (not (equal old-buffer (current-buffer))) + (not (equal old-pos (point)))) + (org-mark-ring-push old-pos old-buffer)))) + +(defun org-default-apps () + "Return the default applications for this operating system." + (cond + ((eq system-type 'darwin) + org-file-apps-defaults-macosx) + ((eq system-type 'windows-nt) + org-file-apps-defaults-windowsnt) + (t org-file-apps-defaults-gnu))) + +(defun org-expand-file-name (path) + "Replace special path abbreviations and expand the file name." + (expand-file-name path)) + +(defvar ange-ftp-name-format) ; to silence the XEmacs compiler. +(defun org-file-remote-p (file) + "Test whether FILE specifies a location on a remote system. +Return non-nil if the location is indeed remote. + +For example, the filename \"/user@host:/foo\" specifies a location +on the system \"/user@host:\"." + (cond ((fboundp 'file-remote-p) + (file-remote-p file)) + ((fboundp 'tramp-handle-file-remote-p) + (tramp-handle-file-remote-p file)) + ((and (boundp 'ange-ftp-name-format) + (string-match (car ange-ftp-name-format) file)) + t) + (t nil))) + + +;;;; Hooks for remember.el + +;;;###autoload +(defun org-remember-annotation () + "Return a link to the current location as an annotation for remember.el. +If you are using Org-mode files as target for data storage with +remember.el, then the annotations should include a link compatible with the +conventions in Org-mode. This function returns such a link." + (org-store-link nil)) + +(defconst org-remember-help +"Select a destination location for the note. +UP/DOWN=headline TAB=cycle visibility [Q]uit RET/<left>/<right>=Store +RET at beg-of-buf -> Append to file as level 2 headline +RET on headline -> Store as sublevel entry to current headline +<left>/<right> -> before/after current headline, same headings level") + +;;;###autoload +(defun org-remember-apply-template () + "Initialize *remember* buffer with template, invoke `org-mode'. +This function should be placed into `remember-mode-hook' and in fact requires +to be run from that hook to fucntion properly." + (if org-remember-templates + + (let* ((entry (if (= (length org-remember-templates) 1) + (cdar org-remember-templates) + (message "Select template: %s" + (mapconcat + (lambda (x) (char-to-string (car x))) + org-remember-templates " ")) + (cdr (assoc (read-char-exclusive) org-remember-templates)))) + (tpl (car entry)) + (file (if (consp (cdr entry)) (nth 1 entry))) + (v-t (format-time-string (car org-time-stamp-formats) (org-current-time))) + (v-T (format-time-string (cdr org-time-stamp-formats) (org-current-time))) + (v-u (concat "[" (substring v-t 1 -1) "]")) + (v-U (concat "[" (substring v-T 1 -1) "]")) + (v-a annotation) ; defined in `remember-mode' + (v-i initial) ; defined in `remember-mode' + (v-n user-full-name) + ) + (unless tpl (setq tpl "") (message "No template") (ding)) + (insert tpl) (goto-char (point-min)) + (while (re-search-forward "%\\([tTuTai]\\)" nil t) + (when (and initial (equal (match-string 0) "%i")) + (save-match-data + (let* ((lead (buffer-substring + (point-at-bol) (match-beginning 0)))) + (setq v-i (mapconcat 'identity + (org-split-string initial "\n") + (concat "\n" lead)))))) + (replace-match + (or (eval (intern (concat "v-" (match-string 1)))) "") + t t)) + (let ((org-startup-folded nil) + (org-startup-with-deadline-check nil)) + (org-mode)) + (if (and file (string-match "\\S-" file) (not (file-directory-p file))) + (org-set-local 'org-default-notes-file file)) + (goto-char (point-min)) + (if (re-search-forward "%\\?" nil t) (replace-match ""))) + (let ((org-startup-folded nil) + (org-startup-with-deadline-check nil)) + (org-mode))) + (org-set-local 'org-finish-function 'remember-buffer)) + +;;;###autoload +(defun org-remember-handler () + "Store stuff from remember.el into an org file. +First prompts for an org file. If the user just presses return, the value +of `org-default-notes-file' is used. +Then the command offers the headings tree of the selected file in order to +file the text at a specific location. +You can either immediately press RET to get the note appended to the +file, or you can use vertical cursor motion and visibility cycling (TAB) to +find a better place. Then press RET or <left> or <right> in insert the note. + +Key Cursor position Note gets inserted +----------------------------------------------------------------------------- +RET buffer-start as level 2 heading at end of file +RET on headline as sublevel of the heading at cursor +RET no heading at cursor position, level taken from context. + Or use prefix arg to specify level manually. +<left> on headline as same level, before current heading +<right> on headline as same level, after current heading + +So the fastest way to store the note is to press RET RET to append it to +the default file. This way your current train of thought is not +interrupted, in accordance with the principles of remember.el. But with +little extra effort, you can push it directly to the correct location. + +Before being stored away, the function ensures that the text has a +headline, i.e. a first line that starts with a \"*\". If not, a headline +is constructed from the current date and some additional data. + +If the variable `org-adapt-indentation' is non-nil, the entire text is +also indented so that it starts in the same column as the headline +\(i.e. after the stars). + +See also the variable `org-reverse-note-order'." + (catch 'quit + (let* ((txt (buffer-substring (point-min) (point-max))) + (fastp current-prefix-arg) + (file (if fastp org-default-notes-file (org-get-org-file))) + (visiting (find-buffer-visiting file)) + (org-startup-with-deadline-check nil) + (org-startup-folded nil) + (org-startup-align-all-tables nil) + spos level indent reversed) + ;; Modify text so that it becomes a nice subtree which can be inserted + ;; into an org tree. + (let* ((lines (split-string txt "\n")) + first) + ;; remove empty lines at the beginning + (while (and lines (string-match "^[ \t]*\n" (car lines))) + (setq lines (cdr lines))) + (setq first (car lines) lines (cdr lines)) + (if (string-match "^\\*+" first) + ;; Is already a headline + (setq indent nil) + ;; We need to add a headline: Use time and first buffer line + (setq lines (cons first lines) + first (concat "* " (current-time-string) + " (" (remember-buffer-desc) ")") + indent " ")) + (if (and org-adapt-indentation indent) + (setq lines (mapcar (lambda (x) (concat indent x)) lines))) + (setq txt (concat first "\n" + (mapconcat 'identity lines "\n")))) + ;; Find the file + (if (not visiting) + (find-file-noselect file)) + (with-current-buffer (get-file-buffer file) + (save-excursion (and (goto-char (point-min)) + (not (re-search-forward "^\\* " nil t)) + (insert "\n* Notes\n"))) + (setq reversed (org-notes-order-reversed-p)) (save-excursion - (remove-text-properties (point-min) (point-max) pall) - (when org-agenda-skip-archived-trees - (goto-char (point-min)) - (while (re-search-forward rea nil t) - (if (org-on-heading-p) - (add-text-properties (point-at-bol) (org-end-of-subtree t) pa)))) - (goto-char (point-min)) - (setq re (concat "^\\*+ +" org-comment-string "\\>")) - (while (re-search-forward re nil t) - (add-text-properties - (match-beginning 0) (org-end-of-subtree t) pc))) - (set-buffer-modified-p bmp))))) + (save-restriction + (widen) + ;; Ask the User for a location + (setq spos (if fastp 1 (org-get-location + (current-buffer) + org-remember-help))) + (if (not spos) (throw 'quit nil)) ; return nil to show we did + ; not handle this note + (goto-char spos) + (cond ((and (bobp) (not reversed)) + ;; Put it at the end, as level 2 + (save-restriction + (widen) + (goto-char (point-max)) + (if (not (bolp)) (newline)) + (org-paste-subtree 2 txt))) + ((and (bobp) reversed) + ;; Put it at the start, as level 1 + (save-restriction + (widen) + (goto-char (point-min)) + (re-search-forward "^\\*" nil t) + (beginning-of-line 1) + (org-paste-subtree 1 txt))) + ((and (org-on-heading-p nil) (not current-prefix-arg)) + ;; Put it below this entry, at the beg/end of the subtree + (org-back-to-heading) + (setq level (funcall outline-level)) + (if reversed + (outline-end-of-heading) + (outline-end-of-subtree)) + (if (not (bolp)) (newline)) + (beginning-of-line 1) + (org-paste-subtree (org-get-legal-level level 1) txt)) + (t + ;; Put it right there, with automatic level determined by + ;; org-paste-subtree or from prefix arg + (org-paste-subtree current-prefix-arg txt))) + (when remember-save-after-remembering + (save-buffer) + (if (not visiting) (kill-buffer (current-buffer))))))))) + t) ;; return t to indicate that we took care of this note. -(defvar org-agenda-skip-function nil - "Function to be called at each match during agenda construction. -If this function return nil, the current match should not be skipped. -Otherwise, the function must return a position from where the search -should be continued. -Never set this variable using `setq' or so, because then it will apply -to all future agenda commands. Instead, bind it with `let' to scope -it dynamically into the agenda-constructing command.") +(defun org-get-org-file () + "Read a filename, with default directory `org-directory'." + (let ((default (or org-default-notes-file remember-data-file))) + (read-file-name (format "File name [%s]: " default) + (file-name-as-directory org-directory) + default))) -(defun org-agenda-skip () - "Throw to `:skip' in places that should be skipped." - (let ((p (point-at-bol)) to) - (and org-agenda-skip-archived-trees - (get-text-property p :org-archived) - (org-end-of-subtree t) - (throw :skip t)) - (and (get-text-property p :org-comment) - (org-end-of-subtree t) - (throw :skip t)) - (if (equal (char-after p) ?#) (throw :skip t)) - (when (and (functionp org-agenda-skip-function) - (setq to (save-excursion - (save-match-data - (funcall org-agenda-skip-function))))) - (goto-char to) - (throw :skip t)))) +(defun org-notes-order-reversed-p () + "Check if the current file should receive notes in reversed order." + (cond + ((not org-reverse-note-order) nil) + ((eq t org-reverse-note-order) t) + ((not (listp org-reverse-note-order)) nil) + (t (catch 'exit + (let ((all org-reverse-note-order) + entry) + (while (setq entry (pop all)) + (if (string-match (car entry) buffer-file-name) + (throw 'exit (cdr entry)))) + nil))))) ;;;; Dynamic blocks @@ -5694,7 +9733,7 @@ At all other locations, this simply calls `ispell-complete-word'." (error (display-completion-list list))))) (message "Making completion list...%s" "done")))))) -;;;; Comments, TODO and DEADLINE +;;;; TODO, DEADLINE, Comments (defun org-toggle-comment () "Change the COMMENT state of an entry." @@ -6034,55 +10073,6 @@ look like when opend with successive calls to `org-cycle'." (org-show-following-heading t)) (org-show-context nil siblings))) -;; Overlay compatibility functions -(defun org-make-overlay (beg end &optional buffer) - (if (featurep 'xemacs) - (make-extent beg end buffer) - (make-overlay beg end buffer))) -(defun org-delete-overlay (ovl) - (if (featurep 'xemacs) (delete-extent ovl) (delete-overlay ovl))) -(defun org-detach-overlay (ovl) - (if (featurep 'xemacs) (detach-extent ovl) (delete-overlay ovl))) -(defun org-move-overlay (ovl beg end &optional buffer) - (if (featurep 'xemacs) - (set-extent-endpoints ovl beg end (or buffer (current-buffer))) - (move-overlay ovl beg end buffer))) -(defun org-overlay-put (ovl prop value) - (if (featurep 'xemacs) - (set-extent-property ovl prop value) - (overlay-put ovl prop value))) -(defun org-overlay-display (ovl text &optional face) - "Make overlay OVL display TEXT with face FACE." - (if (featurep 'xemacs) - (let ((gl (make-glyph text))) - (and face (set-glyph-face gl face)) - (set-extent-property ovl 'invisible t) - (set-extent-property ovl 'end-glyph gl)) - (overlay-put ovl 'display text) - (if face (overlay-put ovl 'face face)))) -(defun org-overlay-get (ovl prop) - (if (featurep 'xemacs) - (extent-property ovl prop) - (overlay-get ovl prop))) -(defun org-overlays-at (pos) - (if (featurep 'xemacs) (extents-at pos) (overlays-at pos))) -(defun org-overlays-in (&optional start end) - (if (featurep 'xemacs) - (extent-list nil start end) - (overlays-in start end))) -(defun org-overlay-start (o) - (if (featurep 'xemacs) (extent-start-position o) (overlay-start o))) -(defun org-overlay-end (o) - (if (featurep 'xemacs) (extent-end-position o) (overlay-end o))) -(defun org-find-overlays (prop &optional pos delete) - "Find all overlays specifying PROP at POS or point. -If DELETE is non-nil, delete all those overlays." - (let ((overlays (org-overlays-at (or pos (point)))) - ov found) - (while (setq ov (pop overlays)) - (if (org-overlay-get ov prop) - (if delete (org-delete-overlay ov) (push ov found)))) - found)) (defun org-highlight-new-match (beg end) "Highlight from BEG to END and mark the highlight is an occur headline." @@ -6173,9 +10163,494 @@ ACTION can be set, up, or down." (* 1000 (- org-lowest-priority (string-to-char (match-string 2 s))))))) +;;;; Tags + +(defun org-scan-tags (action matcher &optional todo-only) + "Scan headline tags with inheritance and produce output ACTION. +ACTION can be `sparse-tree' or `agenda'. MATCHER is a Lisp form to be +evaluated, testing if a given set of tags qualifies a headline for +inclusion. When TODO-ONLY is non-nil, only lines with a TODO keyword +are included in the output." + (let* ((re (concat "[\n\r]" outline-regexp " *\\(\\<\\(" + (mapconcat 'regexp-quote + (nreverse (cdr (reverse org-todo-keywords))) + "\\|") + "\\>\\)\\)? *\\(.*?\\)\\(:[A-Za-z_@0-9:]+:\\)?[ \t]*$")) + (props (list 'face nil + 'done-face 'org-done + 'undone-face nil + 'mouse-face 'highlight + 'org-not-done-regexp org-not-done-regexp + 'keymap org-agenda-keymap + 'help-echo + (format "mouse-2 or RET jump to org file %s" + (abbreviate-file-name buffer-file-name)))) + (case-fold-search nil) + lspos + tags tags-list tags-alist (llast 0) rtn level category i txt + todo marker entry) + (save-excursion + (goto-char (point-min)) + (when (eq action 'sparse-tree) (org-overview)) + (while (re-search-forward re nil t) + (catch :skip + (and (eq action 'agenda) (org-agenda-skip)) + (setq todo (if (match-end 1) (match-string 2)) + tags (if (match-end 4) (match-string 4))) + (goto-char (setq lspos (1+ (match-beginning 0)))) + (setq level (funcall outline-level) + category (org-get-category)) + (setq i llast llast level) + ;; remove tag lists from same and sublevels + (while (>= i level) + (when (setq entry (assoc i tags-alist)) + (setq tags-alist (delete entry tags-alist))) + (setq i (1- i))) + ;; add the nex tags + (when tags + (setq tags (mapcar 'downcase (org-split-string tags ":")) + tags-alist + (cons (cons level tags) tags-alist))) + ;; compile tags for current headline + (setq tags-list + (if org-use-tag-inheritance + (apply 'append (mapcar 'cdr tags-alist)) + tags)) + (when (and (or (not todo-only) todo) + (eval matcher) + (or (not org-agenda-skip-archived-trees) + (not (member org-archive-tag tags-list)))) + ;; list this headline + (if (eq action 'sparse-tree) + (progn + (org-show-context 'tags-tree)) + (setq txt (org-format-agenda-item + "" + (concat + (if org-tags-match-list-sublevels + (make-string (1- level) ?.) "") + (org-get-heading)) + category tags-list)) + (goto-char lspos) + (setq marker (org-agenda-new-marker)) + (org-add-props txt props + 'org-marker marker 'org-hd-marker marker 'category category) + (push txt rtn)) + ;; if we are to skip sublevels, jump to end of subtree + (or org-tags-match-list-sublevels (org-end-of-subtree t)))))) + (when (and (eq action 'sparse-tree) + (not org-sparse-tree-open-archived-trees)) + (org-hide-archived-subtrees (point-min) (point-max))) + (nreverse rtn))) + +(defvar todo-only) ;; dynamically scoped + +(defun org-tags-sparse-tree (&optional todo-only match) + "Create a sparse tree according to tags string MATCH. +MATCH can contain positive and negative selection of tags, like +\"+WORK+URGENT-WITHBOSS\". +If optional argument TODO_ONLY is non-nil, only select lines that are +also TODO lines." + (interactive "P") + (org-scan-tags 'sparse-tree (cdr (org-make-tags-matcher match)) todo-only)) + +;; FIXME: implement search for a specific level. +(defun org-make-tags-matcher (match) + "Create the TAGS//TODO matcher form for the selection string MATCH." + ;; todo-only is scoped dynamically into this function, and the function + ;; may change it it the matcher asksk for it. + (unless match + ;; Get a new match request, with completion + (setq org-last-tags-completion-table + (or org-tag-alist + org-last-tags-completion-table)) + (setq match (completing-read + "Match: " 'org-tags-completion-function nil nil nil + 'org-tags-history))) ; FIXME: Separate history for this? + + ;; Parse the string and create a lisp form + (let ((match0 match) + (re "^&?\\([-+:]\\)?\\({[^}]+}\\|LEVEL=\\([0-9]+\\)\\|[A-Za-z_@0-9]+\\)") + minus tag mm + tagsmatch todomatch tagsmatcher todomatcher kwd matcher + orterms term orlist re-p level-p) + (if (string-match "/+" match) + ;; match contains also a todo-matching request + (progn + (setq tagsmatch (substring match 0 (match-beginning 0)) + todomatch (substring match (match-end 0))) + (if (string-match "^!" todomatch) + (setq todo-only t todomatch (substring todomatch 1))) + (if (string-match "^\\s-*$" todomatch) + (setq todomatch nil))) + ;; only matching tags + (setq tagsmatch match todomatch nil)) + + ;; Make the tags matcher + (if (or (not tagsmatch) (not (string-match "\\S-" tagsmatch))) + (setq tagsmatcher t) + (setq orterms (org-split-string tagsmatch "|") orlist nil) + (while (setq term (pop orterms)) + (while (and (equal (substring term -1) "\\") orterms) + (setq term (concat term "|" (pop orterms)))) ; repair bad split + (while (string-match re term) + (setq minus (and (match-end 1) + (equal (match-string 1 term) "-")) + tag (match-string 2 term) + re-p (equal (string-to-char tag) ?{) + level-p (match-end 3) + mm (cond + (re-p `(org-match-any-p ,(substring tag 1 -1) tags-list)) + (level-p `(= level ,(string-to-number + (match-string 3 term)))) + (t `(member ,(downcase tag) tags-list))) + mm (if minus (list 'not mm) mm) + term (substring term (match-end 0))) + (push mm tagsmatcher)) + (push (if (> (length tagsmatcher) 1) + (cons 'and tagsmatcher) + (car tagsmatcher)) + orlist) + (setq tagsmatcher nil)) + (setq tagsmatcher (if (> (length orlist) 1) (cons 'or orlist) (car orlist)))) + + ;; Make the todo matcher + (if (or (not todomatch) (not (string-match "\\S-" todomatch))) + (setq todomatcher t) + (setq orterms (org-split-string todomatch "|") orlist nil) + (while (setq term (pop orterms)) + (while (string-match re term) + (setq minus (and (match-end 1) + (equal (match-string 1 term) "-")) + kwd (match-string 2 term) + re-p (equal (string-to-char kwd) ?{) + term (substring term (match-end 0)) + mm (if re-p + `(string-match ,(substring kwd 1 -1) todo) + (list 'equal 'todo kwd)) + mm (if minus (list 'not mm) mm)) + (push mm todomatcher)) + (push (if (> (length todomatcher) 1) + (cons 'and todomatcher) + (car todomatcher)) + orlist) + (setq todomatcher nil)) + (setq todomatcher (if (> (length orlist) 1) + (cons 'or orlist) (car orlist)))) + + ;; Return the string and lisp forms of the matcher + (setq matcher (if todomatcher + (list 'and tagsmatcher todomatcher) + tagsmatcher)) + (cons match0 matcher))) + +(defun org-match-any-p (re list) + "Does re match any element of list?" + (setq list (mapcar (lambda (x) (string-match re x)) list)) + (delq nil list)) + +(defvar org-add-colon-after-tag-completion nil) ;; dynamically skoped param +(defvar org-tags-overlay (org-make-overlay 1 1)) +(org-detach-overlay org-tags-overlay) + +(defun org-set-tags (&optional arg just-align) + "Set the tags for the current headline. +With prefix ARG, realign all tags in headings in the current buffer." + (interactive "P") + (let* ((re (concat "^" outline-regexp)) + (current (org-get-tags)) + table current-tags inherited-tags ; computed below when needed + tags p0 c0 c1 rpl) + (if arg + (save-excursion + (goto-char (point-min)) + (let (buffer-invisibility-spec) ; Emacs 21 compatibility + (while (re-search-forward re nil t) + (org-set-tags nil t) + (end-of-line 1))) + (message "All tags realigned to column %d" org-tags-column)) + (if just-align + (setq tags current) + ;; Get a new set of tags from the user + (setq table (or org-tag-alist (org-get-buffer-tags)) + org-last-tags-completion-table table + current-tags (org-split-string current ":") + inherited-tags (nreverse + (nthcdr (length current-tags) + (nreverse (org-get-tags-at)))) + tags + (if (or (eq t org-use-fast-tag-selection) + (and org-use-fast-tag-selection + (delq nil (mapcar 'cdr table)))) + (org-fast-tag-selection current-tags inherited-tags table) + (let ((org-add-colon-after-tag-completion t)) + (org-trim + (completing-read "Tags: " 'org-tags-completion-function + nil nil current 'org-tags-history))))) + (while (string-match "[-+&]+" tags) + ;; No boolean logic, just a list + (setq tags (replace-match ":" t t tags)))) + (if (string-match "\\`[\t ]*\\'" tags) + (setq tags "") + (unless (string-match ":$" tags) (setq tags (concat tags ":"))) + (unless (string-match "^:" tags) (setq tags (concat ":" tags)))) + + ;; Insert new tags at the correct column + (beginning-of-line 1) + (if (re-search-forward + (concat "\\([ \t]*" (regexp-quote current) "\\)[ \t]*$") + (point-at-eol) t) + (progn + (if (equal tags "") + (setq rpl "") + (goto-char (match-beginning 0)) + (setq c0 (current-column) p0 (point) + c1 (max (1+ c0) (if (> org-tags-column 0) + org-tags-column + (- (- org-tags-column) (length tags)))) + rpl (concat (make-string (max 0 (- c1 c0)) ?\ ) tags))) + (replace-match rpl) + (and (not (featurep 'xemacs)) c0 (tabify p0 (point))) + tags) + (error "Tags alignment failed"))))) + +(defun org-tags-completion-function (string predicate &optional flag) + (let (s1 s2 rtn (ctable org-last-tags-completion-table) + (confirm (lambda (x) (stringp (car x))))) + (if (string-match "^\\(.*[-+:&|]\\)\\([^-+:&|]*\\)$" string) + (setq s1 (match-string 1 string) + s2 (match-string 2 string)) + (setq s1 "" s2 string)) + (cond + ((eq flag nil) + ;; try completion + (setq rtn (try-completion s2 ctable confirm)) + (if (stringp rtn) + (concat s1 s2 (substring rtn (length s2)) + (if (and org-add-colon-after-tag-completion + (assoc rtn ctable)) + ":" ""))) + ) + ((eq flag t) + ;; all-completions + (all-completions s2 ctable confirm) + ) + ((eq flag 'lambda) + ;; exact match? + (assoc s2 ctable))) + )) + +(defun org-fast-tag-insert (kwd tags face &optional end) + "Insert KDW, and the TAGS, the latter with face FACE. Also inser END." + (insert (format "%-12s" (concat kwd ":")) + (org-add-props (mapconcat 'identity tags " ") nil 'face face) + (or end ""))) + +(defun org-fast-tag-show-exit (flag) + (save-excursion + (goto-line 3) + (if (re-search-forward "[ \t]+Next change exits" (point-at-eol) t) + (replace-match "")) + (when flag + (end-of-line 1) + (move-to-column (- (window-width) 19) t) + (insert (org-add-props " Next change exits" nil 'face 'org-warning))))) + +(defun org-set-current-tags-overlay (current prefix) + (let ((s (concat ":" (mapconcat 'identity current ":") ":"))) + (if (featurep 'xemacs) + (org-overlay-display org-tags-overlay (concat prefix s) + 'secondary-selection) + (put-text-property 0 (length s) 'face '(secondary-selection org-tag) s) + (org-overlay-display org-tags-overlay (concat prefix s))))) + +(defun org-fast-tag-selection (current inherited table) + "Fast tag selection with single keys. +CURRENT is the current list of tags in the headline, INHERITED is the +list of inherited tags, and TABLE is an alist of tags and corresponding keys, +possibly with grouping information. +If the keys are nil, a-z are automatically assigned. +Returns the new tags string, or nil to not change the current settings." + (let* ((maxlen (apply 'max (mapcar + (lambda (x) + (if (stringp (car x)) (string-width (car x)) 0)) + table))) + (buf (current-buffer)) + (buffer-tags nil) + (fwidth (+ maxlen 3 1 3)) + (ncol (/ (- (window-width) 4) fwidth)) + (i-face 'org-done) + (c-face 'org-tag) + tg cnt e c char c1 c2 ntable tbl rtn + ov-start ov-end ov-prefix + (exit-after-next org-fast-tag-selection-single-key) + groups ingroup) + (save-excursion + (beginning-of-line 1) + (if (looking-at ".*[ \t]\\(:[A-Za-z_@0-9:]+:\\)[ \t]*\\(\r\\|$\\)") + (setq ov-start (match-beginning 1) + ov-end (match-end 1) + ov-prefix "") + (setq ov-start (1- (point-at-eol)) + ov-end (1+ ov-start)) + (skip-chars-forward "^\n\r") + (setq ov-prefix + (concat + (buffer-substring (1- (point)) (point)) + (if (> (current-column) org-tags-column) + " " + (make-string (- org-tags-column (current-column)) ?\ )))))) + (org-move-overlay org-tags-overlay ov-start ov-end) + (save-window-excursion + ;; FIXME: would it be better to keep the other windows? + (delete-other-windows) + (split-window-vertically) + (switch-to-buffer-other-window (get-buffer-create " *Org tags*")) + (erase-buffer) + (org-fast-tag-insert "Inherited" inherited i-face "\n") + (org-fast-tag-insert "Current" current c-face "\n\n") + (org-fast-tag-show-exit exit-after-next) + (org-set-current-tags-overlay current ov-prefix) + (setq tbl table char ?a cnt 0) + (while (setq e (pop tbl)) + (cond + ((equal e '(:startgroup)) + (push '() groups) (setq ingroup t) + (when (not (= cnt 0)) + (setq cnt 0) + (insert "\n")) + (insert "{ ")) + ((equal e '(:endgroup)) + (setq ingroup nil cnt 0) + (insert "}\n")) + (t + (setq tg (car e) c2 nil) + (if (cdr e) + (setq c (cdr e)) + ;; automatically assign a character. + (setq c1 (string-to-char + (downcase (substring + tg (if (= (string-to-char tg) ?@) 1 0))))) + (if (or (rassoc c1 ntable) (rassoc c1 table)) + (while (or (rassoc char ntable) (rassoc char table)) + (setq char (1+ char))) + (setq c2 c1)) + (setq c (or c2 char))) + (if ingroup (push tg (car groups))) + (setq tg (org-add-props tg nil 'face + (cond + ((member tg current) c-face) + ((member tg inherited) i-face) + (t nil)))) + (if (and (= cnt 0) (not ingroup)) (insert " ")) + (insert "[" c "] " tg (make-string + (- fwidth 4 (length tg)) ?\ )) + (push (cons tg c) ntable) + (when (= (setq cnt (1+ cnt)) ncol) + (insert "\n") + (if ingroup (insert " ")) + (setq cnt 0))))) + (setq ntable (nreverse ntable)) + (insert "\n") + (goto-char (point-min)) + (if (fboundp 'fit-window-to-buffer) (fit-window-to-buffer)) + (setq rtn + (catch 'exit + (while t + (message "[a-z..]:Toggle [SPC]:clear [RET]:accept [TAB]:free [C-c]: multi%s" + (if groups " [!] no groups" "")) + (setq c (let ((inhibit-quit t)) (read-char-exclusive))) + (cond + ((= c ?\r) (throw 'exit t)) + ((= c ?!) + (setq groups nil) + (goto-char (point-min)) + (while (re-search-forward "[{}]" nil t) (replace-match " "))) + ((= c ?\C-c) + (org-fast-tag-show-exit + (setq exit-after-next (not exit-after-next)))) + ((or (= c ?\C-g) + (and (= c ?q) (not (rassoc c ntable)))) + (org-detach-overlay org-tags-overlay) + (setq quit-flag t)) + ((= c ?\ ) + (setq current nil) + (if exit-after-next (setq exit-after-next 'now))) + ((= c ?\t) + (condition-case nil + (setq tg (completing-read + "Tag: " + (or buffer-tags + (with-current-buffer buf + (org-get-buffer-tags))))) + (quit (setq tg ""))) + (when (string-match "\\S-" tg) + (add-to-list 'buffer-tags (list tg)) + (if (member tg current) + (setq current (delete tg current)) + (push tg current))) + (if exit-after-next (setq exit-after-next 'now))) + ((setq e (rassoc c ntable) tg (car e)) + (if (member tg current) + (setq current (delete tg current)) + (loop for g in groups do + (if (member tg g) + (mapcar (lambda (x) + (setq current (delete x current))) + g))) + (push tg current)) + (if exit-after-next (setq exit-after-next 'now)))) + + ;; Create a sorted list + (setq current + (sort current + (lambda (a b) + (assoc b (cdr (memq (assoc a ntable) ntable)))))) + (if (eq exit-after-next 'now) (throw 'exit t)) + (goto-char (point-min)) + (beginning-of-line 2) + (delete-region (point) (point-at-eol)) + (org-fast-tag-insert "Current" current c-face) + (org-set-current-tags-overlay current ov-prefix) + (while (re-search-forward "\\[.\\] \\([a-zA-Z0-9_@]+\\)" nil t) + (setq tg (match-string 1)) + (add-text-properties (match-beginning 1) (match-end 1) + (list 'face + (cond + ((member tg current) c-face) + ((member tg inherited) i-face) + (t nil))))) + (goto-char (point-min))))) + (org-detach-overlay org-tags-overlay) + (if rtn + (mapconcat 'identity current ":") + nil)))) + +(defun org-get-tags () + "Get the TAGS string in the current headline." + (unless (org-on-heading-p t) + (error "Not on a heading")) + (save-excursion + (beginning-of-line 1) + (if (looking-at ".*[ \t]\\(:[A-Za-z_@0-9:]+:\\)[ \t]*\\(\r\\|$\\)") + (org-match-string-no-properties 1) + ""))) + +(defun org-get-buffer-tags () + "Get a table of all tags used in the buffer, for completion." + (let (tags) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "[ \t]:\\([A-Za-z_@0-9:]+\\):[ \t\r\n]" nil t) + (mapc (lambda (x) (add-to-list 'tags x)) + (org-split-string (org-match-string-no-properties 1) ":")))) + (mapcar 'list tags))) + ;;;; Timestamps (defvar org-last-changed-timestamp nil) +(defvar org-time-was-given) ; dynamically scoped parameter +(defvar org-ts-what) ; dynamically scoped parameter (defun org-time-stamp (arg) "Prompt for a date/time and insert a time stamp. @@ -6224,6 +10699,9 @@ So these are more for recording a certain time/date." (org-overlay-put org-date-ovl 'face 'org-warning) (org-detach-overlay org-date-ovl) +(defvar org-ans1) ; dynamically scoped parameter +(defvar org-ans2) ; dynamically scoped parameter + (defun org-read-date (&optional with-time to-time from-string) "Read a date and make things smooth for the user. The prompt will suggest to enter an ISO date, but you can also enter anything @@ -6278,7 +10756,7 @@ used to insert the time stamp into the buffer to include the time." (timestr (format-time-string (if with-time "%Y-%m-%d %H:%M" "%Y-%m-%d") default-time)) (prompt (format "YYYY-MM-DD [%s]: " timestr)) - ans ans1 ans2 (deltadays 0) + ans org-ans1 org-ans2 (deltadays 0) second minute hour day month year tl wday wday1) (cond @@ -6328,7 +10806,7 @@ used to insert the time stamp into the buffer to include the time." (use-local-map map) (setq ans (read-string prompt "" nil nil)) (if (not (string-match "\\S-" ans)) (setq ans nil)) - (setq ans (or ans1 ans ans2))) + (setq ans (or org-ans1 ans org-ans2))) (use-local-map old-map)))))) (t ; Naked prompt only (setq ans (read-string prompt "" nil timestr)))) @@ -6375,14 +10853,14 @@ used to insert the time stamp into the buffer to include the time." (defun org-eval-in-calendar (form) "Eval FORM in the calendar window and return to current window. -Also, store the cursor date in variable ans2." +Also, store the cursor date in variable org-ans2." (let ((sw (selected-window))) (select-window (get-buffer-window "*Calendar*")) (eval form) (when (calendar-cursor-to-date) (let* ((date (calendar-cursor-to-date)) (time (encode-time 0 0 0 (nth 1 date) (nth 0 date) (nth 2 date)))) - (setq ans2 (format-time-string "%Y-%m-%d" time)))) + (setq org-ans2 (format-time-string "%Y-%m-%d" time)))) (org-move-overlay org-date-ovl (1- (point)) (1+ (point)) (current-buffer)) (select-window sw))) @@ -6393,7 +10871,7 @@ This is used by `org-read-date' in a temporary keymap for the calendar buffer." (when (calendar-cursor-to-date) (let* ((date (calendar-cursor-to-date)) (time (encode-time 0 0 0 (nth 1 date) (nth 0 date) (nth 2 date)))) - (setq ans1 (format-time-string "%Y-%m-%d" time))) + (setq org-ans1 (format-time-string "%Y-%m-%d" time))) (if (active-minibuffer-window) (exit-minibuffer)))) (defun org-insert-time-stamp (time &optional with-hm inactive pre post) @@ -6508,7 +10986,7 @@ This is used by `org-read-date' in a temporary keymap for the calendar buffer." (when (calendar-cursor-to-date) (let* ((date (calendar-cursor-to-date)) (time (encode-time 0 0 0 (nth 1 date) (nth 0 date) (nth 2 date)))) - (setq ans1 (format-time-string "%Y-%m-%d" time))) + (setq org-ans1 (format-time-string "%Y-%m-%d" time))) (if (active-minibuffer-window) (exit-minibuffer)))) (defun org-check-deadlines (ndays) @@ -6805,7 +11283,7 @@ If necessary, clock-out of the currently active clock." (indent-relative) (insert org-clock-string " ") (setq ts (org-insert-time-stamp (current-time) 'with-hm 'inactive)) - (move-marker org-clock-marker (point)) + (move-marker org-clock-marker (point) (buffer-base-buffer)) (message "Clock started at %s" ts)))) (defun org-clock-out (&optional fail-quietly) @@ -7183,7 +11661,7 @@ FIXME: describe the elements." ;;;; Agenda, and Diary Integration -;;; Define the mode +;;; Define the Org-agenda-mode (defvar org-agenda-mode-map (make-sparse-keymap) "Keymap for `org-agenda-mode'.") @@ -7525,6 +12003,7 @@ L Timeline for current buffer # List stuck projects (!=configure) ((stringp type) type) ((eq type 'tags) "Tags query") ((eq type 'todo) "TODO keyword") + ((eq type 'tags-tree) "Tags (TODO)") ((eq type 'tags-tree) "Tags tree") ((eq type 'todo-tree) "TODO kwd tree") ((eq type 'occur-tree) "Occur tree") @@ -7679,6 +12158,8 @@ before running the agenda command." (fit-window-to-buffer nil (/ (* (frame-height) 3) 4) (/ (frame-height) 2)))) +;;; Agenda file list + (defun org-agenda-files (&optional unrestricted) "Get the list of agenda files. Optional UNRESTRICTED means return the full list even if a restriction @@ -7689,8 +12170,6 @@ is currently in place." ((listp org-agenda-files) org-agenda-files) (t (error "Invalid value of `org-agenda-files'")))) -(defvar org-window-configuration) - (defun org-edit-agenda-file-list () "Edit the list of agenda files. Depending on setup, this either uses customize to edit the variable @@ -7732,6 +12211,193 @@ the buffer and restores the previous window configuration." (insert-file-contents org-agenda-files) (org-split-string (buffer-string) "[ \t\r\n]*?[\r\n][ \t\r\n]*")))) + +;;;###autoload +(defun org-cycle-agenda-files () + "Cycle through the files in `org-agenda-files'. +If the current buffer visits an agenda file, find the next one in the list. +If the current buffer does not, find the first agenda file." + (interactive) + (let* ((fs (org-agenda-files t)) + (files (append fs (list (car fs)))) + (tcf (if buffer-file-name (file-truename buffer-file-name))) + file) + (unless files (error "No agenda files")) + (catch 'exit + (while (setq file (pop files)) + (if (equal (file-truename file) tcf) + (when (car files) + (find-file (car files)) + (throw 'exit t)))) + (find-file (car fs))))) + +(defun org-agenda-file-to-end () + "Move/add the current file to the end of the agenda file list. +If the file is not present in the list, it is appended to the list. If it is +present, it is moved there." + (interactive) + (org-agenda-file-to-front 'to-end)) + +(defun org-agenda-file-to-front (&optional to-end) + "Move/add the current file to the top of the agenda file list. +If the file is not present in the list, it is added to the front. If it is +present, it is moved there. With optional argument TO-END, add/move to the +end of the list." + (interactive "P") + (let ((file-alist (mapcar (lambda (x) + (cons (file-truename x) x)) + (org-agenda-files t))) + (ctf (file-truename buffer-file-name)) + x had) + (setq x (assoc ctf file-alist) had x) + + (if (not x) (setq x (cons ctf (abbreviate-file-name buffer-file-name)))) + (if to-end + (setq file-alist (append (delq x file-alist) (list x))) + (setq file-alist (cons x (delq x file-alist)))) + (org-store-new-agenda-file-list (mapcar 'cdr file-alist)) + (org-install-agenda-files-menu) + (message "File %s to %s of agenda file list" + (if had "moved" "added") (if to-end "end" "front")))) + +(defun org-remove-file (&optional file) + "Remove current file from the list of files in variable `org-agenda-files'. +These are the files which are being checked for agenda entries. +Optional argument FILE means, use this file instead of the current." + (interactive) + (let* ((file (or file buffer-file-name)) + (true-file (file-truename file)) + (afile (abbreviate-file-name file)) + (files (delq nil (mapcar + (lambda (x) + (if (equal true-file + (file-truename x)) + nil x)) + (org-agenda-files t))))) + (if (not (= (length files) (length (org-agenda-files t)))) + (progn + (org-store-new-agenda-file-list files) + (org-install-agenda-files-menu) + (message "Removed file: %s" afile)) + (message "File was not in list: %s" afile)))) + +(defun org-file-menu-entry (file) + (vector file (list 'find-file file) t)) + +(defun org-check-agenda-file (file) + "Make sure FILE exists. If not, ask user what to do." + (when (not (file-exists-p file)) + (message "non-existent file %s. [R]emove from list or [A]bort?" + (abbreviate-file-name file)) + (let ((r (downcase (read-char-exclusive)))) + (cond + ((equal r ?r) + (org-remove-file file) + (throw 'nextfile t)) + (t (error "Abort")))))) + +;;; Agenda prepare and finalize + +(defvar org-agenda-multi nil) ; dynammically scoped +(defvar org-agenda-buffer-name "*Org Agenda*") +(defvar org-pre-agenda-window-conf nil) +(defun org-prepare-agenda () + (if org-agenda-multi + (progn + (setq buffer-read-only nil) + (goto-char (point-max)) + (unless (= (point) 1) + (insert "\n" (make-string (window-width) ?=) "\n")) + (narrow-to-region (point) (point-max))) + (org-agenda-maybe-reset-markers 'force) + (org-prepare-agenda-buffers (org-agenda-files)) + (let* ((abuf (get-buffer-create org-agenda-buffer-name)) + (awin (get-buffer-window abuf))) + (cond + ((equal (current-buffer) abuf) nil) + (awin (select-window awin)) + ((not (setq org-pre-agenda-window-conf (current-window-configuration)))) + ((equal org-agenda-window-setup 'current-window) + (switch-to-buffer abuf)) + ((equal org-agenda-window-setup 'other-window) + (switch-to-buffer-other-window abuf)) + ((equal org-agenda-window-setup 'other-frame) + (switch-to-buffer-other-frame abuf)) + ((equal org-agenda-window-setup 'reorganize-frame) + (delete-other-windows) + (switch-to-buffer-other-window abuf)))) + (setq buffer-read-only nil) + (erase-buffer) + (org-agenda-mode)) + (setq buffer-read-only nil)) + +(defun org-finalize-agenda () + "Finishing touch for the agenda buffer, called just before displaying it." + (unless org-agenda-multi + (org-agenda-align-tags) + (save-excursion + (let ((buffer-read-only)) + (goto-char (point-min)) + (while (org-activate-bracket-links (point-max)) + (add-text-properties (match-beginning 0) (match-end 0) + '(face org-link)))) + (run-hooks 'org-finalize-agenda-hook)))) + +(defun org-prepare-agenda-buffers (files) + "Create buffers for all agenda files, protect archived trees and comments." + (interactive) + (let ((pa '(:org-archived t)) + (pc '(:org-comment t)) + (pall '(:org-archived t :org-comment t)) + (rea (concat ":" org-archive-tag ":")) + bmp file re) + (save-excursion + (while (setq file (pop files)) + (org-check-agenda-file file) + (set-buffer (org-get-agenda-file-buffer file)) + (widen) + (setq bmp (buffer-modified-p)) + (save-excursion + (remove-text-properties (point-min) (point-max) pall) + (when org-agenda-skip-archived-trees + (goto-char (point-min)) + (while (re-search-forward rea nil t) + (if (org-on-heading-p) + (add-text-properties (point-at-bol) (org-end-of-subtree t) pa)))) + (goto-char (point-min)) + (setq re (concat "^\\*+ +" org-comment-string "\\>")) + (while (re-search-forward re nil t) + (add-text-properties + (match-beginning 0) (org-end-of-subtree t) pc))) + (set-buffer-modified-p bmp))))) + +(defvar org-agenda-skip-function nil + "Function to be called at each match during agenda construction. +If this function return nil, the current match should not be skipped. +Otherwise, the function must return a position from where the search +should be continued. +Never set this variable using `setq' or so, because then it will apply +to all future agenda commands. Instead, bind it with `let' to scope +it dynamically into the agenda-constructing command.") + +(defun org-agenda-skip () + "Throw to `:skip' in places that should be skipped." + (let ((p (point-at-bol)) to) + (and org-agenda-skip-archived-trees + (get-text-property p :org-archived) + (org-end-of-subtree t) + (throw :skip t)) + (and (get-text-property p :org-comment) + (org-end-of-subtree t) + (throw :skip t)) + (if (equal (char-after p) ?#) (throw :skip t)) + (when (and (functionp org-agenda-skip-function) + (setq to (save-excursion + (save-match-data + (funcall org-agenda-skip-function))))) + (goto-char to) + (throw :skip t)))) + (defvar org-agenda-markers nil "List of all currently active markers created by `org-agenda'.") (defvar org-agenda-last-marker-time (time-to-seconds (current-time)) @@ -7782,6 +12448,36 @@ When a buffer is unmodified, it is just killed. When modified, it is saved (with-current-buffer buf (save-buffer))) (kill-buffer buf)))) +(defvar org-category-table nil) +(defun org-get-category-table () + "Get the table of categories and positions in current buffer." + (let (tbl) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "\\(^\\|\r\\)#\\+CATEGORY:[ \t]*\\(.*\\)" nil t) + (push (cons (point) (org-trim (match-string 2))) tbl))) + tbl)) + +(defun org-get-category (&optional pos) + "Get the category applying to position POS." + (if (not org-category-table) + (cond + ((null org-category) + (setq org-category + (if buffer-file-name + (file-name-sans-extension + (file-name-nondirectory buffer-file-name)) + "???"))) + ((symbolp org-category) (symbol-name org-category)) + (t org-category)) + (let ((tbl org-category-table) + (pos (or pos (point)))) + (while (and tbl (> (caar tbl) pos)) + (pop tbl)) + (or (cdar tbl) (cdr (nth (1- (length org-category-table)) + org-category-table)))))) +;;; Agenda timeline + (defun org-timeline (&optional include-all) "Show a time-sorted view of the entries in the current org file. Only entries with a time stamp of today or later will be listed. With @@ -7861,10 +12557,54 @@ dates." (when (not org-select-agenda-window) (select-window win) (goto-char pos1)))) +(defun org-get-all-dates (beg end &optional no-ranges force-today inactive empty) + "Return a list of all relevant day numbers from BEG to END buffer positions. +If NO-RANGES is non-nil, include only the start and end dates of a range, +not every single day in the range. If FORCE-TODAY is non-nil, make +sure that TODAY is included in the list. If INACTIVE is non-nil, also +inactive time stamps (those in square brackets) are included. +When EMPTY is non-nil, also include days without any entries." + (let ((re (if inactive org-ts-regexp-both org-ts-regexp)) + dates dates1 date day day1 day2 ts1 ts2) + (if force-today + (setq dates (list (time-to-days (current-time))))) + (save-excursion + (goto-char beg) + (while (re-search-forward re end t) + (setq day (time-to-days (org-time-string-to-time + (substring (match-string 1) 0 10)))) + (or (memq day dates) (push day dates))) + (unless no-ranges + (goto-char beg) + (while (re-search-forward org-tr-regexp end t) + (setq ts1 (substring (match-string 1) 0 10) + ts2 (substring (match-string 2) 0 10) + day1 (time-to-days (org-time-string-to-time ts1)) + day2 (time-to-days (org-time-string-to-time ts2))) + (while (< (setq day1 (1+ day1)) day2) + (or (memq day1 dates) (push day1 dates))))) + (setq dates (sort dates '<)) + (when empty + (while (setq day (pop dates)) + (setq day2 (car dates)) + (push day dates1) + (when (and day2 empty) + (if (or (eq empty t) + (and (numberp empty) (<= (- day2 day) empty))) + (while (< (setq day (1+ day)) day2) + (push (list day) dates1)) + (push (cons :omitted (- day2 day)) dates1)))) + (setq dates (nreverse dates1))) + dates))) + +;;; Agenda Daily/Weekly (defvar org-agenda-overriding-arguments nil) ; dynamically scoped parameter (defvar org-agenda-last-arguments nil "The arguments of the previous call to org-agenda") +(defvar org-starting-day nil) ; local variable in the agenda buffer +(defvar org-include-all-loc nil) ; local variable + ;;;###autoload (defun org-agenda-list (&optional include-all start-day ndays) @@ -7918,8 +12658,8 @@ NDAYS defaults to `org-agenda-ndays'." (setq ndays (1- ndays))) (setq day-numbers (nreverse day-numbers)) (org-prepare-agenda) - (org-set-local 'starting-day (car day-numbers)) - (org-set-local 'include-all-loc include-all) + (org-set-local 'org-starting-day (car day-numbers)) + (org-set-local 'org-include-all-loc include-all) (when (and (or include-all org-agenda-include-all-todo) (member today day-numbers)) (setq files thefiles @@ -7999,7 +12739,10 @@ NDAYS defaults to `org-agenda-ndays'." (if (not org-select-agenda-window) (select-window win)) (message ""))) +;;; Agenda TODO list + (defvar org-select-this-todo-keyword nil) +(defvar org-last-arg nil) ;;;###autoload (defun org-todo-list (arg) @@ -8028,10 +12771,10 @@ for a keyword. A numeric prefix directly selects the Nth keyword in nil t))) (and (equal 0 arg) (setq org-select-this-todo-keyword nil)) (org-prepare-agenda) - (org-set-local 'last-arg arg) + (org-set-local 'org-last-arg arg) (org-set-local 'org-todo-keywords kwds) (setq org-agenda-redo-command - '(org-todo-list (or current-prefix-arg last-arg))) + '(org-todo-list (or current-prefix-arg org-last-arg))) (setq files (org-agenda-files) rtnall nil) (while (setq file (pop files)) @@ -8067,7 +12810,76 @@ for a keyword. A numeric prefix directly selects the Nth keyword in (setq buffer-read-only t) (if (not org-select-agenda-window) (select-window win)))) -;;; Finding stuck projects +;;; Agenda tags match + +;;;###autoload +(defun org-tags-view (&optional todo-only match) + "Show all headlines for all `org-agenda-files' matching a TAGS criterion. +The prefix arg TODO-ONLY limits the search to TODO entries." + (interactive "P") + (org-compile-prefix-format 'tags) + (org-set-sorting-strategy 'tags) + (let* ((org-tags-match-list-sublevels + (if todo-only t org-tags-match-list-sublevels)) + (win (selected-window)) + (completion-ignore-case t) + rtn rtnall files file pos matcher + buffer) + (setq matcher (org-make-tags-matcher match) + match (car matcher) matcher (cdr matcher)) + (org-prepare-agenda) + (setq org-agenda-redo-command + (list 'org-tags-view (list 'quote todo-only) + (list 'if 'current-prefix-arg nil match))) + (setq files (org-agenda-files) + rtnall nil) + (while (setq file (pop files)) + (catch 'nextfile + (org-check-agenda-file file) + (setq buffer (if (file-exists-p file) + (org-get-agenda-file-buffer file) + (error "No such file %s" file))) + (if (not buffer) + ;; If file does not exist, merror message to agenda + (setq rtn (list + (format "ORG-AGENDA-ERROR: No such org-file %s" file)) + rtnall (append rtnall rtn)) + (with-current-buffer buffer + (unless (org-mode-p) + (error "Agenda file %s is not in `org-mode'" file)) + (setq org-category-table (org-get-category-table)) + (save-excursion + (save-restriction + (if org-agenda-restrict + (narrow-to-region org-agenda-restrict-begin + org-agenda-restrict-end) + (widen)) + (setq rtn (org-scan-tags 'agenda matcher todo-only)) + (setq rtnall (append rtnall rtn)))))))) + (if org-agenda-overriding-header + (insert (org-add-props (copy-sequence org-agenda-overriding-header) + nil 'face 'org-level-3) "\n") + (insert "Headlines with TAGS match: ") + (add-text-properties (point-min) (1- (point)) + (list 'face 'org-level-3)) + (setq pos (point)) + (insert match "\n") + (add-text-properties pos (1- (point)) (list 'face 'org-warning)) + (setq pos (point)) + (unless org-agenda-multi + (insert "Press `C-u r' to search again with new search string\n")) + (add-text-properties pos (1- (point)) (list 'face 'org-level-3))) + (when rtnall + (insert (org-finalize-agenda-entries rtnall) "\n")) + (goto-char (point-min)) + (org-fit-agenda-window) + (add-text-properties (point-min) (point-max) '(org-agenda-type tags)) + (org-finalize-agenda) + (setq buffer-read-only t) + (if (not org-select-agenda-window) (select-window win)))) + +;;; Agenda Finding stuck projects + (defvar org-agenda-skip-regexp nil "Regular expression used in skipping subtrees for the agenda. This is basically a temporary global variable that can be set and then @@ -8088,7 +12900,7 @@ to skip this subtree. This is a function that can be put into (setq skip (re-search-forward org-agenda-skip-regexp end t))) (and skip end)))) -(defun org-agenda-list-stuck-projects (match) +(defun org-agenda-list-stuck-projects (&rest ignore) "Create agenda view for projects that are stuck. Stuck projects are project that have no next actions. For the definitions of what a project is and how to check if it stuck, customize the variable @@ -8116,239 +12928,8 @@ MATCH is being ignored." (t (error "No information how to identify unstuck projects")))) (org-tags-view nil matcher))) -(defun org-check-agenda-file (file) - "Make sure FILE exists. If not, ask user what to do." - (when (not (file-exists-p file)) - (message "non-existent file %s. [R]emove from list or [A]bort?" - (abbreviate-file-name file)) - (let ((r (downcase (read-char-exclusive)))) - (cond - ((equal r ?r) - (org-remove-file file) - (throw 'nextfile t)) - (t (error "Abort")))))) - -(defun org-agenda-check-type (error &rest types) - "Check if agenda buffer is of allowed type. -If ERROR is non-nil, throw an error, otherwise just return nil." - (if (memq org-agenda-type types) - t - (if error - (error "Not allowed in %s-type agenda buffers" org-agenda-type) - nil))) - -(defun org-agenda-quit () - "Exit agenda by removing the window or the buffer." - (interactive) - (let ((buf (current-buffer))) - (if (not (one-window-p)) (delete-window)) - (kill-buffer buf) - (org-agenda-maybe-reset-markers 'force)) - ;; Maybe restore the pre-agenda window configuration. - (and org-agenda-restore-windows-after-quit - (not (eq org-agenda-window-setup 'other-frame)) - org-pre-agenda-window-conf - (set-window-configuration org-pre-agenda-window-conf))) - -(defun org-agenda-exit () - "Exit agenda by removing the window or the buffer. -Also kill all Org-mode buffers which have been loaded by `org-agenda'. -Org-mode buffers visited directly by the user will not be touched." - (interactive) - (org-release-buffers org-agenda-new-buffers) - (setq org-agenda-new-buffers nil) - (org-agenda-quit)) - -(defun org-save-all-org-buffers () - "Save all Org-mode buffers without user confirmation." - (interactive) - (message "Saving all Org-mode buffers...") - (save-some-buffers t 'org-mode-p) - (message "Saving all Org-mode buffers... done")) - -(defun org-agenda-redo () - "Rebuild Agenda. -When this is the global TODO list, a prefix argument will be interpreted." - (interactive) - (let* ((org-agenda-keep-modes t) - (line (org-current-line)) - (window-line (- line (org-current-line (window-start))))) - (message "Rebuilding agenda buffer...") - (eval org-agenda-redo-command) - (setq org-agenda-undo-list nil - org-agenda-pending-undo-list nil) - (message "Rebuilding agenda buffer...done") - (goto-line line) - (recenter window-line))) - -(defun org-agenda-goto-today () - "Go to today." - (interactive) - (org-agenda-check-type t 'timeline 'agenda) - (let ((tdpos (text-property-any (point-min) (point-max) 'org-today t))) - (cond - (tdpos (goto-char tdpos)) - ((eq org-agenda-type 'agenda) - (let ((org-agenda-overriding-arguments org-agenda-last-arguments)) - (setf (nth 1 org-agenda-overriding-arguments) nil) - (org-agenda-redo) - (org-agenda-find-today-or-agenda))) - (t (error "Cannot find today"))))) - -(defun org-agenda-find-today-or-agenda () - (goto-char - (or (text-property-any (point-min) (point-max) 'org-today t) - (text-property-any (point-min) (point-max) 'org-agenda-type 'agenda) - (point-min)))) - -(defun org-agenda-later (arg) - "Go forward in time by `org-agenda-ndays' days. -With prefix ARG, go forward that many times `org-agenda-ndays'." - (interactive "p") - (org-agenda-check-type t 'agenda) - (let ((org-agenda-overriding-arguments - (list (car org-agenda-last-arguments) - (+ starting-day (* arg org-agenda-ndays)) - nil t))) - (org-agenda-redo) - (org-agenda-find-today-or-agenda))) - -(defun org-agenda-earlier (arg) - "Go back in time by `org-agenda-ndays' days. -With prefix ARG, go back that many times `org-agenda-ndays'." - (interactive "p") - (org-agenda-check-type t 'agenda) - (let ((org-agenda-overriding-arguments - (list (car org-agenda-last-arguments) - (- starting-day (* arg org-agenda-ndays)) - nil t))) - (org-agenda-redo) - (org-agenda-find-today-or-agenda))) - -(defun org-agenda-week-view () - "Switch to weekly view for agenda." - (interactive) - (org-agenda-check-type t 'agenda) - (if (= org-agenda-ndays 7) - (error "This is already the week view")) - (setq org-agenda-ndays 7) - (let ((org-agenda-overriding-arguments - (list (car org-agenda-last-arguments) - (or (get-text-property (point) 'day) - starting-day) - nil t))) - (org-agenda-redo) - (org-agenda-find-today-or-agenda)) - (org-agenda-set-mode-name) - (message "Switched to week view")) - -(defun org-agenda-day-view () - "Switch to daily view for agenda." - (interactive) - (org-agenda-check-type t 'agenda) - (if (= org-agenda-ndays 1) - (error "This is already the day view")) - (setq org-agenda-ndays 1) - (let ((org-agenda-overriding-arguments - (list (car org-agenda-last-arguments) - (or (get-text-property (point) 'day) - starting-day) - nil t))) - (org-agenda-redo) - (org-agenda-find-today-or-agenda)) - (org-agenda-set-mode-name) - (message "Switched to day view")) - -(defun org-agenda-next-date-line (&optional arg) - "Jump to the next line indicating a date in agenda buffer." - (interactive "p") - (org-agenda-check-type t 'agenda 'timeline) - (beginning-of-line 1) - (if (looking-at "^\\S-") (forward-char 1)) - (if (not (re-search-forward "^\\S-" nil t arg)) - (progn - (backward-char 1) - (error "No next date after this line in this buffer"))) - (goto-char (match-beginning 0))) - -(defun org-agenda-previous-date-line (&optional arg) - "Jump to the previous line indicating a date in agenda buffer." - (interactive "p") - (org-agenda-check-type t 'agenda 'timeline) - (beginning-of-line 1) - (if (not (re-search-backward "^\\S-" nil t arg)) - (error "No previous date before this line in this buffer"))) - -;; Initialize the highlight -(defvar org-hl (org-make-overlay 1 1)) -(org-overlay-put org-hl 'face 'highlight) - -(defun org-highlight (begin end &optional buffer) - "Highlight a region with overlay." - (funcall (if (featurep 'xemacs) 'set-extent-endpoints 'move-overlay) - org-hl begin end (or buffer (current-buffer)))) - -(defun org-unhighlight () - "Detach overlay INDEX." - (funcall (if (featurep 'xemacs) 'detach-extent 'delete-overlay) org-hl)) - - -(defun org-agenda-follow-mode () - "Toggle follow mode in an agenda buffer." - (interactive) - (setq org-agenda-follow-mode (not org-agenda-follow-mode)) - (org-agenda-set-mode-name) - (message "Follow mode is %s" - (if org-agenda-follow-mode "on" "off"))) - -(defun org-agenda-log-mode () - "Toggle log mode in an agenda buffer." - (interactive) - (org-agenda-check-type t 'agenda 'timeline) - (setq org-agenda-show-log (not org-agenda-show-log)) - (org-agenda-set-mode-name) - (org-agenda-redo) - (message "Log mode is %s" - (if org-agenda-show-log "on" "off"))) - -(defun org-agenda-toggle-diary () - "Toggle diary inclusion in an agenda buffer." - (interactive) - (org-agenda-check-type t 'agenda) - (setq org-agenda-include-diary (not org-agenda-include-diary)) - (org-agenda-redo) - (org-agenda-set-mode-name) - (message "Diary inclusion turned %s" - (if org-agenda-include-diary "on" "off"))) - -(defun org-agenda-toggle-time-grid () - "Toggle time grid in an agenda buffer." - (interactive) - (org-agenda-check-type t 'agenda) - (setq org-agenda-use-time-grid (not org-agenda-use-time-grid)) - (org-agenda-redo) - (org-agenda-set-mode-name) - (message "Time-grid turned %s" - (if org-agenda-use-time-grid "on" "off"))) - -(defun org-agenda-set-mode-name () - "Set the mode name to indicate all the small mode settings." - (setq mode-name - (concat "Org-Agenda" - (if (equal org-agenda-ndays 1) " Day" "") - (if (equal org-agenda-ndays 7) " Week" "") - (if org-agenda-follow-mode " Follow" "") - (if org-agenda-include-diary " Diary" "") - (if org-agenda-use-time-grid " Grid" "") - (if org-agenda-show-log " Log" ""))) - (force-mode-line-update)) -(defun org-agenda-post-command-hook () - (and (eolp) (not (bolp)) (backward-char 1)) - (setq org-agenda-type (get-text-property (point) 'org-agenda-type)) - (if (and org-agenda-follow-mode - (get-text-property (point) 'org-marker)) - (org-agenda-show))) +;;; Diary integration (defvar org-disable-agenda-to-diary nil) ;Dynamically-scoped param. @@ -8445,118 +13026,6 @@ Needed to avoid empty dates which mess up holiday display." (add-to-diary-list original-date "Org-mode dummy" "" nil))))) ;;;###autoload -(defun org-cycle-agenda-files () - "Cycle through the files in `org-agenda-files'. -If the current buffer visits an agenda file, find the next one in the list. -If the current buffer does not, find the first agenda file." - (interactive) - (let* ((fs (org-agenda-files t)) - (files (append fs (list (car fs)))) - (tcf (if buffer-file-name (file-truename buffer-file-name))) - file) - (unless files (error "No agenda files")) - (catch 'exit - (while (setq file (pop files)) - (if (equal (file-truename file) tcf) - (when (car files) - (find-file (car files)) - (throw 'exit t)))) - (find-file (car fs))))) - -(defun org-agenda-file-to-end () - "Move/add the current file to the end of the agenda file list. -If the file is not present in the list, it is appended to the list. If it is -present, it is moved there." - (interactive) - (org-agenda-file-to-front 'to-end)) - -(defun org-agenda-file-to-front (&optional to-end) - "Move/add the current file to the top of the agenda file list. -If the file is not present in the list, it is added to the front. If it is -present, it is moved there. With optional argument TO-END, add/move to the -end of the list." - (interactive "P") - (let ((file-alist (mapcar (lambda (x) - (cons (file-truename x) x)) - (org-agenda-files t))) - (ctf (file-truename buffer-file-name)) - x had) - (setq x (assoc ctf file-alist) had x) - - (if (not x) (setq x (cons ctf (abbreviate-file-name buffer-file-name)))) - (if to-end - (setq file-alist (append (delq x file-alist) (list x))) - (setq file-alist (cons x (delq x file-alist)))) - (org-store-new-agenda-file-list (mapcar 'cdr file-alist)) - (org-install-agenda-files-menu) - (message "File %s to %s of agenda file list" - (if had "moved" "added") (if to-end "end" "front")))) - -(defun org-remove-file (&optional file) - "Remove current file from the list of files in variable `org-agenda-files'. -These are the files which are being checked for agenda entries. -Optional argument FILE means, use this file instead of the current." - (interactive) - (let* ((file (or file buffer-file-name)) - (true-file (file-truename file)) - (afile (abbreviate-file-name file)) - (files (delq nil (mapcar - (lambda (x) - (if (equal true-file - (file-truename x)) - nil x)) - (org-agenda-files t))))) - (if (not (= (length files) (length (org-agenda-files t)))) - (progn - (org-store-new-agenda-file-list files) - (org-install-agenda-files-menu) - (message "Removed file: %s" afile)) - (message "File was not in list: %s" afile)))) - -(defun org-file-menu-entry (file) - (vector file (list 'find-file file) t)) - -(defun org-get-all-dates (beg end &optional no-ranges force-today inactive empty) - "Return a list of all relevant day numbers from BEG to END buffer positions. -If NO-RANGES is non-nil, include only the start and end dates of a range, -not every single day in the range. If FORCE-TODAY is non-nil, make -sure that TODAY is included in the list. If INACTIVE is non-nil, also -inactive time stamps (those in square brackets) are included. -When EMPTY is non-nil, also include days without any entries." - (let ((re (if inactive org-ts-regexp-both org-ts-regexp)) - dates dates1 date day day1 day2 ts1 ts2) - (if force-today - (setq dates (list (time-to-days (current-time))))) - (save-excursion - (goto-char beg) - (while (re-search-forward re end t) - (setq day (time-to-days (org-time-string-to-time - (substring (match-string 1) 0 10)))) - (or (memq day dates) (push day dates))) - (unless no-ranges - (goto-char beg) - (while (re-search-forward org-tr-regexp end t) - (setq ts1 (substring (match-string 1) 0 10) - ts2 (substring (match-string 2) 0 10) - day1 (time-to-days (org-time-string-to-time ts1)) - day2 (time-to-days (org-time-string-to-time ts2))) - (while (< (setq day1 (1+ day1)) day2) - (or (memq day1 dates) (push day1 dates))))) - (setq dates (sort dates '<)) - (when empty - (while (setq day (pop dates)) - (setq day2 (car dates)) - (push day dates1) - (when (and day2 empty) - (if (or (eq empty t) - (and (numberp empty) (<= (- day2 day) empty))) - (while (< (setq day (1+ day)) day2) - (push (list day) dates1)) - (push (cons :omitted (- day2 day)) dates1)))) - (setq dates (nreverse dates1))) - dates))) - -;;;###autoload (defun org-diary (&rest args) "Return diary information from org-files. This function can be used in a \"sexp\" diary entry in the Emacs calendar. @@ -8616,33 +13085,8 @@ function from a program - use `org-agenda-get-day-entries' instead." (setq results (append results rtn))) (if results (concat (org-finalize-agenda-entries results) "\n")))) -(defvar org-category-table nil) -(defun org-get-category-table () - "Get the table of categories and positions in current buffer." - (let (tbl) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "\\(^\\|\r\\)#\\+CATEGORY:[ \t]*\\(.*\\)" nil t) - (push (cons (point) (org-trim (match-string 2))) tbl))) - tbl)) -(defun org-get-category (&optional pos) - "Get the category applying to position POS." - (if (not org-category-table) - (cond - ((null org-category) - (setq org-category - (if buffer-file-name - (file-name-sans-extension - (file-name-nondirectory buffer-file-name)) - "???"))) - ((symbolp org-category) (symbol-name org-category)) - (t org-category)) - (let ((tbl org-category-table) - (pos (or pos (point)))) - (while (and tbl (> (caar tbl) pos)) - (pop tbl)) - (or (cdar tbl) (cdr (nth (1- (length org-category-table)) - org-category-table)))))) + +;;; Agenda entry finders (defun org-agenda-get-day-entries (file date &rest args) "Does the work for `org-diary' and `org-agenda'. @@ -9057,6 +13501,8 @@ the documentation of `org-diary'." ;; Sort the entries by expiration date. (nreverse ee))) +;;; Agenda presentation and sorting + ;; FIXME: should I allow spaces around the dash? (defconst org-plain-time-of-day-regexp (concat @@ -9353,6 +13799,230 @@ HH:MM." (eval (cons 'or org-agenda-sorting-strategy-selected)) '((-1 . t) (1 . nil) (nil . nil)))))) +;;; Agenda commands + +(defun org-agenda-check-type (error &rest types) + "Check if agenda buffer is of allowed type. +If ERROR is non-nil, throw an error, otherwise just return nil." + (if (memq org-agenda-type types) + t + (if error + (error "Not allowed in %s-type agenda buffers" org-agenda-type) + nil))) + +(defun org-agenda-quit () + "Exit agenda by removing the window or the buffer." + (interactive) + (let ((buf (current-buffer))) + (if (not (one-window-p)) (delete-window)) + (kill-buffer buf) + (org-agenda-maybe-reset-markers 'force)) + ;; Maybe restore the pre-agenda window configuration. + (and org-agenda-restore-windows-after-quit + (not (eq org-agenda-window-setup 'other-frame)) + org-pre-agenda-window-conf + (set-window-configuration org-pre-agenda-window-conf))) + +(defun org-agenda-exit () + "Exit agenda by removing the window or the buffer. +Also kill all Org-mode buffers which have been loaded by `org-agenda'. +Org-mode buffers visited directly by the user will not be touched." + (interactive) + (org-release-buffers org-agenda-new-buffers) + (setq org-agenda-new-buffers nil) + (org-agenda-quit)) + +(defun org-save-all-org-buffers () + "Save all Org-mode buffers without user confirmation." + (interactive) + (message "Saving all Org-mode buffers...") + (save-some-buffers t 'org-mode-p) + (message "Saving all Org-mode buffers... done")) + +(defun org-agenda-redo () + "Rebuild Agenda. +When this is the global TODO list, a prefix argument will be interpreted." + (interactive) + (let* ((org-agenda-keep-modes t) + (line (org-current-line)) + (window-line (- line (org-current-line (window-start))))) + (message "Rebuilding agenda buffer...") + (eval org-agenda-redo-command) + (setq org-agenda-undo-list nil + org-agenda-pending-undo-list nil) + (message "Rebuilding agenda buffer...done") + (goto-line line) + (recenter window-line))) + +(defun org-agenda-goto-today () + "Go to today." + (interactive) + (org-agenda-check-type t 'timeline 'agenda) + (let ((tdpos (text-property-any (point-min) (point-max) 'org-today t))) + (cond + (tdpos (goto-char tdpos)) + ((eq org-agenda-type 'agenda) + (let ((org-agenda-overriding-arguments org-agenda-last-arguments)) + (setf (nth 1 org-agenda-overriding-arguments) nil) + (org-agenda-redo) + (org-agenda-find-today-or-agenda))) + (t (error "Cannot find today"))))) + +(defun org-agenda-find-today-or-agenda () + (goto-char + (or (text-property-any (point-min) (point-max) 'org-today t) + (text-property-any (point-min) (point-max) 'org-agenda-type 'agenda) + (point-min)))) + +(defun org-agenda-later (arg) + "Go forward in time by `org-agenda-ndays' days. +With prefix ARG, go forward that many times `org-agenda-ndays'." + (interactive "p") + (org-agenda-check-type t 'agenda) + (let ((org-agenda-overriding-arguments + (list (car org-agenda-last-arguments) + (+ org-starting-day (* arg org-agenda-ndays)) + nil t))) + (org-agenda-redo) + (org-agenda-find-today-or-agenda))) + +(defun org-agenda-earlier (arg) + "Go back in time by `org-agenda-ndays' days. +With prefix ARG, go back that many times `org-agenda-ndays'." + (interactive "p") + (org-agenda-check-type t 'agenda) + (let ((org-agenda-overriding-arguments + (list (car org-agenda-last-arguments) + (- org-starting-day (* arg org-agenda-ndays)) + nil t))) + (org-agenda-redo) + (org-agenda-find-today-or-agenda))) + +(defun org-agenda-week-view () + "Switch to weekly view for agenda." + (interactive) + (org-agenda-check-type t 'agenda) + (if (= org-agenda-ndays 7) + (error "This is already the week view")) + (setq org-agenda-ndays 7) + (let ((org-agenda-overriding-arguments + (list (car org-agenda-last-arguments) + (or (get-text-property (point) 'day) + org-starting-day) + nil t))) + (org-agenda-redo) + (org-agenda-find-today-or-agenda)) + (org-agenda-set-mode-name) + (message "Switched to week view")) + +(defun org-agenda-day-view () + "Switch to daily view for agenda." + (interactive) + (org-agenda-check-type t 'agenda) + (if (= org-agenda-ndays 1) + (error "This is already the day view")) + (setq org-agenda-ndays 1) + (let ((org-agenda-overriding-arguments + (list (car org-agenda-last-arguments) + (or (get-text-property (point) 'day) + org-starting-day) + nil t))) + (org-agenda-redo) + (org-agenda-find-today-or-agenda)) + (org-agenda-set-mode-name) + (message "Switched to day view")) + +(defun org-agenda-next-date-line (&optional arg) + "Jump to the next line indicating a date in agenda buffer." + (interactive "p") + (org-agenda-check-type t 'agenda 'timeline) + (beginning-of-line 1) + (if (looking-at "^\\S-") (forward-char 1)) + (if (not (re-search-forward "^\\S-" nil t arg)) + (progn + (backward-char 1) + (error "No next date after this line in this buffer"))) + (goto-char (match-beginning 0))) + +(defun org-agenda-previous-date-line (&optional arg) + "Jump to the previous line indicating a date in agenda buffer." + (interactive "p") + (org-agenda-check-type t 'agenda 'timeline) + (beginning-of-line 1) + (if (not (re-search-backward "^\\S-" nil t arg)) + (error "No previous date before this line in this buffer"))) + +;; Initialize the highlight +(defvar org-hl (org-make-overlay 1 1)) +(org-overlay-put org-hl 'face 'highlight) + +(defun org-highlight (begin end &optional buffer) + "Highlight a region with overlay." + (funcall (if (featurep 'xemacs) 'set-extent-endpoints 'move-overlay) + org-hl begin end (or buffer (current-buffer)))) + +(defun org-unhighlight () + "Detach overlay INDEX." + (funcall (if (featurep 'xemacs) 'detach-extent 'delete-overlay) org-hl)) + + +(defun org-agenda-follow-mode () + "Toggle follow mode in an agenda buffer." + (interactive) + (setq org-agenda-follow-mode (not org-agenda-follow-mode)) + (org-agenda-set-mode-name) + (message "Follow mode is %s" + (if org-agenda-follow-mode "on" "off"))) + +(defun org-agenda-log-mode () + "Toggle log mode in an agenda buffer." + (interactive) + (org-agenda-check-type t 'agenda 'timeline) + (setq org-agenda-show-log (not org-agenda-show-log)) + (org-agenda-set-mode-name) + (org-agenda-redo) + (message "Log mode is %s" + (if org-agenda-show-log "on" "off"))) + +(defun org-agenda-toggle-diary () + "Toggle diary inclusion in an agenda buffer." + (interactive) + (org-agenda-check-type t 'agenda) + (setq org-agenda-include-diary (not org-agenda-include-diary)) + (org-agenda-redo) + (org-agenda-set-mode-name) + (message "Diary inclusion turned %s" + (if org-agenda-include-diary "on" "off"))) + +(defun org-agenda-toggle-time-grid () + "Toggle time grid in an agenda buffer." + (interactive) + (org-agenda-check-type t 'agenda) + (setq org-agenda-use-time-grid (not org-agenda-use-time-grid)) + (org-agenda-redo) + (org-agenda-set-mode-name) + (message "Time-grid turned %s" + (if org-agenda-use-time-grid "on" "off"))) + +(defun org-agenda-set-mode-name () + "Set the mode name to indicate all the small mode settings." + (setq mode-name + (concat "Org-Agenda" + (if (equal org-agenda-ndays 1) " Day" "") + (if (equal org-agenda-ndays 7) " Week" "") + (if org-agenda-follow-mode " Follow" "") + (if org-agenda-include-diary " Diary" "") + (if org-agenda-use-time-grid " Grid" "") + (if org-agenda-show-log " Log" ""))) + (force-mode-line-update)) + +(defun org-agenda-post-command-hook () + (and (eolp) (not (bolp)) (backward-char 1)) + (setq org-agenda-type (get-text-property (point) 'org-agenda-type)) + (if (and org-agenda-follow-mode + (get-text-property (point) 'org-marker)) + (org-agenda-show))) + (defun org-agenda-show-priority () "Show the priority of the current item. This priority is composed of the main priority given with the [#A] cookies, @@ -9542,7 +14212,7 @@ dedicated frame)." (with-current-buffer buffer (save-excursion (goto-char pos) - (org-tree-to-indirect-buffer))))) + (call-interactively 'org-tree-to-indirect-buffer))))) (defvar org-last-heading-marker (make-marker) "Marker pointing to the headline that last changed its TODO state @@ -10031,4498 +14701,298 @@ This is a command that has to be installed in `calendar-mode-map'." (if (fboundp 'fit-window-to-buffer) (fit-window-to-buffer (get-buffer-window "*Dates*"))))) -;;;; Tags -(defun org-scan-tags (action matcher &optional todo-only) - "Scan headline tags with inheritance and produce output ACTION. -ACTION can be `sparse-tree' or `agenda'. MATCHER is a Lisp form to be -evaluated, testing if a given set of tags qualifies a headline for -inclusion. When TODO-ONLY is non-nil, only lines with a TODO keyword -are included in the output." - (let* ((re (concat "[\n\r]" outline-regexp " *\\(\\<\\(" - (mapconcat 'regexp-quote - (nreverse (cdr (reverse org-todo-keywords))) - "\\|") - "\\>\\)\\)? *\\(.*?\\)\\(:[A-Za-z_@0-9:]+:\\)?[ \t]*$")) - (props (list 'face nil - 'done-face 'org-done - 'undone-face nil - 'mouse-face 'highlight - 'org-not-done-regexp org-not-done-regexp - 'keymap org-agenda-keymap - 'help-echo - (format "mouse-2 or RET jump to org file %s" - (abbreviate-file-name buffer-file-name)))) - (case-fold-search nil) - lspos - tags tags-list tags-alist (llast 0) rtn level category i txt - todo marker) - (save-excursion - (goto-char (point-min)) - (when (eq action 'sparse-tree) (org-overview)) - (while (re-search-forward re nil t) - (catch :skip - (and (eq action 'agenda) (org-agenda-skip)) - (setq todo (if (match-end 1) (match-string 2)) - tags (if (match-end 4) (match-string 4))) - (goto-char (setq lspos (1+ (match-beginning 0)))) - (setq level (funcall outline-level) - category (org-get-category)) - (setq i llast llast level) - ;; remove tag lists from same and sublevels - (while (>= i level) - (when (setq entry (assoc i tags-alist)) - (setq tags-alist (delete entry tags-alist))) - (setq i (1- i))) - ;; add the nex tags - (when tags - (setq tags (mapcar 'downcase (org-split-string tags ":")) - tags-alist - (cons (cons level tags) tags-alist))) - ;; compile tags for current headline - (setq tags-list - (if org-use-tag-inheritance - (apply 'append (mapcar 'cdr tags-alist)) - tags)) - (when (and (or (not todo-only) todo) - (eval matcher) - (or (not org-agenda-skip-archived-trees) - (not (member org-archive-tag tags-list)))) - ;; list this headline - (if (eq action 'sparse-tree) - (progn - (org-show-context 'tags-tree)) - (setq txt (org-format-agenda-item - "" - (concat - (if org-tags-match-list-sublevels - (make-string (1- level) ?.) "") - (org-get-heading)) - category tags-list)) - (goto-char lspos) - (setq marker (org-agenda-new-marker)) - (org-add-props txt props - 'org-marker marker 'org-hd-marker marker 'category category) - (push txt rtn)) - ;; if we are to skip sublevels, jump to end of subtree - (or org-tags-match-list-sublevels (org-end-of-subtree t)))))) - (when (and (eq action 'sparse-tree) - (not org-sparse-tree-open-archived-trees)) - (org-hide-archived-subtrees (point-min) (point-max))) - (nreverse rtn))) - -(defvar todo-only) ;; dynamically scoped - -(defun org-tags-sparse-tree (&optional todo-only match) - "Create a sparse tree according to tags string MATCH. -MATCH can contain positive and negative selection of tags, like -\"+WORK+URGENT-WITHBOSS\". -If optional argument TODO_ONLY is non-nil, only select lines that are -also TODO lines." - (interactive "P") - (org-scan-tags 'sparse-tree (cdr (org-make-tags-matcher match)) todo-only)) - -;; FIXME: implement search for a specific level. -(defun org-make-tags-matcher (match) - "Create the TAGS//TODO matcher form for the selection string MATCH." - ;; todo-only is scoped dynamically into this function, and the function - ;; may change it it the matcher asksk for it. - (unless match - ;; Get a new match request, with completion - (setq org-last-tags-completion-table - (or org-tag-alist - org-last-tags-completion-table)) - (setq match (completing-read - "Match: " 'org-tags-completion-function nil nil nil - 'org-tags-history))) ; FIXME: Separate history for this? - - ;; Parse the string and create a lisp form - (let ((match0 match) - (re "^&?\\([-+:]\\)?\\({[^}]+}\\|LEVEL=\\([0-9]+\\)\\|[A-Za-z_@0-9]+\\)") - minus tag mm - tagsmatch todomatch tagsmatcher todomatcher kwd matcher - orterms term orlist re-p level-p) - (if (string-match "/+" match) - ;; match contains also a todo-matching request - (progn - (setq tagsmatch (substring match 0 (match-beginning 0)) - todomatch (substring match (match-end 0))) - (if (string-match "^!" todomatch) - (setq todo-only t todomatch (substring todomatch 1))) - (if (string-match "^\\s-*$" todomatch) - (setq todomatch nil))) - ;; only matching tags - (setq tagsmatch match todomatch nil)) - - ;; Make the tags matcher - (if (or (not tagsmatch) (not (string-match "\\S-" tagsmatch))) - (setq tagsmatcher t) - (setq orterms (org-split-string tagsmatch "|") orlist nil) - (while (setq term (pop orterms)) - (while (and (equal (substring term -1) "\\") orterms) - (setq term (concat term "|" (pop orterms)))) ; repair bad split - (while (string-match re term) - (setq minus (and (match-end 1) - (equal (match-string 1 term) "-")) - tag (match-string 2 term) - re-p (equal (string-to-char tag) ?{) - level-p (match-end 3) - mm (cond - (re-p `(org-match-any-p ,(substring tag 1 -1) tags-list)) - (level-p `(= level ,(string-to-number - (match-string 3 term)))) - (t `(member ,(downcase tag) tags-list))) - mm (if minus (list 'not mm) mm) - term (substring term (match-end 0))) - (push mm tagsmatcher)) - (push (if (> (length tagsmatcher) 1) - (cons 'and tagsmatcher) - (car tagsmatcher)) - orlist) - (setq tagsmatcher nil)) - (setq tagsmatcher (if (> (length orlist) 1) (cons 'or orlist) (car orlist)))) - - ;; Make the todo matcher - (if (or (not todomatch) (not (string-match "\\S-" todomatch))) - (setq todomatcher t) - (setq orterms (org-split-string todomatch "|") orlist nil) - (while (setq term (pop orterms)) - (while (string-match re term) - (setq minus (and (match-end 1) - (equal (match-string 1 term) "-")) - kwd (match-string 2 term) - re-p (equal (string-to-char kwd) ?{) - term (substring term (match-end 0)) - mm (if re-p - `(string-match ,(substring kwd 1 -1) todo) - (list 'equal 'todo kwd)) - mm (if minus (list 'not mm) mm)) - (push mm todomatcher)) - (push (if (> (length todomatcher) 1) - (cons 'and todomatcher) - (car todomatcher)) - orlist) - (setq todomatcher nil)) - (setq todomatcher (if (> (length orlist) 1) - (cons 'or orlist) (car orlist)))) - - ;; Return the string and lisp forms of the matcher - (setq matcher (if todomatcher - (list 'and tagsmatcher todomatcher) - tagsmatcher)) - (cons match0 matcher))) - -(defun org-match-any-p (re list) - "Does re match any element of list?" - (setq list (mapcar (lambda (x) (string-match re x)) list)) - (delq nil list)) - -;;;###autoload -(defun org-tags-view (&optional todo-only match) - "Show all headlines for all `org-agenda-files' matching a TAGS criterion. -The prefix arg TODO-ONLY limits the search to TODO entries." - (interactive "P") - (org-compile-prefix-format 'tags) - (org-set-sorting-strategy 'tags) - (let* ((org-tags-match-list-sublevels - (if todo-only t org-tags-match-list-sublevels)) - (win (selected-window)) - (completion-ignore-case t) - rtn rtnall files file pos matcher - buffer) - (setq matcher (org-make-tags-matcher match) - match (car matcher) matcher (cdr matcher)) - (org-prepare-agenda) - (setq org-agenda-redo-command - (list 'org-tags-view (list 'quote todo-only) - (list 'if 'current-prefix-arg nil match))) - (setq files (org-agenda-files) - rtnall nil) - (while (setq file (pop files)) - (catch 'nextfile - (org-check-agenda-file file) - (setq buffer (if (file-exists-p file) - (org-get-agenda-file-buffer file) - (error "No such file %s" file))) - (if (not buffer) - ;; If file does not exist, merror message to agenda - (setq rtn (list - (format "ORG-AGENDA-ERROR: No such org-file %s" file)) - rtnall (append rtnall rtn)) - (with-current-buffer buffer - (unless (org-mode-p) - (error "Agenda file %s is not in `org-mode'" file)) - (setq org-category-table (org-get-category-table)) - (save-excursion - (save-restriction - (if org-agenda-restrict - (narrow-to-region org-agenda-restrict-begin - org-agenda-restrict-end) - (widen)) - (setq rtn (org-scan-tags 'agenda matcher todo-only)) - (setq rtnall (append rtnall rtn)))))))) - (if org-agenda-overriding-header - (insert (org-add-props (copy-sequence org-agenda-overriding-header) - nil 'face 'org-level-3) "\n") - (insert "Headlines with TAGS match: ") - (add-text-properties (point-min) (1- (point)) - (list 'face 'org-level-3)) - (setq pos (point)) - (insert match "\n") - (add-text-properties pos (1- (point)) (list 'face 'org-warning)) - (setq pos (point)) - (unless org-agenda-multi - (insert "Press `C-u r' to search again with new search string\n")) - (add-text-properties pos (1- (point)) (list 'face 'org-level-3))) - (when rtnall - (insert (org-finalize-agenda-entries rtnall) "\n")) - (goto-char (point-min)) - (org-fit-agenda-window) - (add-text-properties (point-min) (point-max) '(org-agenda-type tags)) - (org-finalize-agenda) - (setq buffer-read-only t) - (if (not org-select-agenda-window) (select-window win)))) - -(defvar org-add-colon-after-tag-completion nil) ;; dynamically skoped param -(defvar org-tags-overlay (org-make-overlay 1 1)) -(org-detach-overlay org-tags-overlay) - -(defun org-set-tags (&optional arg just-align) - "Set the tags for the current headline. -With prefix ARG, realign all tags in headings in the current buffer." - (interactive "P") - (let* ((re (concat "^" outline-regexp)) - (current (org-get-tags)) - table current-tags inherited-tags ; computed below when needed - tags p0 c0 c1 rpl) - (if arg - (save-excursion - (goto-char (point-min)) - (let (buffer-invisibility-spec) ; Emacs 21 compatibility - (while (re-search-forward re nil t) - (org-set-tags nil t) - (end-of-line 1))) - (message "All tags realigned to column %d" org-tags-column)) - (if just-align - (setq tags current) - ;; Get a new set of tags from the user - (setq table (or org-tag-alist (org-get-buffer-tags)) - org-last-tags-completion-table table - current-tags (org-split-string current ":") - inherited-tags (nreverse - (nthcdr (length current-tags) - (nreverse (org-get-tags-at)))) - tags - (if (or (eq t org-use-fast-tag-selection) - (and org-use-fast-tag-selection - (delq nil (mapcar 'cdr table)))) - (org-fast-tag-selection current-tags inherited-tags table) - (let ((org-add-colon-after-tag-completion t)) - (org-trim - (completing-read "Tags: " 'org-tags-completion-function - nil nil current 'org-tags-history))))) - (while (string-match "[-+&]+" tags) - ;; No boolean logic, just a list - (setq tags (replace-match ":" t t tags)))) - (if (string-match "\\`[\t ]*\\'" tags) - (setq tags "") - (unless (string-match ":$" tags) (setq tags (concat tags ":"))) - (unless (string-match "^:" tags) (setq tags (concat ":" tags)))) - - ;; Insert new tags at the correct column - (beginning-of-line 1) - (if (re-search-forward - (concat "\\([ \t]*" (regexp-quote current) "\\)[ \t]*$") - (point-at-eol) t) - (progn - (if (equal tags "") - (setq rpl "") - (goto-char (match-beginning 0)) - (setq c0 (current-column) p0 (point) - c1 (max (1+ c0) (if (> org-tags-column 0) - org-tags-column - (- (- org-tags-column) (length tags)))) - rpl (concat (make-string (max 0 (- c1 c0)) ?\ ) tags))) - (replace-match rpl) - (and (not (featurep 'xemacs)) c0 (tabify p0 (point))) - tags) - (error "Tags alignment failed"))))) - -(defun org-tags-completion-function (string predicate &optional flag) - (let (s1 s2 rtn (ctable org-last-tags-completion-table) - (confirm (lambda (x) (stringp (car x))))) - (if (string-match "^\\(.*[-+:&|]\\)\\([^-+:&|]*\\)$" string) - (setq s1 (match-string 1 string) - s2 (match-string 2 string)) - (setq s1 "" s2 string)) - (cond - ((eq flag nil) - ;; try completion - (setq rtn (try-completion s2 ctable confirm)) - (if (stringp rtn) - (concat s1 s2 (substring rtn (length s2)) - (if (and org-add-colon-after-tag-completion - (assoc rtn ctable)) - ":" ""))) - ) - ((eq flag t) - ;; all-completions - (all-completions s2 ctable confirm) - ) - ((eq flag 'lambda) - ;; exact match? - (assoc s2 ctable))) - )) +;;;; Embedded LaTeX -(defun org-fast-tag-insert (kwd tags face &optional end) - "Insert KDW, and the TAGS, the latter with face FACE. Also inser END." - (insert (format "%-12s" (concat kwd ":")) - (org-add-props (mapconcat 'identity tags " ") nil 'face face) - (or end ""))) +(defvar org-cdlatex-mode-map (make-sparse-keymap) + "Keymap for the minor `org-cdlatex-mode'.") -(defun org-fast-tag-show-exit (flag) - (save-excursion - (goto-line 3) - (if (re-search-forward "[ \t]+Next change exits" (point-at-eol) t) - (replace-match "")) - (when flag - (end-of-line 1) - (move-to-column (- (window-width) 19) t) - (insert (org-add-props " Next change exits" nil 'face 'org-warning))))) +(define-key org-cdlatex-mode-map "_" 'org-cdlatex-underscore-caret) +(define-key org-cdlatex-mode-map "^" 'org-cdlatex-underscore-caret) +(define-key org-cdlatex-mode-map "`" 'cdlatex-math-symbol) +(define-key org-cdlatex-mode-map "'" 'org-cdlatex-math-modify) +(define-key org-cdlatex-mode-map "\C-c{" 'cdlatex-environment) -(defun org-set-current-tags-overlay (current prefix) - (let ((s (concat ":" (mapconcat 'identity current ":") ":"))) - (if (featurep 'xemacs) - (org-overlay-display org-tags-overlay (concat prefix s) - 'secondary-selection) - (put-text-property 0 (length s) 'face '(secondary-selection org-tag) s) - (org-overlay-display org-tags-overlay (concat prefix s))))) +(defvar org-cdlatex-texmathp-advice-is-done nil + "Flag remembering if we have applied the advice to texmathp already.") -(defun org-fast-tag-selection (current inherited table) - "Fast tag selection with single keys. -CURRENT is the current list of tags in the headline, INHERITED is the -list of inherited tags, and TABLE is an alist of tags and corresponding keys, -possibly with grouping information. -If the keys are nil, a-z are automatically assigned. -Returns the new tags string, or nil to not change the current settings." - (let* ((maxlen (apply 'max (mapcar - (lambda (x) - (if (stringp (car x)) (string-width (car x)) 0)) - table))) - (buf (current-buffer)) - (buffer-tags nil) - (fwidth (+ maxlen 3 1 3)) - (ncol (/ (- (window-width) 4) fwidth)) - (i-face 'org-done) - (c-face 'org-tag) - tg cnt e c char c1 c2 ntable tbl rtn - ov-start ov-end ov-prefix - (exit-after-next org-fast-tag-selection-single-key) - groups ingroup) - (save-excursion - (beginning-of-line 1) - (if (looking-at ".*[ \t]\\(:[A-Za-z_@0-9:]+:\\)[ \t]*\\(\r\\|$\\)") - (setq ov-start (match-beginning 1) - ov-end (match-end 1) - ov-prefix "") - (setq ov-start (1- (point-at-eol)) - ov-end (1+ ov-start)) - (skip-chars-forward "^\n\r") - (setq ov-prefix - (concat - (buffer-substring (1- (point)) (point)) - (if (> (current-column) org-tags-column) - " " - (make-string (- org-tags-column (current-column)) ?\ )))))) - (org-move-overlay org-tags-overlay ov-start ov-end) - (save-window-excursion - ;; FIXME: would it be better to keep the other windows? - (delete-other-windows) - (split-window-vertically) - (switch-to-buffer-other-window (get-buffer-create " *Org tags*")) - (erase-buffer) - (org-fast-tag-insert "Inherited" inherited i-face "\n") - (org-fast-tag-insert "Current" current c-face "\n\n") - (org-fast-tag-show-exit exit-after-next) - (org-set-current-tags-overlay current ov-prefix) - (setq tbl table char ?a cnt 0) - (while (setq e (pop tbl)) +(define-minor-mode org-cdlatex-mode + "Toggle the minor `org-cdlatex-mode'. +This mode supports entering LaTeX environment and math in LaTeX fragments +in Org-mode. +\\{org-cdlatex-mode-map}" + nil " OCDL" nil + (when org-cdlatex-mode (require 'cdlatex)) + (unless org-cdlatex-texmathp-advice-is-done + (setq org-cdlatex-texmathp-advice-is-done t) + (defadvice texmathp (around org-math-always-on activate) + "Always return t in org-mode buffers. +This is because we want to insert math symbols without dollars even outside +the LaTeX math segments. If Orgmode thinks that point is actually inside +en embedded LaTeX fragement, let texmathp do its job. +\\[org-cdlatex-mode-map]" + (interactive) + (let (p) (cond - ((equal e '(:startgroup)) - (push '() groups) (setq ingroup t) - (when (not (= cnt 0)) - (setq cnt 0) - (insert "\n")) - (insert "{ ")) - ((equal e '(:endgroup)) - (setq ingroup nil cnt 0) - (insert "}\n")) + ((not (org-mode-p)) ad-do-it) + ((eq this-command 'cdlatex-math-symbol) + (setq ad-return-value t + texmathp-why '("cdlatex-math-symbol in org-mode" . 0))) (t - (setq tg (car e) c2 nil) - (if (cdr e) - (setq c (cdr e)) - ;; automatically assign a character. - (setq c1 (string-to-char - (downcase (substring - tg (if (= (string-to-char tg) ?@) 1 0))))) - (if (or (rassoc c1 ntable) (rassoc c1 table)) - (while (or (rassoc char ntable) (rassoc char table)) - (setq char (1+ char))) - (setq c2 c1)) - (setq c (or c2 char))) - (if ingroup (push tg (car groups))) - (setq tg (org-add-props tg nil 'face - (cond - ((member tg current) c-face) - ((member tg inherited) i-face) - (t nil)))) - (if (and (= cnt 0) (not ingroup)) (insert " ")) - (insert "[" c "] " tg (make-string - (- fwidth 4 (length tg)) ?\ )) - (push (cons tg c) ntable) - (when (= (setq cnt (1+ cnt)) ncol) - (insert "\n") - (if ingroup (insert " ")) - (setq cnt 0))))) - (setq ntable (nreverse ntable)) - (insert "\n") - (goto-char (point-min)) - (if (fboundp 'fit-window-to-buffer) (fit-window-to-buffer)) - (setq rtn - (catch 'exit - (while t - (message "[a-z..]:Toggle [SPC]:clear [RET]:accept [TAB]:free [C-c]: multi%s" - (if groups " [!] no groups" "")) - (setq c (let ((inhibit-quit t)) (read-char-exclusive))) - (cond - ((= c ?\r) (throw 'exit t)) - ((= c ?!) - (setq groups nil) - (goto-char (point-min)) - (while (re-search-forward "[{}]" nil t) (replace-match " "))) - ((= c ?\C-c) - (org-fast-tag-show-exit - (setq exit-after-next (not exit-after-next)))) - ((or (= c ?\C-g) - (and (= c ?q) (not (rassoc c ntable)))) - (org-detach-overlay org-tags-overlay) - (setq quit-flag t)) - ((= c ?\ ) - (setq current nil) - (if exit-after-next (setq exit-after-next 'now))) - ((= c ?\t) - (condition-case nil - (setq tg (completing-read - "Tag: " - (or buffer-tags - (with-current-buffer buf - (org-get-buffer-tags))))) - (quit (setq tg ""))) - (when (string-match "\\S-" tg) - (add-to-list 'buffer-tags (list tg)) - (if (member tg current) - (setq current (delete tg current)) - (push tg current))) - (if exit-after-next (setq exit-after-next 'now))) - ((setq e (rassoc c ntable) tg (car e)) - (if (member tg current) - (setq current (delete tg current)) - (loop for g in groups do - (if (member tg g) - (mapcar (lambda (x) - (setq current (delete x current))) - g))) - (push tg current)) - (if exit-after-next (setq exit-after-next 'now)))) - - ;; Create a sorted list - (setq current - (sort current - (lambda (a b) - (assoc b (cdr (memq (assoc a ntable) ntable)))))) - (if (eq exit-after-next 'now) (throw 'exit t)) - (goto-char (point-min)) - (beginning-of-line 2) - (delete-region (point) (point-at-eol)) - (org-fast-tag-insert "Current" current c-face) - (org-set-current-tags-overlay current ov-prefix) - (while (re-search-forward "\\[.\\] \\([a-zA-Z0-9_@]+\\)" nil t) - (setq tg (match-string 1)) - (add-text-properties (match-beginning 1) (match-end 1) - (list 'face - (cond - ((member tg current) c-face) - ((member tg inherited) i-face) - (t nil))))) - (goto-char (point-min))))) - (org-detach-overlay org-tags-overlay) - (if rtn - (mapconcat 'identity current ":") - nil)))) - -(defun org-get-tags () - "Get the TAGS string in the current headline." - (unless (org-on-heading-p t) - (error "Not on a heading")) - (save-excursion - (beginning-of-line 1) - (if (looking-at ".*[ \t]\\(:[A-Za-z_@0-9:]+:\\)[ \t]*\\(\r\\|$\\)") - (org-match-string-no-properties 1) - ""))) - -(defun org-get-buffer-tags () - "Get a table of all tags used in the buffer, for completion." - (let (tags) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "[ \t]:\\([A-Za-z_@0-9:]+\\):[ \t\r\n]" nil t) - (mapc (lambda (x) (add-to-list 'tags x)) - (org-split-string (org-match-string-no-properties 1) ":")))) - (mapcar 'list tags))) - -;;;; Link Stuff - -(defvar org-create-file-search-functions nil - "List of functions to construct the right search string for a file link. -These functions are called in turn with point at the location to -which the link should point. - -A function in the hook should first test if it would like to -handle this file type, for example by checking the major-mode or -the file extension. If it decides not to handle this file, it -should just return nil to give other functions a chance. If it -does handle the file, it must return the search string to be used -when following the link. The search string will be part of the -file link, given after a double colon, and `org-open-at-point' -will automatically search for it. If special measures must be -taken to make the search successful, another function should be -added to the companion hook `org-execute-file-search-functions', -which see. - -A function in this hook may also use `setq' to set the variable -`description' to provide a suggestion for the descriptive text to -be used for this link when it gets inserted into an Org-mode -buffer with \\[org-insert-link].") - -(defvar org-execute-file-search-functions nil - "List of functions to execute a file search triggered by a link. - -Functions added to this hook must accept a single argument, the -search string that was part of the file link, the part after the -double colon. The function must first check if it would like to -handle this search, for example by checking the major-mode or the -file extension. If it decides not to handle this search, it -should just return nil to give other functions a chance. If it -does handle the search, it must return a non-nil value to keep -other functions from trying. - -Each function can access the current prefix argument through the -variable `current-prefix-argument'. Note that a single prefix is -used to force opening a link in Emacs, so it may be good to only -use a numeric or double prefix to guide the search function. - -In case this is needed, a function in this hook can also restore -the window configuration before `org-open-at-point' was called using: - - (set-window-configuration org-window-config-before-follow-link)") - -(defun org-find-file-at-mouse (ev) - "Open file link or URL at mouse." - (interactive "e") - (mouse-set-point ev) - (org-open-at-point 'in-emacs)) - -(defun org-open-at-mouse (ev) - "Open file link or URL at mouse." - (interactive "e") - (mouse-set-point ev) - (org-open-at-point)) - -(defvar org-window-config-before-follow-link nil - "The window configuration before following a link. -This is saved in case the need arises to restore it.") - -;; FIXME: IN-EMACS is used for many purposes, maybe rename this argument??? -(defun org-open-at-point (&optional in-emacs) - "Open link at or after point. -If there is no link at point, this function will search forward up to -the end of the current subtree. -Normally, files will be opened by an appropriate application. If the -optional argument IN-EMACS is non-nil, Emacs will visit the file." - (interactive "P") - (setq org-window-config-before-follow-link (current-window-configuration)) - (org-remove-occur-highlights nil nil t) - (if (org-at-timestamp-p t) - (org-follow-timestamp-link) - (let (type path link line search (pos (point))) - (catch 'match - (save-excursion - (skip-chars-forward "^]\n\r") - (when (and (re-search-backward "\\[\\[" nil t) - (looking-at org-bracket-link-regexp) - (<= (match-beginning 0) pos) - (>= (match-end 0) pos)) - (setq link (org-link-unescape (org-match-string-no-properties 1))) - (while (string-match " *\n *" link) - (setq link (replace-match " " t t link))) - (setq link (org-link-expand-abbrev link)) - (if (string-match org-link-re-with-space2 link) - (setq type (match-string 1 link) - path (match-string 2 link)) - (setq type "thisfile" - path link)) - (throw 'match t))) - - (when (get-text-property (point) 'org-linked-text) - (setq type "thisfile" - pos (if (get-text-property (1+ (point)) 'org-linked-text) - (1+ (point)) (point)) - path (buffer-substring - (previous-single-property-change pos 'org-linked-text) - (next-single-property-change pos 'org-linked-text))) - (throw 'match t)) - - (save-excursion - (skip-chars-backward (concat "^[]" org-non-link-chars " ")) - (if (equal (char-before) ?<) (backward-char 1)) - (when (or (looking-at org-angle-link-re) - (looking-at org-plain-link-re) - (and (or (re-search-forward org-angle-link-re (point-at-eol) t) - (re-search-forward org-plain-link-re (point-at-eol) t)) - (<= (match-beginning 0) pos) - (>= (match-end 0) pos))) - (setq type (match-string 1) - path (match-string 2)) - (throw 'match t))) - (save-excursion - (skip-chars-backward "^ \t\n\r") - (when (looking-at "\\(:[A-Za-z_@0-9:]+\\):[ \t\r\n]") - (setq type "tags" - path (match-string 1)) - (while (string-match ":" path) - (setq path (replace-match "+" t t path))) - (throw 'match t))) - (save-excursion - (skip-chars-backward "a-zA-Z_") - (when (and (memq 'camel org-activate-links) - (looking-at org-camel-regexp)) - (setq type "camel" path (match-string 0)) - (if (equal (char-before) ?*) - (setq path (concat "*" path)))) - (throw 'match t))) - (unless path - (error "No link found")) - ;; Remove any trailing spaces in path - (if (string-match " +\\'" path) - (setq path (replace-match "" t t path))) - - (cond - - ((equal type "mailto") - (let ((cmd (car org-link-mailto-program)) - (args (cdr org-link-mailto-program)) args1 - (address path) (subject "") a) - (if (string-match "\\(.*\\)::\\(.*\\)" path) - (setq address (match-string 1 path) - subject (org-link-escape (match-string 2 path)))) - (while args - (cond - ((not (stringp (car args))) (push (pop args) args1)) - (t (setq a (pop args)) - (if (string-match "%a" a) - (setq a (replace-match address t t a))) - (if (string-match "%s" a) - (setq a (replace-match subject t t a))) - (push a args1)))) - (apply cmd (nreverse args1)))) - - ((member type '("http" "https" "ftp" "news")) - (browse-url (concat type ":" path))) - - ((string= type "tags") - (org-tags-view in-emacs path)) - ((or (string= type "camel") - (string= type "thisfile")) - (if in-emacs - (switch-to-buffer-other-window - (org-get-buffer-for-internal-link (current-buffer))) - (org-mark-ring-push)) - (org-link-search - path - (cond ((equal in-emacs '(4)) 'occur) - ((equal in-emacs '(16)) 'org-occur) - (t nil)))) - - ((string= type "file") - (if (string-match "::\\([0-9]+\\)\\'" path) - (setq line (string-to-number (match-string 1 path)) - path (substring path 0 (match-beginning 0))) - (if (string-match "::\\(.+\\)\\'" path) - (setq search (match-string 1 path) - path (substring path 0 (match-beginning 0))))) - (org-open-file path in-emacs line search)) - - ((string= type "news") - (org-follow-gnus-link path)) - - ((string= type "bbdb") - (org-follow-bbdb-link path)) - - ((string= type "info") - (org-follow-info-link path)) - - ((string= type "gnus") - (let (group article) - (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) - (error "Error in Gnus link")) - (setq group (match-string 1 path) - article (match-string 3 path)) - (org-follow-gnus-link group article))) - - ((string= type "vm") - (let (folder article) - (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) - (error "Error in VM link")) - (setq folder (match-string 1 path) - article (match-string 3 path)) - ;; in-emacs is the prefix arg, will be interpreted as read-only - (org-follow-vm-link folder article in-emacs))) - - ((string= type "wl") - (let (folder article) - (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) - (error "Error in Wanderlust link")) - (setq folder (match-string 1 path) - article (match-string 3 path)) - (org-follow-wl-link folder article))) - - ((string= type "mhe") - (let (folder article) - (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) - (error "Error in MHE link")) - (setq folder (match-string 1 path) - article (match-string 3 path)) - (org-follow-mhe-link folder article))) - - ((string= type "rmail") - (let (folder article) - (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) - (error "Error in RMAIL link")) - (setq folder (match-string 1 path) - article (match-string 3 path)) - (org-follow-rmail-link folder article))) - - ((string= type "shell") - (let ((cmd path)) - (while (string-match "@{" cmd) ; FIXME: not needed for [[]] links - (setq cmd (replace-match "<" t t cmd))) - (while (string-match "@}" cmd) ; FIXME: not needed for [[]] links - (setq cmd (replace-match ">" t t cmd))) - (if (or (not org-confirm-shell-link-function) - (funcall org-confirm-shell-link-function - (format "Execute \"%s\" in shell? " - (org-add-props cmd nil - 'face 'org-warning)))) - (progn - (message "Executing %s" cmd) - (shell-command cmd)) - (error "Abort")))) - - ((string= type "elisp") - (let ((cmd path)) - (if (or (not org-confirm-elisp-link-function) - (funcall org-confirm-elisp-link-function - (format "Execute \"%s\" as elisp? " - (org-add-props cmd nil - 'face 'org-warning)))) - (message "%s => %s" cmd (eval (read cmd))) - (error "Abort")))) - - (t - (browse-url-at-point)))))) + (let ((p (org-inside-LaTeX-fragment-p))) + (if (and p (member (car p) (plist-get org-format-latex-options :matchers))) + (setq ad-return-value t + texmathp-why '("Org-mode embedded math" . 0)) + (if p ad-do-it))))))))) -(defun org-link-expand-abbrev (link) - "Apply replacements as defined in `org-link-abbrev-alist." - (if (string-match "^\\([a-zA-Z]+\\)\\(::\\(.*\\)\\)?$" link) - (let* ((key (match-string 1 link)) - (as (or (assoc key org-link-abbrev-alist-local) - (assoc key org-link-abbrev-alist))) - (tag (and (match-end 2) (match-string 3 link))) - rpl) - (if (not as) - link - (setq rpl (cdr as)) - (cond - ((symbolp rpl) (funcall rpl tag)) - ((string-match "%s" rpl) (replace-match (or tag "") t t rpl)) - (t (concat rpl tag))))) - link)) +(defun turn-on-org-cdlatex () + "Unconditionally turn on `org-cdlatex-mode'." + (org-cdlatex-mode 1)) -(defun org-link-search (s &optional type) - "Search for a link search option. -When S is a CamelCaseWord, search for a target, or for a sentence containing -the words. If S is surrounded by forward slashes, it is interpreted as a -regular expression. In org-mode files, this will create an `org-occur' -sparse tree. In ordinary files, `occur' will be used to list matches. -If the current buffer is in `dired-mode', grep will be used to search -in all files." - (let ((case-fold-search t) - (s0 (mapconcat 'identity (org-split-string s "[ \t\r\n]+") " ")) - (pos (point)) - (pre "") (post "") - words re0 re1 re2 re3 re4 re5 re2a reall camel) - (cond - ;; First check if there are any special - ((run-hook-with-args-until-success 'org-execute-file-search-functions s)) - ;; Now try the builtin stuff - ((save-excursion - (goto-char (point-min)) - (and - (re-search-forward - (concat "<<" (regexp-quote s0) ">>") nil t) - (setq pos (match-beginning 0)))) - ;; There is an exact target for this - (goto-char pos)) - ((string-match "^/\\(.*\\)/$" s) - ;; A regular expression - (cond - ((org-mode-p) - (org-occur (match-string 1 s))) - ;;((eq major-mode 'dired-mode) - ;; (grep (concat "grep -n -e '" (match-string 1 s) "' *"))) - (t (org-do-occur (match-string 1 s))))) - ((or (setq camel (string-match (concat "^" org-camel-regexp "$") s)) - t) - ;; A camel or a normal search string - (when (equal (string-to-char s) ?*) - ;; Anchor on headlines, post may include tags. - (setq pre "^\\*+[ \t]*\\(?:\\sw+\\)?[ \t]*" - post "[ \t]*\\(?:[ \t]+:[a-zA-Z_@0-9:+]:[ \t]*\\)?$" - s (substring s 1))) - (remove-text-properties - 0 (length s) - '(face nil mouse-face nil keymap nil fontified nil) s) - ;; Make a series of regular expressions to find a match - (setq words - (if camel - (org-camel-to-words s) - (org-split-string s "[ \n\r\t]+")) - re0 (concat "\\(<<" (regexp-quote s0) ">>\\)") - re2 (concat "[ \t\r\n]\\(" (mapconcat 'downcase words "[ \t]+") "\\)[ \t\r\n]") - re2a (concat "[ \t\r\n]\\(" (mapconcat 'downcase words "[ \t\r\n]+") "\\)[ \t\r\n]") - re4 (concat "[^a-zA-Z_]\\(" (mapconcat 'downcase words "[^a-zA-Z_\r\n]+") "\\)[^a-zA-Z_]") - re1 (concat pre re2 post) - re3 (concat pre re4 post) - re5 (concat pre ".*" re4) - re2 (concat pre re2) - re2a (concat pre re2a) - re4 (concat pre re4) - reall (concat "\\(" re0 "\\)\\|\\(" re1 "\\)\\|\\(" re2 - "\\)\\|\\(" re3 "\\)\\|\\(" re4 "\\)\\|\\(" - re5 "\\)" - )) - (cond - ((eq type 'org-occur) (org-occur reall)) - ((eq type 'occur) (org-do-occur (downcase reall) 'cleanup)) - (t (goto-char (point-min)) - (if (or (org-search-not-link re0 nil t) - (org-search-not-link re1 nil t) - (org-search-not-link re2 nil t) - (org-search-not-link re2a nil t) - (org-search-not-link re3 nil t) - (org-search-not-link re4 nil t) - (org-search-not-link re5 nil t) - ) - (goto-char (match-beginning 1)) - (goto-char pos) - (error "No match"))))) - (t - ;; Normal string-search - (goto-char (point-min)) - (if (search-forward s nil t) - (goto-char (match-beginning 0)) - (error "No match")))) - (and (org-mode-p) (org-show-context 'link-search)))) +(defun org-inside-LaTeX-fragment-p () + "Test if point is inside a LaTeX fragment. +I.e. after a \\begin, \\(, \\[, $, or $$, without the corresponding closing +sequence appearing also before point. +Even though the matchers for math are configurable, this function assumes +that \\begin, \\(, \\[, and $$ are always used. Only the single dollar +delimiters are skipped when they have been removed by customization. +The return value is nil, or a cons cell with the delimiter and +and the position of this delimiter. -(defun org-search-not-link (&rest args) - "Execute `re-search-forward', but only accept matches that are not a link." +This function does a reasonably good job, but can locally be fooled by +for example currency specifications. For example it will assume being in +inline math after \"$22.34\". The LaTeX fragment formatter will only format +fragments that are properly closed, but during editing, we have to live +with the uncertainty caused by missing closing delimiters. This function +looks only before point, not after." (catch 'exit - (let (p1) - (while (apply 're-search-forward args) - (setq p1 (point)) - (if (not (save-match-data - (and (re-search-backward "\\[\\[" nil t) - (looking-at org-bracket-link-regexp) - (<= (match-beginning 0) p1) - (>= (match-end 0) p1)))) - (progn (goto-char (match-end 0)) - (throw 'exit (point))) - (goto-char (match-end 0))))))) - -(defun org-get-buffer-for-internal-link (buffer) - "Return a buffer to be used for displaying the link target of internal links." - (cond - ((not org-display-internal-link-with-indirect-buffer) - buffer) - ((string-match "(Clone)$" (buffer-name buffer)) - (message "Buffer is already a clone, not making another one") - ;; we also do not modify visibility in this case - buffer) - (t ; make a new indirect buffer for displaying the link - (let* ((bn (buffer-name buffer)) - (ibn (concat bn "(Clone)")) - (ib (or (get-buffer ibn) (make-indirect-buffer buffer ibn 'clone)))) - (with-current-buffer ib (org-overview)) - ib)))) - -(defun org-do-occur (regexp &optional cleanup) - "Call the Emacs command `occur'. -If CLEANUP is non-nil, remove the printout of the regular expression -in the *Occur* buffer. This is useful if the regex is long and not useful -to read." - (occur regexp) - (when cleanup - (let ((cwin (selected-window)) win beg end) - (when (setq win (get-buffer-window "*Occur*")) - (select-window win)) - (goto-char (point-min)) - (when (re-search-forward "match[a-z]+" nil t) - (setq beg (match-end 0)) - (if (re-search-forward "^[ \t]*[0-9]+" nil t) - (setq end (1- (match-beginning 0))))) - (and beg end (let ((buffer-read-only)) (delete-region beg end))) - (goto-char (point-min)) - (select-window cwin)))) - -(defvar org-mark-ring nil - "Mark ring for positions before jumps in Org-mode.") -(defvar org-mark-ring-last-goto nil - "Last position in the mark ring used to go back.") -;; Fill and close the ring -(setq org-mark-ring nil org-mark-ring-last-goto nil) ;; in case file is reloaded -(loop for i from 1 to org-mark-ring-length do - (push (make-marker) org-mark-ring)) -(setcdr (nthcdr (1- org-mark-ring-length) org-mark-ring) - org-mark-ring) - -(defun org-mark-ring-push (&optional pos buffer) - "Put the current position or POS into the mark ring and rotate it." - (interactive) - (setq pos (or pos (point))) - (setq org-mark-ring (nthcdr (1- org-mark-ring-length) org-mark-ring)) - (move-marker (car org-mark-ring) - (or pos (point)) - (or buffer (current-buffer))) - (message - (substitute-command-keys - "Position saved to mark ring, go back with \\[org-mark-ring-goto]."))) - -(defun org-mark-ring-goto (&optional n) - "Jump to the previous position in the mark ring. -With prefix arg N, jump back that many stored positions. When -called several times in succession, walk through the entire ring. -Org-mode commands jumping to a different position in the current file, -or to another Org-mode file, automatically push the old position -onto the ring." - (interactive "p") - (let (p m) - (if (eq last-command this-command) - (setq p (nthcdr n (or org-mark-ring-last-goto org-mark-ring))) - (setq p org-mark-ring)) - (setq org-mark-ring-last-goto p) - (setq m (car p)) - (switch-to-buffer (marker-buffer m)) - (goto-char m) - (if (or (org-invisible-p) (org-invisible-p2)) (org-show-context 'mark-goto)))) - -(defun org-camel-to-words (s) - "Split \"CamelCaseWords\" to (\"Camel\" \"Case\" \"Words\")." - (let ((case-fold-search nil) - words) - (while (string-match "[a-z][A-Z]" s) - (push (substring s 0 (1+ (match-beginning 0))) words) - (setq s (substring s (1+ (match-beginning 0))))) - (nreverse (cons s words)))) - -(defun org-remove-angle-brackets (s) - (if (equal (substring s 0 1) "<") (setq s (substring s 1))) - (if (equal (substring s -1) ">") (setq s (substring s 0 -1))) - s) -(defun org-add-angle-brackets (s) - (if (equal (substring s 0 1) "<") nil (setq s (concat "<" s))) - (if (equal (substring s -1) ">") nil (setq s (concat s ">"))) - s) - -(defun org-follow-timestamp-link () - (cond - ((org-at-date-range-p t) - (let ((org-agenda-start-on-weekday) - (t1 (match-string 1)) - (t2 (match-string 2))) - (setq t1 (time-to-days (org-time-string-to-time t1)) - t2 (time-to-days (org-time-string-to-time t2))) - (org-agenda-list nil t1 (1+ (- t2 t1))))) - ((org-at-timestamp-p t) - (org-agenda-list nil (time-to-days (org-time-string-to-time - (substring (match-string 1) 0 10))) - 1)) - (t (error "This should not happen")))) - - -(defun org-follow-bbdb-link (name) - "Follow a BBDB link to NAME." - (require 'bbdb) - (let ((inhibit-redisplay t) - (bbdb-electric-p nil)) - (catch 'exit - ;; Exact match on name - (bbdb-name (concat "\\`" name "\\'") nil) - (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) - ;; Exact match on name - (bbdb-company (concat "\\`" name "\\'") nil) - (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) - ;; Partial match on name - (bbdb-name name nil) - (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) - ;; Partial match on company - (bbdb-company name nil) - (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) - ;; General match including network address and notes - (bbdb name nil) - (when (= 0 (buffer-size (get-buffer "*BBDB*"))) - (delete-window (get-buffer-window "*BBDB*")) - (error "No matching BBDB record"))))) - - -(defun org-follow-info-link (name) - "Follow an info file & node link to NAME." - (if (or (string-match "\\(.*\\)::?\\(.*\\)" name) - (string-match "\\(.*\\)" name)) - (progn - (require 'info) - (if (match-string 2 name) ; If there isn't a node, choose "Top" - (Info-find-node (match-string 1 name) (match-string 2 name)) - (Info-find-node (match-string 1 name) "Top"))) - (message (concat "Could not open: " name)))) - -(defun org-follow-gnus-link (&optional group article) - "Follow a Gnus link to GROUP and ARTICLE." - (require 'gnus) - (funcall (cdr (assq 'gnus org-link-frame-setup))) - (if gnus-other-frame-object (select-frame gnus-other-frame-object)) - (if group (gnus-fetch-group group)) - (if article - (or (gnus-summary-goto-article article nil 'force) - (if (fboundp 'gnus-summary-insert-cached-articles) - (progn - (gnus-summary-insert-cached-articles) - (gnus-summary-goto-article article nil 'force)) - (message "Message could not be found."))))) - -(defun org-follow-vm-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) - (sit-for 0.1) - (when article - (vm-select-folder-buffer) - (widen) - (let ((case-fold-search t)) - (goto-char (point-min)) - (if (not (re-search-forward - (concat "^" "message-id: *" (regexp-quote article)))) - (error "Could not find the specified message in this folder")) - (vm-isearch-update) - (vm-isearch-narrow) - (vm-beginning-of-message) - (vm-summarize))))) - -(defun org-follow-wl-link (folder article) - "Follow a Wanderlust link to FOLDER and ARTICLE." - (setq article (org-add-angle-brackets article)) - (wl-summary-goto-folder-subr folder 'no-sync t nil t nil nil) - (if article (wl-summary-jump-to-msg-by-message-id article)) - (wl-summary-redisplay)) - -(defun org-follow-rmail-link (folder article) - "Follow an RMAIL link to FOLDER and ARTICLE." - (setq article (org-add-angle-brackets article)) - (let (message-number) - (save-excursion - (save-window-excursion - (rmail (if (string= folder "RMAIL") rmail-file-name folder)) - (setq message-number - (save-restriction - (widen) - (goto-char (point-max)) - (if (re-search-backward - (concat "^Message-ID:\\s-+" (regexp-quote - (or article ""))) - nil t) - (rmail-what-message)))))) - (if message-number - (progn - (rmail (if (string= folder "RMAIL") rmail-file-name folder)) - (rmail-show-message message-number) - message-number) - (error "Message not found")))) - -;;; mh-e integration based on planner-mode -(defun org-mhe-get-message-real-folder () - "Return the name of the current message real folder, so if you use -sequences, it will now work." - (save-excursion - (let* ((folder - (if (equal major-mode 'mh-folder-mode) - mh-current-folder - ;; Refer to the show buffer - mh-show-folder-buffer)) - (end-index - (if (boundp 'mh-index-folder) - (min (length mh-index-folder) (length folder)))) - ) - ;; a simple test on mh-index-data does not work, because - ;; mh-index-data is always nil in a show buffer. - (if (and (boundp 'mh-index-folder) - (string= mh-index-folder (substring folder 0 end-index))) - (if (equal major-mode 'mh-show-mode) - (save-window-excursion - (when (buffer-live-p (get-buffer folder)) - (progn - (pop-to-buffer folder) - (org-mhe-get-message-folder-from-index) - ) - )) - (org-mhe-get-message-folder-from-index) - ) - folder - ) - ))) - -(defun org-mhe-get-message-folder-from-index () - "Returns the name of the message folder in a index folder buffer." - (save-excursion - (mh-index-previous-folder) - (re-search-forward "^\\(+.*\\)$" nil t) - (message (match-string 1)))) - -(defun org-mhe-get-message-folder () - "Return the name of the current message folder. Be careful if you -use sequences." - (save-excursion - (if (equal major-mode 'mh-folder-mode) - mh-current-folder - ;; Refer to the show buffer - mh-show-folder-buffer))) - -(defun org-mhe-get-message-num () - "Return the number of the current message. Be careful if you -use sequences." - (save-excursion - (if (equal major-mode 'mh-folder-mode) - (mh-get-msg-num nil) - ;; Refer to the show buffer - (mh-show-buffer-message-number)))) - -(defun org-mhe-get-header (header) - "Return a header of the message in folder mode. This will create a -show buffer for the corresponding message. If you have a more clever -idea..." - (let* ((folder (org-mhe-get-message-folder)) - (num (org-mhe-get-message-num)) - (buffer (get-buffer-create (concat "show-" folder))) - (header-field)) - (with-current-buffer buffer - (mh-display-msg num folder) - (if (equal major-mode 'mh-folder-mode) - (mh-header-display) - (mh-show-header-display)) - (set-buffer buffer) - (setq header-field (mh-get-header-field header)) - (if (equal major-mode 'mh-folder-mode) - (mh-show) - (mh-show-show)) - header-field))) - -(defun org-follow-mhe-link (folder article) - "Follow an MHE link to FOLDER and ARTICLE. -If ARTICLE is nil FOLDER is shown. If the configuration variable -`org-mhe-search-all-folders' is t and `mh-searcher' is pick, -ARTICLE is searched in all folders. Indexed searches (swish++, -namazu, and others supported by MH-E) will always search in all -folders." - (require 'mh-e) - (require 'mh-search) - (require 'mh-utils) - (mh-find-path) - (if (not article) - (mh-visit-folder (mh-normalize-folder-name folder)) - (setq article (org-add-angle-brackets article)) - (mh-search-choose) - (if (equal mh-searcher 'pick) - (progn - (mh-search folder (list "--message-id" article)) - (when (and org-mhe-search-all-folders - (not (org-mhe-get-message-real-folder))) - (kill-this-buffer) - (mh-search "+" (list "--message-id" article)))) - (mh-search "+" article)) - (if (org-mhe-get-message-real-folder) - (mh-show-msg 1) - (kill-this-buffer) - (error "Message not found")))) - -;;; BibTeX links - -;; Use the custom search meachnism to construct and use search strings for -;; file links to BibTeX database entries. - -(defun org-create-file-search-in-bibtex () - "Create the search string and description for a BibTeX database entry." - (when (eq major-mode 'bibtex-mode) - ;; yes, we want to construct this search string. - ;; Make a good description for this entry, using names, year and the title - ;; Put it into the `description' variable which is dynamically scoped. - (let ((bibtex-autokey-names 1) - (bibtex-autokey-names-stretch 1) - (bibtex-autokey-name-case-convert-function 'identity) - (bibtex-autokey-name-separator " & ") - (bibtex-autokey-additional-names " et al.") - (bibtex-autokey-year-length 4) - (bibtex-autokey-name-year-separator " ") - (bibtex-autokey-titlewords 3) - (bibtex-autokey-titleword-separator " ") - (bibtex-autokey-titleword-case-convert-function 'identity) - (bibtex-autokey-titleword-length 'infty) - (bibtex-autokey-year-title-separator ": ")) - (setq description (bibtex-generate-autokey))) - ;; Now parse the entry, get the key and return it. - (save-excursion - (bibtex-beginning-of-entry) - (cdr (assoc "=key=" (bibtex-parse-entry)))))) - -(defun org-execute-file-search-in-bibtex (s) - "Find the link search string S as a key for a database entry." - (when (eq major-mode 'bibtex-mode) - ;; Yes, we want to do the search in this file. - ;; We construct a regexp that searches for "@entrytype{" followed by the key - (goto-char (point-min)) - (and (re-search-forward (concat "@[a-zA-Z]+[ \t\n]*{[ \t\n]*" - (regexp-quote s) "[ \t\n]*,") nil t) - (goto-char (match-beginning 0))) - (if (and (match-beginning 0) (equal current-prefix-arg '(16))) - ;; Use double prefix to indicate that any web link should be browsed - (let ((b (current-buffer)) (p (point))) - ;; Restore the window configuration because we just use the web link - (set-window-configuration org-window-config-before-follow-link) - (save-excursion (set-buffer b) (goto-char p) - (bibtex-url))) - (recenter 0)) ; Move entry start to beginning of window - ;; return t to indicate that the search is done. - t)) - -;; Finally add the functions to the right hooks. -(add-hook 'org-create-file-search-functions 'org-create-file-search-in-bibtex) -(add-hook 'org-execute-file-search-functions 'org-execute-file-search-in-bibtex) - -;; end of Bibtex link setup - -(defun org-upgrade-old-links (&optional query-description) - "Transfer old <...> style links to new [[...]] style links. -With arg query-description, ask at each match for a description text to use -for this link." - (interactive (list (y-or-n-p "Would you like to be queried for a description at each link?"))) - (save-excursion - (goto-char (point-min)) - (let ((re (concat "\\([^[]\\)<\\(" - "\\(" (mapconcat 'identity org-link-types "\\|") - "\\):" - "[^" org-non-link-chars "]+\\)>")) - l1 l2 (cnt 0)) - (while (re-search-forward re nil t) - (setq cnt (1+ cnt) - l1 (org-match-string-no-properties 2) - l2 (save-match-data (org-link-escape l1))) - (when query-description (setq l1 (read-string "Desc: " l1))) - (if (equal l1 l2) - (replace-match (concat (match-string 1) "[[" l1 "]]") t t) - (replace-match (concat (match-string 1) "[[" l2 "][" l1 "]]") t t))) - (message "%d matches have beed treated" cnt)))) - -(defun org-open-file (path &optional in-emacs line search) - "Open the file at PATH. -First, this expands any special file name abbreviations. Then the -configuration variable `org-file-apps' is checked if it contains an -entry for this file type, and if yes, the corresponding command is launched. -If no application is found, Emacs simply visits the file. -With optional argument IN-EMACS, Emacs will visit the file. -Optional LINE specifies a line to go to, optional SEARCH a string to -search for. If LINE or SEARCH is given, the file will always be -opened in Emacs. -If the file does not exist, an error is thrown." - (setq in-emacs (or in-emacs line search)) - (let* ((file (if (equal path "") - buffer-file-name - (substitute-in-file-name (expand-file-name path)))) - (apps (append org-file-apps (org-default-apps))) - (remp (and (assq 'remote apps) (org-file-remote-p file))) - (dirp (if remp nil (file-directory-p file))) - (dfile (downcase file)) - (old-buffer (current-buffer)) - (old-pos (point)) - (old-mode major-mode) - ext cmd) - (if (string-match "^.*\\.\\([a-zA-Z0-9]+\\.gz\\)$" dfile) - (setq ext (match-string 1 dfile)) - (if (string-match "^.*\\.\\([a-zA-Z0-9]+\\)$" dfile) - (setq ext (match-string 1 dfile)))) - (if in-emacs - (setq cmd 'emacs) - (setq cmd (or (and remp (cdr (assoc 'remote apps))) - (and dirp (cdr (assoc 'directory apps))) - (cdr (assoc ext apps)) - (cdr (assoc t apps))))) - (when (eq cmd 'mailcap) - (require 'mailcap) - (mailcap-parse-mailcaps) - (let* ((mime-type (mailcap-extension-to-mime (or ext ""))) - (command (mailcap-mime-info mime-type))) - (if (stringp command) - (setq cmd command) - (setq cmd 'emacs)))) - (if (and (not (eq cmd 'emacs)) ; Emacs has not problems with non-ex files - (not (file-exists-p file)) - (not org-open-non-existing-files)) - (error "No such file: %s" file)) - (cond - ((and (stringp cmd) (not (string-match "^\\s-*$" cmd))) - ;; Remove quotes around the file name - we'll use shell-quote-argument. - (if (string-match "['\"]%s['\"]" cmd) - (setq cmd (replace-match "%s" t t cmd))) - (setq cmd (format cmd (shell-quote-argument file))) - (save-window-excursion - (shell-command (concat cmd " &")))) - ((or (stringp cmd) - (eq cmd 'emacs)) -; (unless (equal (file-truename file) (file-truename (or buffer-file-name ""))) -; (funcall (cdr (assq 'file org-link-frame-setup)) file)) - (funcall (cdr (assq 'file org-link-frame-setup)) file) - (if line (goto-line line) - (if search (org-link-search search)))) - ((consp cmd) - (eval cmd)) - (t (funcall (cdr (assq 'file org-link-frame-setup)) file))) - (and (org-mode-p) (eq old-mode 'org-mode) - (or (not (equal old-buffer (current-buffer))) - (not (equal old-pos (point)))) - (org-mark-ring-push old-pos old-buffer)))) - -(defun org-default-apps () - "Return the default applications for this operating system." - (cond - ((eq system-type 'darwin) - org-file-apps-defaults-macosx) - ((eq system-type 'windows-nt) - org-file-apps-defaults-windowsnt) - (t org-file-apps-defaults-gnu))) - -(defun org-expand-file-name (path) - "Replace special path abbreviations and expand the file name." - (expand-file-name path)) - -(defvar ange-ftp-name-format) ; to silence the XEmacs compiler. -(defun org-file-remote-p (file) - "Test whether FILE specifies a location on a remote system. -Return non-nil if the location is indeed remote. - -For example, the filename \"/user@host:/foo\" specifies a location -on the system \"/user@host:\"." - (cond ((fboundp 'file-remote-p) - (file-remote-p file)) - ((fboundp 'tramp-handle-file-remote-p) - (tramp-handle-file-remote-p file)) - ((and (boundp 'ange-ftp-name-format) - (string-match (car ange-ftp-name-format) file)) - t) - (t nil))) - -(defvar org-insert-link-history nil - "Minibuffer history for links inserted with `org-insert-link'.") - -(defvar org-stored-links nil - "Contains the links stored with `org-store-link'.") - -;;;###autoload -(defun org-store-link (arg) - "\\<org-mode-map>Store an org-link to the current location. -This link can later be inserted into an org-buffer with -\\[org-insert-link]. -For some link types, a prefix arg is interpreted: -For links to usenet articles, arg negates `org-usenet-links-prefer-google'. -For file links, arg negates `org-context-in-file-links'." - (interactive "P") - (let (link cpltxt desc description search txt (pos (point))) - (cond - - ((eq major-mode 'bbdb-mode) - (setq cpltxt (concat - "bbdb:" - (or (bbdb-record-name (bbdb-current-record)) - (bbdb-record-company (bbdb-current-record)))) - link (org-make-link cpltxt))) - - ((eq major-mode 'Info-mode) - (setq link (org-make-link "info:" - (file-name-nondirectory Info-current-file) - ":" Info-current-node)) - (setq cpltxt (concat (file-name-nondirectory Info-current-file) - ":" Info-current-node))) - - ((eq major-mode 'calendar-mode) - (let ((cd (calendar-cursor-to-date))) - (setq link - (format-time-string - (car org-time-stamp-formats) - (apply 'encode-time - (list 0 0 0 (nth 1 cd) (nth 0 cd) (nth 2 cd) - nil nil nil)))))) - - ((or (eq major-mode 'vm-summary-mode) - (eq major-mode 'vm-presentation-mode)) - (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)) - (folder buffer-file-name) - (subject (vm-su-subject message)) - (author (vm-su-full-name message)) - (message-id (vm-su-message-id message))) - (setq message-id (org-remove-angle-brackets message-id)) - (setq folder (abbreviate-file-name folder)) - (if (string-match (concat "^" (regexp-quote vm-folder-directory)) - folder) - (setq folder (replace-match "" t t folder))) - (setq cpltxt (concat author " on: " subject)) - (setq link (org-make-link "vm:" folder "#" message-id))))) - - ((eq major-mode 'wl-summary-mode) - (let* ((msgnum (wl-summary-message-number)) - (message-id (elmo-message-field wl-summary-buffer-elmo-folder - msgnum 'message-id)) - (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)))) - (author (wl-summary-line-from)) ; FIXME: correct? - (subject "???")) ; FIXME: - (setq message-id (org-remove-angle-brackets message-id)) - (setq cpltxt (concat author " on: " subject)) - (setq link (org-make-link "wl:" wl-summary-buffer-folder-name - "#" message-id)))) - - ((or (equal major-mode 'mh-folder-mode) - (equal major-mode 'mh-show-mode)) - (let ((from-header (org-mhe-get-header "From:")) - (to-header (org-mhe-get-header "To:")) - (subject (org-mhe-get-header "Subject:"))) - (setq cpltxt (concat from-header " on: " subject)) - (setq link (org-make-link "mhe:" (org-mhe-get-message-real-folder) "#" - (org-remove-angle-brackets - (org-mhe-get-header "Message-Id:")))))) - - ((eq major-mode 'rmail-mode) - (save-excursion - (save-restriction - (rmail-narrow-to-non-pruned-header) - (let ((folder buffer-file-name) - (message-id (mail-fetch-field "message-id")) - (author (mail-fetch-field "from")) - (subject (mail-fetch-field "subject"))) - (setq message-id (org-remove-angle-brackets message-id)) - (setq cpltxt (concat author " on: " subject)) - (setq link (org-make-link "rmail:" folder "#" message-id)))))) - - ((eq major-mode 'gnus-group-mode) - (let ((group (cond ((fboundp 'gnus-group-group-name) ; depending on Gnus - (gnus-group-group-name)) ; version - ((fboundp 'gnus-group-name) - (gnus-group-name)) - (t "???")))) - (setq cpltxt (concat - (if (org-xor arg org-usenet-links-prefer-google) - "http://groups.google.com/groups?group=" - "gnus:") - group) - link (org-make-link cpltxt)))) - - ((memq major-mode '(gnus-summary-mode gnus-article-mode)) - (require 'gnus-sum) ; FIXME: I don't think this is needed, actually - (and (eq major-mode 'gnus-article-mode) (gnus-article-show-summary)) - (gnus-summary-beginning-of-article) - (let* ((group (car gnus-article-current)) - (article (cdr gnus-article-current)) - (header (gnus-summary-article-header article)) - (author (mail-header-from header)) - (message-id (mail-header-id header)) - (date (mail-header-date header)) - (subject (gnus-summary-subject-string))) - (setq cpltxt (concat author " on: " subject)) - (if (org-xor arg org-usenet-links-prefer-google) - (setq link - (concat - cpltxt "\n " - (format "http://groups.google.com/groups?as_umsgid=%s" - (org-fixup-message-id-for-http message-id)))) - (setq link (org-make-link "gnus:" group - "#" (number-to-string article)))))) - - ((eq major-mode 'w3-mode) - (setq cpltxt (url-view-url t) - link (org-make-link cpltxt))) - ((eq major-mode 'w3m-mode) - (setq cpltxt (or w3m-current-title w3m-current-url) - link (org-make-link w3m-current-url))) - - ((setq search (run-hook-with-args-until-success - 'org-create-file-search-functions)) - (setq link (concat "file:" (abbreviate-file-name buffer-file-name) - "::" search)) - (setq cpltxt (or description link))) - - ((eq major-mode 'image-mode) - (setq cpltxt (concat "file:" - (abbreviate-file-name buffer-file-name)) - link (org-make-link cpltxt))) - - ((eq major-mode 'dired-mode) - ;; link to the file in the current line - (setq cpltxt (concat "file:" - (abbreviate-file-name - (expand-file-name - (dired-get-filename nil t)))) - link (org-make-link cpltxt))) - - ((and buffer-file-name (org-mode-p)) - ;; Just link to current headline - (setq cpltxt (concat "file:" - (abbreviate-file-name buffer-file-name))) - ;; Add a context search string - (when (org-xor org-context-in-file-links arg) - ;; Check if we are on a target - (if (save-excursion - (skip-chars-forward "^>\n\r") - (and (re-search-backward "<<" nil t) - (looking-at "<<\\(.*?\\)>>") - (<= (match-beginning 0) pos) - (>= (match-end 0) pos))) - (setq cpltxt (concat cpltxt "::" (match-string 1))) - (setq txt (cond - ((org-on-heading-p) nil) - ((org-region-active-p) - (buffer-substring (region-beginning) (region-end))) - (t (buffer-substring (point-at-bol) (point-at-eol))))) - (when (or (null txt) (string-match "\\S-" txt)) - (setq cpltxt - (concat cpltxt "::" - (if org-file-link-context-use-camel-case - (org-make-org-heading-camel txt) - (org-make-org-heading-search-string txt))) - desc "NONE")))) - (if (string-match "::\\'" cpltxt) - (setq cpltxt (substring cpltxt 0 -2))) - (setq link (org-make-link cpltxt))) - - (buffer-file-name - ;; Just link to this file here. - (setq cpltxt (concat "file:" - (abbreviate-file-name buffer-file-name))) - ;; Add a context string - (when (org-xor org-context-in-file-links arg) - (setq txt (if (org-region-active-p) - (buffer-substring (region-beginning) (region-end)) - (buffer-substring (point-at-bol) (point-at-eol)))) - ;; Only use search option if there is some text. - (when (string-match "\\S-" txt) - (setq cpltxt - (concat cpltxt "::" - (if org-file-link-context-use-camel-case - (org-make-org-heading-camel txt) - (org-make-org-heading-search-string txt))) - desc "NONE"))) - (setq link (org-make-link cpltxt))) - - ((interactive-p) - (error "Cannot link to a buffer which is not visiting a file")) - - (t (setq link nil))) - - (if (consp link) (setq cpltxt (car link) link (cdr link))) - (setq link (or link cpltxt) - desc (or desc cpltxt)) - (if (equal desc "NONE") (setq desc nil)) - - (if (and (interactive-p) link) - (progn - (setq org-stored-links - (cons (list cpltxt link desc) org-stored-links)) - (message "Stored: %s" (or cpltxt link))) - (org-make-link-string link desc)))) - -(defun org-make-org-heading-search-string (&optional string heading) - "Make search string for STRING or current headline." - (interactive) - (let ((s (or string (org-get-heading)))) - (unless (and string (not heading)) - ;; We are using a headline, clean up garbage in there. - (if (string-match org-todo-regexp s) - (setq s (replace-match "" t t s))) - (if (string-match ":[a-zA-Z_@0-9:]+:[ \t]*$" s) - (setq s (replace-match "" t t s))) - (setq s (org-trim s)) - (if (string-match (concat "^\\(" org-quote-string "\\|" - org-comment-string "\\)") s) - (setq s (replace-match "" t t s))) - (while (string-match org-ts-regexp s) - (setq s (replace-match "" t t s)))) - (while (string-match "[^a-zA-Z_0-9 \t]+" s) - (setq s (replace-match " " t t s))) - (or string (setq s (concat "*" s))) ; Add * for headlines - (mapconcat 'identity (org-split-string s "[ \t]+") " "))) - -(defun org-make-org-heading-camel (&optional string heading) - "Make a CamelCase string for STRING or the current headline." - (interactive) - (let ((s (or string (org-get-heading)))) - (unless (and string (not heading)) - ;; We are using a headline, clean up garbage in there. - (if (string-match org-todo-regexp s) - (setq s (replace-match "" t t s))) - (if (string-match ":[a-zA-Z_@0-9:]+:[ \t]*$" s) - (setq s (replace-match "" t t s))) - (setq s (org-trim s)) - (if (string-match (concat "^\\(" org-quote-string "\\|" - org-comment-string "\\)") s) - (setq s (replace-match "" t t s))) - (while (string-match org-ts-regexp s) - (setq s (replace-match "" t t s)))) - (while (string-match "[^a-zA-Z_ \t]+" s) - (setq s (replace-match " " t t s))) - (or string (setq s (concat "*" s))) ; Add * for headlines - (mapconcat 'capitalize (org-split-string s "[ \t]+") ""))) - -(defun org-make-link (&rest strings) - "Concatenate STRINGS, format resulting string with `org-link-format'." - (format org-link-format (apply 'concat strings))) - -(defun org-make-link-string (link &optional description) - "Make a link with brackets, consisting of LINK and DESCRIPTION." - (if (eq org-link-style 'plain) - (if (equal description link) - link - (concat description "\n" link)) - (when (stringp description) - ;; Remove brackets from the description, they are fatal. - (while (string-match "\\[\\|\\]" description) - (setq description (replace-match "" t t description)))) - (when (equal (org-link-escape link) description) - ;; No description needed, it is identical - (setq description nil)) - (when (and (not description) - (not (equal link (org-link-escape link)))) - (setq description link)) - (concat "[[" (org-link-escape link) "]" - (if description (concat "[" description "]") "") - "]"))) - -(defconst org-link-escape-chars '(("[" . "%5B") ("]" . "%5D") (" " . "%20")) - "Association list of escapes for some characters problematic in links.") - -(defun org-link-escape (text) - "Escape charaters in TEXT that are problematic for links." - (when text - (let ((re (mapconcat (lambda (x) (regexp-quote (car x))) - org-link-escape-chars "\\|"))) - (while (string-match re text) - (setq text - (replace-match - (cdr (assoc (match-string 0 text) org-link-escape-chars)) - t t text))) - text))) - -(defun org-link-unescape (text) - "Reverse the action of `org-link-escape'." - (when text - (let ((re (mapconcat (lambda (x) (regexp-quote (cdr x))) - org-link-escape-chars "\\|"))) - (while (string-match re text) - (setq text - (replace-match - (car (rassoc (match-string 0 text) org-link-escape-chars)) - t t text))) - text))) - -(defun org-xor (a b) - "Exclusive or." - (if a (not b) b)) - -(defun org-get-header (header) - "Find a header field in the current buffer." - (save-excursion - (goto-char (point-min)) - (let ((case-fold-search t) s) - (cond - ((eq header 'from) - (if (re-search-forward "^From:\\s-+\\(.*\\)" nil t) - (setq s (match-string 1))) - (while (string-match "\"" s) - (setq s (replace-match "" t t s))) - (if (string-match "[<(].*" s) - (setq s (replace-match "" t t s)))) - ((eq header 'message-id) - (if (re-search-forward "^message-id:\\s-+\\(.*\\)" nil t) - (setq s (match-string 1)))) - ((eq header 'subject) - (if (re-search-forward "^subject:\\s-+\\(.*\\)" nil t) - (setq s (match-string 1))))) - (if (string-match "\\`[ \t\]+" s) (setq s (replace-match "" t t s))) - (if (string-match "[ \t\]+\\'" s) (setq s (replace-match "" t t s))) - s))) - - -(defun org-fixup-message-id-for-http (s) - "Replace special characters in a message id, so it can be used in an http query." - (while (string-match "<" s) - (setq s (replace-match "%3C" t t s))) - (while (string-match ">" s) - (setq s (replace-match "%3E" t t s))) - (while (string-match "@" s) - (setq s (replace-match "%40" t t s))) - s) - -(defun org-insert-link (&optional complete-file) - "Insert a link. At the prompt, enter the link. - -Completion can be used to select a link previously stored with -`org-store-link'. When the empty string is entered (i.e. if you just -press RET at the prompt), the link defaults to the most recently -stored link. As SPC triggers completion in the minibuffer, you need to -use M-SPC or C-q SPC to force the insertion of a space character. - -You will also be prompted for a description, and if one is given, it will -be displayed in the buffer instead of the link. - -If there is already a link at point, this command will allow you to edit link -and description parts. + (let ((pos (point)) + (dodollar (member "$" (plist-get org-format-latex-options :matchers))) + (lim (progn + (re-search-backward (concat "^\\(" paragraph-start "\\)") nil t) + (point))) + dd-on str (start 0) m re) + (goto-char pos) + (when dodollar + (setq str (concat (buffer-substring lim (point)) "\000 X$.") + re (nth 1 (assoc "$" org-latex-regexps))) + (while (string-match re str start) + (cond + ((= (match-end 0) (length str)) + (throw 'exit (cons "$" (+ lim (match-beginning 0))))) + ((= (match-end 0) (- (length str) 5)) + (throw 'exit nil)) + (t (setq start (match-end 0)))))) + (when (setq m (re-search-backward "\\(\\\\begin{[^}]*}\\|\\\\(\\|\\\\\\[\\)\\|\\(\\\\end{[^}]*}\\|\\\\)\\|\\\\\\]\\)\\|\\(\\$\\$\\)" lim t)) + (goto-char pos) + (and (match-beginning 1) (throw 'exit (cons (match-string 1) m))) + (and (match-beginning 2) (throw 'exit nil)) + ;; count $$ + (while (re-search-backward "\\$\\$" lim t) + (setq dd-on (not dd-on))) + (goto-char pos) + (if dd-on (cons "$$" m)))))) -With a \\[universal-argument] prefix, prompts for a file to link to. The file name can be -selected using completion. The path to the file will be relative to -the current directory if the file is in the current directory or a -subdirectory. Otherwise, the link will be the absolute path as -completed in the minibuffer (i.e. normally ~/path/to/file). -With two \\[universal-argument] prefixes, enforce an absolute path even if the file -is in the current directory or below. -With three \\[universal-argument] prefixes, negate the meaning of -`org-keep-stored-link-after-insertion'." - (interactive "P") - (let (link desc entry remove file (pos (point))) +(defun org-try-cdlatex-tab () + "Check if it makes sense to execute `cdlatex-tab', and do it if yes. +It makes sense to do so if `org-cdlatex-mode' is active and if the cursor is + - inside a LaTeX fragment, or + - after the first word in a line, where an abbreviation expansion could + insert a LaTeX environment." + (when org-cdlatex-mode (cond ((save-excursion - (skip-chars-forward "^]\n\r") - (and (re-search-backward "\\[\\[" nil t) - (looking-at org-bracket-link-regexp) - (<= (match-beginning 0) pos) - (>= (match-end 0) pos))) - ;; We do have a link at point, and we are going to edit it. - (setq remove (list (match-beginning 0) (match-end 0))) - (setq desc (if (match-end 3) (org-match-string-no-properties 3))) - (setq link (read-string "Link: " - (org-link-unescape - (org-match-string-no-properties 1))))) - ((equal complete-file '(4)) - ;; Completing read for file names. - (setq file (read-file-name "File: ")) - (let ((pwd (file-name-as-directory (expand-file-name "."))) - (pwd1 (file-name-as-directory (abbreviate-file-name - (expand-file-name "."))))) - (cond - ((equal complete-file '(16)) - (setq link (org-make-link - "file:" - (abbreviate-file-name (expand-file-name file))))) - ((string-match (concat "^" (regexp-quote pwd1) "\\(.+\\)") file) - (setq link (org-make-link "file:" (match-string 1 file)))) - ((string-match (concat "^" (regexp-quote pwd) "\\(.+\\)") - (expand-file-name file)) - (setq link (org-make-link - "file:" (match-string 1 (expand-file-name file))))) - (t (setq link (org-make-link "file:" file)))))) - (t - ;; Read link, with completion for stored links. - (setq link (org-completing-read - "Link: " org-stored-links nil nil nil - org-insert-link-history - (or (car (car org-stored-links))))) - (setq entry (assoc link org-stored-links)) - (if (funcall (if (equal complete-file '(64)) 'not 'identity) - (not org-keep-stored-link-after-insertion)) - (setq org-stored-links (delq (assoc link org-stored-links) - org-stored-links))) - (setq link (if entry (nth 1 entry) link) - desc (or desc (nth 2 entry))))) - - (if (string-match org-plain-link-re link) - ;; URL-like link, normalize the use of angular brackets. - (setq link (org-make-link (org-remove-angle-brackets link)))) - - ;; Check if we are linking to the current file with a search option - ;; If yes, simplify the link by using only the search option. - (when (and buffer-file-name - (string-match "\\<file:\\(.+?\\)::\\([^>]+\\)" link)) - (let* ((path (match-string 1 link)) - (case-fold-search nil) - (search (match-string 2 link))) - (save-match-data - (if (equal (file-truename buffer-file-name) (file-truename path)) - ;; We are linking to this same file, with a search option - (setq link search))))) - - ;; Check if we can/should use a relative path. If yes, simplify the link - (when (string-match "\\<file:\\(.*\\)" link) - (let* ((path (match-string 1 link)) - (case-fold-search nil)) - (cond - ((eq org-link-file-path-type 'absolute) - (setq path (abbreviate-file-name (expand-file-name path)))) - ((eq org-link-file-path-type 'noabbrev) - (setq path (expand-file-name path))) - ((eq org-link-file-path-type 'relative) - (setq path (file-relative-name path))) - (t - (save-match-data - (if (string-match (concat "^" (regexp-quote - (file-name-as-directory - (expand-file-name ".")))) - (expand-file-name path)) - ;; We are linking a file with relative path name. - (setq path (substring (expand-file-name path) - (match-end 0))))))) - (setq link (concat "file:" path)))) - - (setq desc (read-string "Description: " desc)) - (unless (string-match "\\S-" desc) (setq desc nil)) - (if remove (apply 'delete-region remove)) - (insert (org-make-link-string link desc)))) - -(defun org-completing-read (&rest args) - (let ((minibuffer-local-completion-map - (copy-keymap minibuffer-local-completion-map))) - (define-key minibuffer-local-completion-map " " 'self-insert-command) - (apply 'completing-read args))) - -;;;; Hooks for remember.el - -(defvar org-finish-function nil) - -;;;###autoload -(defun org-remember-annotation () - "Return a link to the current location as an annotation for remember.el. -If you are using Org-mode files as target for data storage with -remember.el, then the annotations should include a link compatible with the -conventions in Org-mode. This function returns such a link." - (org-store-link nil)) - -(defconst org-remember-help -"Select a destination location for the note. -UP/DOWN=headline TAB=cycle visibility [Q]uit RET/<left>/<right>=Store -RET at beg-of-buf -> Append to file as level 2 headline -RET on headline -> Store as sublevel entry to current headline -<left>/<right> -> before/after current headline, same headings level") - -;;;###autoload -(defun org-remember-apply-template () - "Initialize *remember* buffer with template, invoke `org-mode'. -This function should be placed into `remember-mode-hook' and in fact requires -to be run from that hook to fucntion properly." - (if org-remember-templates - - (let* ((entry (if (= (length org-remember-templates) 1) - (cdar org-remember-templates) - (message "Select template: %s" - (mapconcat - (lambda (x) (char-to-string (car x))) - org-remember-templates " ")) - (cdr (assoc (read-char-exclusive) org-remember-templates)))) - (tpl (car entry)) - (file (if (consp (cdr entry)) (nth 1 entry))) - (v-t (format-time-string (car org-time-stamp-formats) (org-current-time))) - (v-T (format-time-string (cdr org-time-stamp-formats) (org-current-time))) - (v-u (concat "[" (substring v-t 1 -1) "]")) - (v-U (concat "[" (substring v-T 1 -1) "]")) - (v-a annotation) ; defined in `remember-mode' - (v-i initial) ; defined in `remember-mode' - (v-n user-full-name) - ) - (unless tpl (setq tpl "") (message "No template") (ding)) - (insert tpl) (goto-char (point-min)) - (while (re-search-forward "%\\([tTuTai]\\)" nil t) - (when (and initial (equal (match-string 0) "%i")) - (save-match-data - (let* ((lead (buffer-substring - (point-at-bol) (match-beginning 0)))) - (setq v-i (mapconcat 'identity - (org-split-string initial "\n") - (concat "\n" lead)))))) - (replace-match - (or (eval (intern (concat "v-" (match-string 1)))) "") - t t)) - (let ((org-startup-folded nil) - (org-startup-with-deadline-check nil)) - (org-mode)) - (if (and file (string-match "\\S-" file) (not (file-directory-p file))) - (org-set-local 'org-default-notes-file file)) - (goto-char (point-min)) - (if (re-search-forward "%\\?" nil t) (replace-match ""))) - (let ((org-startup-folded nil) - (org-startup-with-deadline-check nil)) - (org-mode))) - (org-set-local 'org-finish-function 'remember-buffer)) - -;;;###autoload -(defun org-remember-handler () - "Store stuff from remember.el into an org file. -First prompts for an org file. If the user just presses return, the value -of `org-default-notes-file' is used. -Then the command offers the headings tree of the selected file in order to -file the text at a specific location. -You can either immediately press RET to get the note appended to the -file, or you can use vertical cursor motion and visibility cycling (TAB) to -find a better place. Then press RET or <left> or <right> in insert the note. - -Key Cursor position Note gets inserted ------------------------------------------------------------------------------ -RET buffer-start as level 2 heading at end of file -RET on headline as sublevel of the heading at cursor -RET no heading at cursor position, level taken from context. - Or use prefix arg to specify level manually. -<left> on headline as same level, before current heading -<right> on headline as same level, after current heading - -So the fastest way to store the note is to press RET RET to append it to -the default file. This way your current train of thought is not -interrupted, in accordance with the principles of remember.el. But with -little extra effort, you can push it directly to the correct location. - -Before being stored away, the function ensures that the text has a -headline, i.e. a first line that starts with a \"*\". If not, a headline -is constructed from the current date and some additional data. - -If the variable `org-adapt-indentation' is non-nil, the entire text is -also indented so that it starts in the same column as the headline -\(i.e. after the stars). - -See also the variable `org-reverse-note-order'." - (catch 'quit - (let* ((txt (buffer-substring (point-min) (point-max))) - (fastp current-prefix-arg) - (file (if fastp org-default-notes-file (org-get-org-file))) - (visiting (find-buffer-visiting file)) - (org-startup-with-deadline-check nil) - (org-startup-folded nil) - (org-startup-align-all-tables nil) - spos level indent reversed) - ;; Modify text so that it becomes a nice subtree which can be inserted - ;; into an org tree. - (let* ((lines (split-string txt "\n")) - first) - ;; remove empty lines at the beginning - (while (and lines (string-match "^[ \t]*\n" (car lines))) - (setq lines (cdr lines))) - (setq first (car lines) lines (cdr lines)) - (if (string-match "^\\*+" first) - ;; Is already a headline - (setq indent nil) - ;; We need to add a headline: Use time and first buffer line - (setq lines (cons first lines) - first (concat "* " (current-time-string) - " (" (remember-buffer-desc) ")") - indent " ")) - (if (and org-adapt-indentation indent) - (setq lines (mapcar (lambda (x) (concat indent x)) lines))) - (setq txt (concat first "\n" - (mapconcat 'identity lines "\n")))) - ;; Find the file - (if (not visiting) - (find-file-noselect file)) - (with-current-buffer (get-file-buffer file) - (save-excursion (and (goto-char (point-min)) - (not (re-search-forward "^\\* " nil t)) - (insert "\n* Notes\n"))) - (setq reversed (org-notes-order-reversed-p)) - (save-excursion - (save-restriction - (widen) - ;; Ask the User for a location - (setq spos (if fastp 1 (org-get-location - (current-buffer) - org-remember-help))) - (if (not spos) (throw 'quit nil)) ; return nil to show we did - ; not handle this note - (goto-char spos) - (cond ((and (bobp) (not reversed)) - ;; Put it at the end, as level 2 - (save-restriction - (widen) - (goto-char (point-max)) - (if (not (bolp)) (newline)) - (org-paste-subtree 2 txt))) - ((and (bobp) reversed) - ;; Put it at the start, as level 1 - (save-restriction - (widen) - (goto-char (point-min)) - (re-search-forward "^\\*" nil t) - (beginning-of-line 1) - (org-paste-subtree 1 txt))) - ((and (org-on-heading-p nil) (not current-prefix-arg)) - ;; Put it below this entry, at the beg/end of the subtree - (org-back-to-heading) - (setq level (funcall outline-level)) - (if reversed - (outline-end-of-heading) - (outline-end-of-subtree)) - (if (not (bolp)) (newline)) - (beginning-of-line 1) - (org-paste-subtree (org-get-legal-level level 1) txt)) - (t - ;; Put it right there, with automatic level determined by - ;; org-paste-subtree or from prefix arg - (org-paste-subtree current-prefix-arg txt))) - (when remember-save-after-remembering - (save-buffer) - (if (not visiting) (kill-buffer (current-buffer))))))))) - t) ;; return t to indicate that we took care of this note. - -(defun org-get-org-file () - "Read a filename, with default directory `org-directory'." - (let ((default (or org-default-notes-file remember-data-file))) - (read-file-name (format "File name [%s]: " default) - (file-name-as-directory org-directory) - default))) - -(defun org-notes-order-reversed-p () - "Check if the current file should receive notes in reversed order." - (cond - ((not org-reverse-note-order) nil) - ((eq t org-reverse-note-order) t) - ((not (listp org-reverse-note-order)) nil) - (t (catch 'exit - (let ((all org-reverse-note-order) - entry) - (while (setq entry (pop all)) - (if (string-match (car entry) buffer-file-name) - (throw 'exit (cdr entry)))) - nil))))) - -;;;; Tables - -;; Watch out: Here we are talking about two different kind of tables. -;; Most of the code is for the tables created with the Org-mode table editor. -;; Sometimes, we talk about tables created and edited with the table.el -;; Emacs package. We call the former org-type tables, and the latter -;; table.el-type tables. - - -(defun org-before-change-function (beg end) - "Every change indicates that a table might need an update." - (setq org-table-may-need-update t)) - -(defconst org-table-line-regexp "^[ \t]*|" - "Detects an org-type table line.") -(defconst org-table-dataline-regexp "^[ \t]*|[^-]" - "Detects an org-type table line.") -(defconst org-table-auto-recalculate-regexp "^[ \t]*| *# *\\(|\\|$\\)" - "Detects a table line marked for automatic recalculation.") -(defconst org-table-recalculate-regexp "^[ \t]*| *[#*] *\\(|\\|$\\)" - "Detects a table line marked for automatic recalculation.") -(defconst org-table-calculate-mark-regexp "^[ \t]*| *[!$^_#*] *\\(|\\|$\\)" - "Detects a table line marked for automatic recalculation.") -(defconst org-table-hline-regexp "^[ \t]*|-" - "Detects an org-type table hline.") -(defconst org-table1-hline-regexp "^[ \t]*\\+-[-+]" - "Detects a table-type table hline.") -(defconst org-table-any-line-regexp "^[ \t]*\\(|\\|\\+-[-+]\\)" - "Detects an org-type or table-type table.") -(defconst org-table-border-regexp "^[ \t]*[^| \t]" - "Searching from within a table (any type) this finds the first line -outside the table.") -(defconst org-table-any-border-regexp "^[ \t]*[^|+ \t]" - "Searching from within a table (any type) this finds the first line -outside the table.") - -(defun org-table-create-with-table.el () - "Use the table.el package to insert a new table. -If there is already a table at point, convert between Org-mode tables -and table.el tables." - (interactive) - (require 'table) - (cond - ((org-at-table.el-p) - (if (y-or-n-p "Convert table to Org-mode table? ") - (org-table-convert))) - ((org-at-table-p) - (if (y-or-n-p "Convert table to table.el table? ") - (org-table-convert))) - (t (call-interactively 'table-insert)))) - -(defun org-table-create-or-convert-from-region (arg) - "Convert region to table, or create an empty table. -If there is an active region, convert it to a table. If there is no such -region, create an empty table." - (interactive "P") - (if (org-region-active-p) - (org-table-convert-region (region-beginning) (region-end) arg) - (org-table-create arg))) - -(defun org-table-create (&optional size) - "Query for a size and insert a table skeleton. -SIZE is a string Columns x Rows like for example \"3x2\"." - (interactive "P") - (unless size - (setq size (read-string - (concat "Table size Columns x Rows [e.g. " - org-table-default-size "]: ") - "" nil org-table-default-size))) - - (let* ((pos (point)) - (indent (make-string (current-column) ?\ )) - (split (org-split-string size " *x *")) - (rows (string-to-number (nth 1 split))) - (columns (string-to-number (car split))) - (line (concat (apply 'concat indent "|" (make-list columns " |")) - "\n"))) - (if (string-match "^[ \t]*$" (buffer-substring-no-properties - (point-at-bol) (point))) - (beginning-of-line 1) - (newline)) - ;; (mapcar (lambda (x) (insert line)) (make-list rows t)) - (dotimes (i rows) (insert line)) - (goto-char pos) - (if (> rows 1) - ;; Insert a hline after the first row. - (progn - (end-of-line 1) - (insert "\n|-") - (goto-char pos))) - (org-table-align))) - -(defun org-table-convert-region (beg0 end0 &optional nspace) - "Convert region to a table. -The region goes from BEG0 to END0, but these borders will be moved -slightly, to make sure a beginning of line in the first line is included. -When NSPACE is non-nil, it indicates the minimum number of spaces that -separate columns (default: just one space)." - (interactive "rP") - (let* ((beg (min beg0 end0)) - (end (max beg0 end0)) - (tabsep t) - re) - (goto-char beg) - (beginning-of-line 1) - (setq beg (move-marker (make-marker) (point))) - (goto-char end) - (if (bolp) (backward-char 1) (end-of-line 1)) - (setq end (move-marker (make-marker) (point))) - ;; Lets see if this is tab-separated material. If every nonempty line - ;; contains a tab, we will assume that it is tab-separated material - (if nspace - (setq tabsep nil) - (goto-char beg) - (and (re-search-forward "^[^\n\t]+$" end t) (setq tabsep nil))) - (if nspace (setq tabsep nil)) - (if tabsep - (setq re "^\\|\t") - (setq re (format "^ *\\| *\t *\\| \\{%d,\\}" - (max 1 (prefix-numeric-value nspace))))) - (goto-char beg) - (while (re-search-forward re end t) - (replace-match "| " t t)) - (goto-char beg) - (insert " ") - (org-table-align))) - -(defun org-table-import (file arg) - "Import FILE as a table. -The file is assumed to be tab-separated. Such files can be produced by most -spreadsheet and database applications. If no tabs (at least one per line) -are found, lines will be split on whitespace into fields." - (interactive "f\nP") - (or (bolp) (newline)) - (let ((beg (point)) - (pm (point-max))) - (insert-file-contents file) - (org-table-convert-region beg (+ (point) (- (point-max) pm)) arg))) - -(defun org-table-export () - "Export table as a tab-separated file. -Such a file can be imported into a spreadsheet program like Excel." - (interactive) - (let* ((beg (org-table-begin)) - (end (org-table-end)) - (table (buffer-substring beg end)) - (file (read-file-name "Export table to: ")) - buf) - (unless (or (not (file-exists-p file)) - (y-or-n-p (format "Overwrite file %s? " file))) - (error "Abort")) - (with-current-buffer (find-file-noselect file) - (setq buf (current-buffer)) - (erase-buffer) - (fundamental-mode) - (insert table) - (goto-char (point-min)) - (while (re-search-forward "^[ \t]*|[ \t]*" nil t) - (replace-match "" t t) - (end-of-line 1)) - (goto-char (point-min)) - (while (re-search-forward "[ \t]*|[ \t]*$" nil t) - (replace-match "" t t) - (goto-char (min (1+ (point)) (point-max)))) - (goto-char (point-min)) - (while (re-search-forward "^-[-+]*$" nil t) - (replace-match "") - (if (looking-at "\n") - (delete-char 1))) - (goto-char (point-min)) - (while (re-search-forward "[ \t]*|[ \t]*" nil t) - (replace-match "\t" t t)) - (save-buffer)) - (kill-buffer buf))) - -(defvar org-table-aligned-begin-marker (make-marker) - "Marker at the beginning of the table last aligned. -Used to check if cursor still is in that table, to minimize realignment.") -(defvar org-table-aligned-end-marker (make-marker) - "Marker at the end of the table last aligned. -Used to check if cursor still is in that table, to minimize realignment.") -(defvar org-table-last-alignment nil - "List of flags for flushright alignment, from the last re-alignment. -This is being used to correctly align a single field after TAB or RET.") -(defvar org-table-last-column-widths nil - "List of max width of fields in each column. -This is being used to correctly align a single field after TAB or RET.") - -(defvar org-last-recalc-line nil) -(defconst org-narrow-column-arrow "=>" - "Used as display property in narrowed table columns.") - -(defun org-table-align () - "Align the table at point by aligning all vertical bars." - (interactive) - (let* ( - ;; Limits of table - (beg (org-table-begin)) - (end (org-table-end)) - ;; Current cursor position - (linepos (org-current-line)) - (colpos (org-table-current-column)) - (winstart (window-start)) - (winstartline (org-current-line (min winstart (1- (point-max))))) - lines (new "") lengths l typenums ty fields maxfields i - column - (indent "") cnt frac - rfmt hfmt - (spaces '(1 . 1)) - (sp1 (car spaces)) - (sp2 (cdr spaces)) - (rfmt1 (concat - (make-string sp2 ?\ ) "%%%s%ds" (make-string sp1 ?\ ) "|")) - (hfmt1 (concat - (make-string sp2 ?-) "%s" (make-string sp1 ?-) "+")) - emptystrings links dates narrow fmax f1 len c e) - (untabify beg end) - (remove-text-properties beg end '(org-cwidth t org-dwidth t display t)) - ;; Check if we have links or dates - (goto-char beg) - (setq links (re-search-forward org-bracket-link-regexp end t)) - (goto-char beg) - (setq dates (and org-display-custom-times - (re-search-forward org-ts-regexp-both end t))) - ;; Make sure the link properties are right - (when links (goto-char beg) (while (org-activate-bracket-links end))) - ;; Make sure the date properties are right - (when dates (goto-char beg) (while (org-activate-dates end))) - - ;; Check if we are narrowing any columns - (goto-char beg) - (setq narrow (and org-format-transports-properties-p - (re-search-forward "<[0-9]+>" end t))) - ;; Get the rows - (setq lines (org-split-string - (buffer-substring beg end) "\n")) - ;; Store the indentation of the first line - (if (string-match "^ *" (car lines)) - (setq indent (make-string (- (match-end 0) (match-beginning 0)) ?\ ))) - ;; Mark the hlines by setting the corresponding element to nil - ;; At the same time, we remove trailing space. - (setq lines (mapcar (lambda (l) - (if (string-match "^ *|-" l) - nil - (if (string-match "[ \t]+$" l) - (substring l 0 (match-beginning 0)) - l))) - lines)) - ;; Get the data fields by splitting the lines. - (setq fields (mapcar - (lambda (l) - (org-split-string l " *| *")) - (delq nil (copy-sequence lines)))) - ;; How many fields in the longest line? - (condition-case nil - (setq maxfields (apply 'max (mapcar 'length fields))) - (error - (kill-region beg end) - (org-table-create org-table-default-size) - (error "Empty table - created default table"))) - ;; A list of empty strings to fill any short rows on output - (setq emptystrings (make-list maxfields "")) - ;; Check for special formatting. - (setq i -1) - (while (< (setq i (1+ i)) maxfields) ;; Loop over all columns - (setq column (mapcar (lambda (x) (or (nth i x) "")) fields)) - ;; Check if there is an explicit width specified - (when (and org-table-limit-column-width narrow) - (setq c column fmax nil) - (while c - (setq e (pop c)) - (if (and (stringp e) (string-match "^<\\([0-9]+\\)>$" e)) - (setq fmax (string-to-number (match-string 1 e)) c nil))) - ;; Find fields that are wider than fmax, and shorten them - (when fmax - (loop for xx in column do - (when (and (stringp xx) - (> (org-string-width xx) fmax)) - (org-add-props xx nil - 'help-echo - (concat "Clipped table field, use C-c ` to edit. Full value is:\n" (org-no-properties (copy-sequence xx)))) - (setq f1 (min fmax (or (string-match org-bracket-link-regexp xx) fmax))) - (unless (> f1 1) - (error "Cannot narrow field starting with wide link \"%s\"" - (match-string 0 xx))) - (add-text-properties f1 (length xx) (list 'org-cwidth t) xx) - (add-text-properties (- f1 2) f1 - (list 'display org-narrow-column-arrow) - xx))))) - ;; Get the maximum width for each column - (push (apply 'max 1 (mapcar 'org-string-width column)) lengths) - ;; Get the fraction of numbers, to decide about alignment of the column - (setq cnt 0 frac 0.0) - (loop for x in column do - (if (equal x "") - nil - (setq frac ( / (+ (* frac cnt) - (if (string-match org-table-number-regexp x) 1 0)) - (setq cnt (1+ cnt)))))) - (push (>= frac org-table-number-fraction) typenums)) - (setq lengths (nreverse lengths) typenums (nreverse typenums)) - - ;; Store the alignment of this table, for later editing of single fields - (setq org-table-last-alignment typenums - org-table-last-column-widths lengths) - - ;; With invisible characters, `format' does not get the field width right - ;; So we need to make these fields wide by hand. - (when links - (loop for i from 0 upto (1- maxfields) do - (setq len (nth i lengths)) - (loop for j from 0 upto (1- (length fields)) do - (setq c (nthcdr i (car (nthcdr j fields)))) - (if (and (stringp (car c)) - (string-match org-bracket-link-regexp (car c)) - (< (org-string-width (car c)) len)) - (setcar c (concat (car c) (make-string (- len (org-string-width (car c))) ?\ ))))))) - - ;; Compute the formats needed for output of the table - (setq rfmt (concat indent "|") hfmt (concat indent "|")) - (while (setq l (pop lengths)) - (setq ty (if (pop typenums) "" "-")) ; number types flushright - (setq rfmt (concat rfmt (format rfmt1 ty l)) - hfmt (concat hfmt (format hfmt1 (make-string l ?-))))) - (setq rfmt (concat rfmt "\n") - hfmt (concat (substring hfmt 0 -1) "|\n")) - - (setq new (mapconcat - (lambda (l) - (if l (apply 'format rfmt - (append (pop fields) emptystrings)) - hfmt)) - lines "")) - ;; Replace the old one - (delete-region beg end) - (move-marker end nil) - (move-marker org-table-aligned-begin-marker (point)) - (insert new) - (move-marker org-table-aligned-end-marker (point)) - (when (and orgtbl-mode (not (org-mode-p))) - (goto-char org-table-aligned-begin-marker) - (while (org-hide-wide-columns org-table-aligned-end-marker))) - ;; Try to move to the old location - (goto-line winstartline) - (setq winstart (point-at-bol)) - (goto-line linepos) - (set-window-start (selected-window) winstart 'noforce) - (org-table-goto-column colpos) - (setq org-table-may-need-update nil) - )) - -(defun org-string-width (s) - "Compute width of string, ignoring invisible characters. -This ignores character with invisibility property `org-link', and also -characters with property `org-cwidth', because these will become invisible -upon the next fontification round." - (let (b l) - (when (or (eq t buffer-invisibility-spec) - (assq 'org-link buffer-invisibility-spec)) - (while (setq b (text-property-any 0 (length s) - 'invisible 'org-link s)) - (setq s (concat (substring s 0 b) - (substring s (or (next-single-property-change - b 'invisible s) (length s))))))) - (while (setq b (text-property-any 0 (length s) 'org-cwidth t s)) - (setq s (concat (substring s 0 b) - (substring s (or (next-single-property-change - b 'org-cwidth s) (length s)))))) - (setq l (string-width s) b -1) - (while (setq b (text-property-any (1+ b) (length s) 'org-dwidth t s)) - (setq l (- l (get-text-property b 'org-dwidth-n s)))) - l)) - -(defun org-table-begin (&optional table-type) - "Find the beginning of the table and return its position. -With argument TABLE-TYPE, go to the beginning of a table.el-type table." - (save-excursion - (if (not (re-search-backward - (if table-type org-table-any-border-regexp - org-table-border-regexp) - nil t)) - (progn (goto-char (point-min)) (point)) - (goto-char (match-beginning 0)) - (beginning-of-line 2) - (point)))) - -(defun org-table-end (&optional table-type) - "Find the end of the table and return its position. -With argument TABLE-TYPE, go to the end of a table.el-type table." - (save-excursion - (if (not (re-search-forward - (if table-type org-table-any-border-regexp - org-table-border-regexp) - nil t)) - (goto-char (point-max)) - (goto-char (match-beginning 0))) - (point-marker))) - -(defun org-table-justify-field-maybe (&optional new) - "Justify the current field, text to left, number to right. -Optional argument NEW may specify text to replace the current field content." - (cond - ((and (not new) org-table-may-need-update)) ; Realignment will happen anyway - ((org-at-table-hline-p)) - ((and (not new) - (or (not (equal (marker-buffer org-table-aligned-begin-marker) - (current-buffer))) - (< (point) org-table-aligned-begin-marker) - (>= (point) org-table-aligned-end-marker))) - ;; This is not the same table, force a full re-align - (setq org-table-may-need-update t)) - (t ;; realign the current field, based on previous full realign - (let* ((pos (point)) s - (col (org-table-current-column)) - (num (if (> col 0) (nth (1- col) org-table-last-alignment))) - l f n o e) - (when (> col 0) - (skip-chars-backward "^|\n") - (if (looking-at " *\\([^|\n]*?\\) *\\(|\\|$\\)") - (progn - (setq s (match-string 1) - o (match-string 0) - l (max 1 (- (match-end 0) (match-beginning 0) 3)) - e (not (= (match-beginning 2) (match-end 2)))) - (setq f (format (if num " %%%ds %s" " %%-%ds %s") - l (if e "|" (setq org-table-may-need-update t) "")) - n (format f s)) - (if new - (if (<= (length new) l) ;; FIXME: length -> str-width? - (setq n (format f new)) - (setq n (concat new "|") org-table-may-need-update t))) - (or (equal n o) - (let (org-table-may-need-update) - (replace-match n)))) - (setq org-table-may-need-update t)) - (goto-char pos)))))) - -(defun org-table-next-field () - "Go to the next field in the current table, creating new lines as needed. -Before doing so, re-align the table if necessary." - (interactive) - (org-table-maybe-eval-formula) - (org-table-maybe-recalculate-line) - (if (and org-table-automatic-realign - org-table-may-need-update) - (org-table-align)) - (let ((end (org-table-end))) - (if (org-at-table-hline-p) - (end-of-line 1)) - (condition-case nil - (progn - (re-search-forward "|" end) - (if (looking-at "[ \t]*$") - (re-search-forward "|" end)) - (if (and (looking-at "-") - org-table-tab-jumps-over-hlines - (re-search-forward "^[ \t]*|\\([^-]\\)" end t)) - (goto-char (match-beginning 1))) - (if (looking-at "-") - (progn - (beginning-of-line 0) - (org-table-insert-row 'below)) - (if (looking-at " ") (forward-char 1)))) - (error - (org-table-insert-row 'below))))) - -(defun org-table-previous-field () - "Go to the previous field in the table. -Before doing so, re-align the table if necessary." - (interactive) - (org-table-justify-field-maybe) - (org-table-maybe-recalculate-line) - (if (and org-table-automatic-realign - org-table-may-need-update) - (org-table-align)) - (if (org-at-table-hline-p) - (end-of-line 1)) - (re-search-backward "|" (org-table-begin)) - (re-search-backward "|" (org-table-begin)) - (while (looking-at "|\\(-\\|[ \t]*$\\)") - (re-search-backward "|" (org-table-begin))) - (if (looking-at "| ?") - (goto-char (match-end 0)))) - -(defun org-table-next-row () - "Go to the next row (same column) in the current table. -Before doing so, re-align the table if necessary." - (interactive) - (org-table-maybe-eval-formula) - (org-table-maybe-recalculate-line) - (if (or (looking-at "[ \t]*$") - (save-excursion (skip-chars-backward " \t") (bolp))) - (newline) - (if (and org-table-automatic-realign - org-table-may-need-update) - (org-table-align)) - (let ((col (org-table-current-column))) - (beginning-of-line 2) - (if (or (not (org-at-table-p)) - (org-at-table-hline-p)) - (progn - (beginning-of-line 0) - (org-table-insert-row 'below))) - (org-table-goto-column col) - (skip-chars-backward "^|\n\r") - (if (looking-at " ") (forward-char 1))))) - -(defun org-table-copy-down (n) - "Copy a field down in the current column. -If the field at the cursor is empty, copy into it the content of the nearest -non-empty field above. With argument N, use the Nth non-empty field. -If the current field is not empty, it is copied down to the next row, and -the cursor is moved with it. Therefore, repeating this command causes the -column to be filled row-by-row. -If the variable `org-table-copy-increment' is non-nil and the field is an -integer, it will be incremented while copying." - (interactive "p") - (let* ((colpos (org-table-current-column)) - (field (org-table-get-field)) - (non-empty (string-match "[^ \t]" field)) - (beg (org-table-begin)) - txt) - (org-table-check-inside-data-field) - (if non-empty - (progn - (setq txt (org-trim field)) - (org-table-next-row) - (org-table-blank-field)) - (save-excursion - (setq txt - (catch 'exit - (while (progn (beginning-of-line 1) - (re-search-backward org-table-dataline-regexp - beg t)) - (org-table-goto-column colpos t) - (if (and (looking-at - "|[ \t]*\\([^| \t][^|]*?\\)[ \t]*|") - (= (setq n (1- n)) 0)) - (throw 'exit (match-string 1)))))))) - (if txt - (progn - (if (and org-table-copy-increment - (string-match "^[0-9]+$" txt)) - (setq txt (format "%d" (+ (string-to-number txt) 1)))) - (insert txt) - (org-table-maybe-recalculate-line) - (org-table-align)) - (error "No non-empty field found")))) - -(defun org-table-check-inside-data-field () - "Is point inside a table data field? -I.e. not on a hline or before the first or after the last column? -This actually throws an error, so it aborts the current command." - (if (or (not (org-at-table-p)) - (= (org-table-current-column) 0) - (org-at-table-hline-p) - (looking-at "[ \t]*$")) - (error "Not in table data field"))) - -(defvar org-table-clip nil - "Clipboard for table regions.") - -(defun org-table-blank-field () - "Blank the current table field or active region." - (interactive) - (org-table-check-inside-data-field) - (if (and (interactive-p) (org-region-active-p)) - (let (org-table-clip) - (org-table-cut-region (region-beginning) (region-end))) - (skip-chars-backward "^|") - (backward-char 1) - (if (looking-at "|[^|\n]+") - (let* ((pos (match-beginning 0)) - (match (match-string 0)) - (len (org-string-width match))) - (replace-match (concat "|" (make-string (1- len) ?\ ))) - (goto-char (+ 2 pos)) - (substring match 1))))) - -(defun org-table-get-field (&optional n replace) - "Return the value of the field in column N of current row. -N defaults to current field. -If REPLACE is a string, replace field with this value. The return value -is always the old value." - (and n (org-table-goto-column n)) - (skip-chars-backward "^|\n") - (backward-char 1) - (if (looking-at "|[^|\r\n]*") - (let* ((pos (match-beginning 0)) - (val (buffer-substring (1+ pos) (match-end 0)))) - (if replace - (replace-match (concat "|" replace))) - (goto-char (min (point-at-eol) (+ 2 pos))) - val) - (forward-char 1) "")) - -(defun org-table-current-column () - "Find out which column we are in. -When called interactively, column is also displayed in echo area." - (interactive) - (if (interactive-p) (org-table-check-inside-data-field)) - (save-excursion - (let ((cnt 0) (pos (point))) - (beginning-of-line 1) - (while (search-forward "|" pos t) - (setq cnt (1+ cnt))) - (if (interactive-p) (message "This is table column %d" cnt)) - cnt))) - -(defun org-table-goto-column (n &optional on-delim force) - "Move the cursor to the Nth column in the current table line. -With optional argument ON-DELIM, stop with point before the left delimiter -of the field. -If there are less than N fields, just go to after the last delimiter. -However, when FORCE is non-nil, create new columns if necessary." - (interactive "p") - (let ((pos (point-at-eol))) - (beginning-of-line 1) - (when (> n 0) - (while (and (> (setq n (1- n)) -1) - (or (search-forward "|" pos t) - (and force - (progn (end-of-line 1) - (skip-chars-backward "^|") - (insert " | ")))))) -; (backward-char 2) t))))) - (when (and force (not (looking-at ".*|"))) - (save-excursion (end-of-line 1) (insert " | "))) - (if on-delim - (backward-char 1) - (if (looking-at " ") (forward-char 1)))))) - -(defun org-at-table-p (&optional table-type) - "Return t if the cursor is inside an org-type table. -If TABLE-TYPE is non-nil, also check for table.el-type tables." - (if org-enable-table-editor - (save-excursion - (beginning-of-line 1) - (looking-at (if table-type org-table-any-line-regexp - org-table-line-regexp))) - nil)) - -(defun org-at-table.el-p () - "Return t if and only if we are at a table.el table." - (and (org-at-table-p 'any) - (save-excursion - (goto-char (org-table-begin 'any)) - (looking-at org-table1-hline-regexp)))) - -(defun org-table-recognize-table.el () - "If there is a table.el table nearby, recognize it and move into it." - (if org-table-tab-recognizes-table.el - (if (org-at-table.el-p) - (progn - (beginning-of-line 1) - (if (looking-at org-table-dataline-regexp) - nil - (if (looking-at org-table1-hline-regexp) - (progn - (beginning-of-line 2) - (if (looking-at org-table-any-border-regexp) - (beginning-of-line -1))))) - (if (re-search-forward "|" (org-table-end t) t) - (progn - (require 'table) - (if (table--at-cell-p (point)) - t - (message "recognizing table.el table...") - (table-recognize-table) - (message "recognizing table.el table...done"))) - (error "This should not happen...")) - t) - nil) - nil)) - -(defun org-at-table-hline-p () - "Return t if the cursor is inside a hline in a table." - (if org-enable-table-editor - (save-excursion - (beginning-of-line 1) - (looking-at org-table-hline-regexp)) - nil)) - -(defun org-table-insert-column () - "Insert a new column into the table." - (interactive) - (if (not (org-at-table-p)) - (error "Not at a table")) - (org-table-find-dataline) - (let* ((col (max 1 (org-table-current-column))) - (beg (org-table-begin)) - (end (org-table-end)) - ;; Current cursor position - (linepos (org-current-line)) - (colpos col)) - (goto-char beg) - (while (< (point) end) - (if (org-at-table-hline-p) - nil - (org-table-goto-column col t) - (insert "| ")) - (beginning-of-line 2)) - (move-marker end nil) - (goto-line linepos) - (org-table-goto-column colpos) - (org-table-align) - (org-table-modify-formulas 'insert col))) - -(defun org-table-find-dataline () - "Find a dataline in the current table, which is needed for column commands." - (if (and (org-at-table-p) - (not (org-at-table-hline-p))) - t - (let ((col (current-column)) - (end (org-table-end))) - (move-to-column col) - (while (and (< (point) end) - (or (not (= (current-column) col)) - (org-at-table-hline-p))) - (beginning-of-line 2) - (move-to-column col)) - (if (and (org-at-table-p) - (not (org-at-table-hline-p))) - t - (error - "Please position cursor in a data line for column operations"))))) - -(defun org-table-delete-column () - "Delete a column from the table." - (interactive) - (if (not (org-at-table-p)) - (error "Not at a table")) - (org-table-find-dataline) - (org-table-check-inside-data-field) - (let* ((col (org-table-current-column)) - (beg (org-table-begin)) - (end (org-table-end)) - ;; Current cursor position - (linepos (org-current-line)) - (colpos col)) - (goto-char beg) - (while (< (point) end) - (if (org-at-table-hline-p) - nil - (org-table-goto-column col t) - (and (looking-at "|[^|\n]+|") - (replace-match "|"))) - (beginning-of-line 2)) - (move-marker end nil) - (goto-line linepos) - (org-table-goto-column colpos) - (org-table-align) - (org-table-modify-formulas 'remove col))) - -(defun org-table-move-column-right () - "Move column to the right." - (interactive) - (org-table-move-column nil)) -(defun org-table-move-column-left () - "Move column to the left." - (interactive) - (org-table-move-column 'left)) - -(defun org-table-move-column (&optional left) - "Move the current column to the right. With arg LEFT, move to the left." - (interactive "P") - (if (not (org-at-table-p)) - (error "Not at a table")) - (org-table-find-dataline) - (org-table-check-inside-data-field) - (let* ((col (org-table-current-column)) - (col1 (if left (1- col) col)) - (beg (org-table-begin)) - (end (org-table-end)) - ;; Current cursor position - (linepos (org-current-line)) - (colpos (if left (1- col) (1+ col)))) - (if (and left (= col 1)) - (error "Cannot move column further left")) - (if (and (not left) (looking-at "[^|\n]*|[^|\n]*$")) - (error "Cannot move column further right")) - (goto-char beg) - (while (< (point) end) - (if (org-at-table-hline-p) - nil - (org-table-goto-column col1 t) - (and (looking-at "|\\([^|\n]+\\)|\\([^|\n]+\\)|") - (replace-match "|\\2|\\1|"))) - (beginning-of-line 2)) - (move-marker end nil) - (goto-line linepos) - (org-table-goto-column colpos) - (org-table-align) - (org-table-modify-formulas 'swap col (if left (1- col) (1+ col))))) - -(defun org-table-move-row-down () - "Move table row down." - (interactive) - (org-table-move-row nil)) -(defun org-table-move-row-up () - "Move table row up." - (interactive) - (org-table-move-row 'up)) - -(defun org-table-move-row (&optional up) - "Move the current table line down. With arg UP, move it up." - (interactive "P") - (let ((col (current-column)) - (pos (point)) - (tonew (if up 0 2)) - txt) - (beginning-of-line tonew) - (if (not (org-at-table-p)) - (progn - (goto-char pos) - (error "Cannot move row further"))) - (goto-char pos) - (beginning-of-line 1) - (setq pos (point)) - (setq txt (buffer-substring (point) (1+ (point-at-eol)))) - (delete-region (point) (1+ (point-at-eol))) - (beginning-of-line tonew) - (insert txt) - (beginning-of-line 0) - (move-to-column col))) - -(defun org-table-insert-row (&optional arg) - "Insert a new row above the current line into the table. -With prefix ARG, insert below the current line." - (interactive "P") - (if (not (org-at-table-p)) - (error "Not at a table")) - (let* ((line (buffer-substring (point-at-bol) (point-at-eol))) - (new (org-table-clean-line line))) - ;; Fix the first field if necessary - (if (string-match "^[ \t]*| *[#$] *|" line) - (setq new (replace-match (match-string 0 line) t t new))) - (beginning-of-line (if arg 2 1)) - (let (org-table-may-need-update) (insert-before-markers new "\n")) - (beginning-of-line 0) - (re-search-forward "| ?" (point-at-eol) t) - (and org-table-may-need-update (org-table-align)))) + (skip-chars-backward "a-zA-Z0-9*") + (skip-chars-backward " \t") + (bolp)) + (cdlatex-tab) t) + ((org-inside-LaTeX-fragment-p) + (cdlatex-tab) t) + (t nil)))) -(defun org-table-insert-hline (&optional arg) - "Insert a horizontal-line below the current line into the table. -With prefix ARG, insert above the current line." +(defun org-cdlatex-underscore-caret (&optional arg) + "Execute `cdlatex-sub-superscript' in LaTeX fragments. +Revert to the normal definition outside of these fragments." (interactive "P") - (if (not (org-at-table-p)) - (error "Not at a table")) - (let ((line (org-table-clean-line - (buffer-substring (point-at-bol) (point-at-eol)))) - (col (current-column))) - (while (string-match "|\\( +\\)|" line) - (setq line (replace-match - (concat "+" (make-string (- (match-end 1) (match-beginning 1)) - ?-) "|") t t line))) - (and (string-match "\\+" line) (setq line (replace-match "|" t t line))) - (beginning-of-line (if arg 1 2)) - (insert line "\n") - (beginning-of-line (if arg 1 -1)) - (move-to-column col))) - -(defun org-table-clean-line (s) - "Convert a table line S into a string with only \"|\" and space. -In particular, this does handle wide and invisible characters." - (if (string-match "^[ \t]*|-" s) - ;; It's a hline, just map the characters - (setq s (mapconcat (lambda (x) (if (member x '(?| ?+)) "|" " ")) s "")) - (while (string-match "|\\([ \t]*?[^ \t\r\n|][^\r\n|]*\\)|" s) - (setq s (replace-match - (concat "|" (make-string (org-string-width (match-string 1 s)) - ?\ ) "|") - t t s))) - s)) - -(defun org-table-kill-row () - "Delete the current row or horizontal line from the table." - (interactive) - (if (not (org-at-table-p)) - (error "Not at a table")) - (let ((col (current-column))) - (kill-region (point-at-bol) (min (1+ (point-at-eol)) (point-max))) - (if (not (org-at-table-p)) (beginning-of-line 0)) - (move-to-column col))) - -(defun org-table-sort-lines (with-case &optional sorting-type) - "Sort table lines according to the column at point. - -The position of point indicates the column to be used for -sorting, and the range of lines is the range between the nearest -horizontal separator lines, or the entire table of no such lines -exist. If point is before the first column, you will be prompted -for the sorting column. If there is an active region, the mark -specifies the first line and the sorting column, while point -should be in the last line to be included into the sorting. - -The command then prompts for the sorting type which can be -alphabetically, numerically, or by time (as given in a time stamp -in the field). Sorting in reverse order is also possible. - -With prefix argument WITH-CASE, alphabetic sorting will be case-sensitive. + (if (org-inside-LaTeX-fragment-p) + (call-interactively 'cdlatex-sub-superscript) + (let (org-cdlatex-mode) + (call-interactively (key-binding (vector last-input-event)))))) -If SORTING-TYPE is specified when this function is called from a Lisp -program, no prompting will take place. SORTING-TYPE must be a character, -any of (?a ?A ?n ?N ?t ?T) where the capital letter indicate that sorting -should be done in reverse order." +(defun org-cdlatex-math-modify (&optional arg) + "Execute `cdlatex-math-modify' in LaTeX fragments. +Revert to the normal definition outside of these fragments." (interactive "P") - (let* ((thisline (org-current-line)) - (thiscol (org-table-current-column)) - beg end bcol ecol tend tbeg column lns pos) - (when (equal thiscol 0) - (if (interactive-p) - (setq thiscol - (string-to-number - (read-string "Use column N for sorting: "))) - (setq thiscol 1)) - (org-table-goto-column thiscol)) - (org-table-check-inside-data-field) - (if (org-region-active-p) - (progn - (setq beg (region-beginning) end (region-end)) - (goto-char beg) - (setq column (org-table-current-column) - beg (point-at-bol)) - (goto-char end) - (setq end (point-at-bol 2))) - (setq column (org-table-current-column) - pos (point) - tbeg (org-table-begin) - tend (org-table-end)) - (if (re-search-backward org-table-hline-regexp tbeg t) - (setq beg (point-at-bol 2)) - (goto-char tbeg) - (setq beg (point-at-bol 1))) - (goto-char pos) - (if (re-search-forward org-table-hline-regexp tend t) - (setq beg (point-at-bol 0)) - (goto-char tend) - (setq end (point-at-bol)))) - (setq beg (move-marker (make-marker) beg) - end (move-marker (make-marker) end)) - (untabify beg end) - (goto-char beg) - (org-table-goto-column column) - (skip-chars-backward "^|") - (setq bcol (current-column)) - (org-table-goto-column (1+ column)) - (skip-chars-backward "^|") - (setq ecol (1- (current-column))) - (org-table-goto-column column) - (setq lns (mapcar (lambda(x) (cons (org-trim (substring x bcol ecol)) x)) - (org-split-string (buffer-substring beg end) "\n"))) - (setq lns (org-do-sort lns "Table" with-case sorting-type)) - (delete-region beg end) - (move-marker beg nil) - (move-marker end nil) - (insert (mapconcat 'cdr lns "\n") "\n") - (goto-line thisline) - (org-table-goto-column thiscol) - (message "%d lines sorted, based on column %d" (length lns) column))) - -(defun org-table-cut-region (beg end) - "Copy region in table to the clipboard and blank all relevant fields." - (interactive "r") - (org-table-copy-region beg end 'cut)) - -(defun org-table-copy-region (beg end &optional cut) - "Copy rectangular region in table to clipboard. -A special clipboard is used which can only be accessed -with `org-table-paste-rectangle'." - (interactive "rP") - (let* (l01 c01 l02 c02 l1 c1 l2 c2 ic1 ic2 - region cols - (rpl (if cut " " nil))) - (goto-char beg) - (org-table-check-inside-data-field) - (setq l01 (count-lines (point-min) (point)) - c01 (org-table-current-column)) - (goto-char end) - (org-table-check-inside-data-field) - (setq l02 (count-lines (point-min) (point)) - c02 (org-table-current-column)) - (setq l1 (min l01 l02) l2 (max l01 l02) - c1 (min c01 c02) c2 (max c01 c02)) - (catch 'exit - (while t - (catch 'nextline - (if (> l1 l2) (throw 'exit t)) - (goto-line l1) - (if (org-at-table-hline-p) (throw 'nextline (setq l1 (1+ l1)))) - (setq cols nil ic1 c1 ic2 c2) - (while (< ic1 (1+ ic2)) - (push (org-table-get-field ic1 rpl) cols) - (setq ic1 (1+ ic1))) - (push (nreverse cols) region) - (setq l1 (1+ l1))))) - (setq org-table-clip (nreverse region)) - (if cut (org-table-align)) - org-table-clip)) - -(defun org-table-paste-rectangle () - "Paste a rectangular region into a table. -The upper right corner ends up in the current field. All involved fields -will be overwritten. If the rectangle does not fit into the present table, -the table is enlarged as needed. The process ignores horizontal separator -lines." - (interactive) - (unless (and org-table-clip (listp org-table-clip)) - (error "First cut/copy a region to paste!")) - (org-table-check-inside-data-field) - (let* ((clip org-table-clip) - (line (count-lines (point-min) (point))) - (col (org-table-current-column)) - (org-enable-table-editor t) - (org-table-automatic-realign nil) - c cols field) - (while (setq cols (pop clip)) - (while (org-at-table-hline-p) (beginning-of-line 2)) - (if (not (org-at-table-p)) - (progn (end-of-line 0) (org-table-next-field))) - (setq c col) - (while (setq field (pop cols)) - (org-table-goto-column c nil 'force) - (org-table-get-field nil field) - (setq c (1+ c))) - (beginning-of-line 2)) - (goto-line line) - (org-table-goto-column col) - (org-table-align))) - -(defun org-table-convert () - "Convert from `org-mode' table to table.el and back. -Obviously, this only works within limits. When an Org-mode table is -converted to table.el, all horizontal separator lines get lost, because -table.el uses these as cell boundaries and has no notion of horizontal lines. -A table.el table can be converted to an Org-mode table only if it does not -do row or column spanning. Multiline cells will become multiple cells. -Beware, Org-mode does not test if the table can be successfully converted - it -blindly applies a recipe that works for simple tables." - (interactive) - (require 'table) - (if (org-at-table.el-p) - ;; convert to Org-mode table - (let ((beg (move-marker (make-marker) (org-table-begin t))) - (end (move-marker (make-marker) (org-table-end t)))) - (table-unrecognize-region beg end) - (goto-char beg) - (while (re-search-forward "^\\([ \t]*\\)\\+-.*\n" end t) - (replace-match "")) - (goto-char beg)) - (if (org-at-table-p) - ;; convert to table.el table - (let ((beg (move-marker (make-marker) (org-table-begin))) - (end (move-marker (make-marker) (org-table-end)))) - ;; first, get rid of all horizontal lines - (goto-char beg) - (while (re-search-forward "^\\([ \t]*\\)|-.*\n" end t) - (replace-match "")) - ;; insert a hline before first - (goto-char beg) - (org-table-insert-hline 'above) - (beginning-of-line -1) - ;; insert a hline after each line - (while (progn (beginning-of-line 3) (< (point) end)) - (org-table-insert-hline)) - (goto-char beg) - (setq end (move-marker end (org-table-end))) - ;; replace "+" at beginning and ending of hlines - (while (re-search-forward "^\\([ \t]*\\)|-" end t) - (replace-match "\\1+-")) - (goto-char beg) - (while (re-search-forward "-|[ \t]*$" end t) - (replace-match "-+")) - (goto-char beg))))) - -(defun org-table-wrap-region (arg) - "Wrap several fields in a column like a paragraph. -This is useful if you'd like to spread the contents of a field over several -lines, in order to keep the table compact. - -If there is an active region, and both point and mark are in the same column, -the text in the column is wrapped to minimum width for the given number of -lines. Generally, this makes the table more compact. A prefix ARG may be -used to change the number of desired lines. For example, `C-2 \\[org-table-wrap]' -formats the selected text to two lines. If the region was longer than two -lines, the remaining lines remain empty. A negative prefix argument reduces -the current number of lines by that amount. The wrapped text is pasted back -into the table. If you formatted it to more lines than it was before, fields -further down in the table get overwritten - so you might need to make space in -the table first. - -If there is no region, the current field is split at the cursor position and -the text fragment to the right of the cursor is prepended to the field one -line down. + (if (org-inside-LaTeX-fragment-p) + (call-interactively 'cdlatex-math-modify) + (let (org-cdlatex-mode) + (call-interactively (key-binding (vector last-input-event)))))) -If there is no region, but you specify a prefix ARG, the current field gets -blank, and the content is appended to the field above." - (interactive "P") - (org-table-check-inside-data-field) - (if (org-region-active-p) - ;; There is a region: fill as a paragraph - (let ((beg (region-beginning)) - nlines) - (org-table-cut-region (region-beginning) (region-end)) - (if (> (length (car org-table-clip)) 1) - (error "Region must be limited to single column")) - (setq nlines (if arg - (if (< arg 1) - (+ (length org-table-clip) arg) - arg) - (length org-table-clip))) - (setq org-table-clip - (mapcar 'list (org-wrap (mapconcat 'car org-table-clip " ") - nil nlines))) - (goto-char beg) - (org-table-paste-rectangle)) - ;; No region, split the current field at point - (if arg - ;; combine with field above - (let ((s (org-table-blank-field)) - (col (org-table-current-column))) - (beginning-of-line 0) - (while (org-at-table-hline-p) (beginning-of-line 0)) - (org-table-goto-column col) - (skip-chars-forward "^|") - (skip-chars-backward " ") - (insert " " (org-trim s)) - (org-table-align)) - ;; split field - (when (looking-at "\\([^|]+\\)+|") - (let ((s (match-string 1))) - (replace-match " |") - (goto-char (match-beginning 0)) - (org-table-next-row) - (insert (org-trim s) " ") - (org-table-align)))))) +(defvar org-latex-fragment-image-overlays nil + "List of overlays carrying the images of latex fragments.") +(make-variable-buffer-local 'org-latex-fragment-image-overlays) -(defvar org-field-marker nil) +(defun org-remove-latex-fragment-image-overlays () + "Remove all overlays with LaTeX fragment images in current buffer." + (mapc 'org-delete-overlay org-latex-fragment-image-overlays) + (setq org-latex-fragment-image-overlays nil)) -(defun org-table-edit-field (arg) - "Edit table field in a different window. -This is mainly useful for fields that contain hidden parts. -When called with a \\[universal-argument] prefix, just make the full field visible so that -it can be edited in place." +(defun org-preview-latex-fragment (&optional subtree) + "Preview the LaTeX fragment at point, or all locally or globally. +If the cursor is in a LaTeX fragment, create the image and overlay +it over the source code. If there is no fragment at point, display +all fragments in the current text, from one headline to the next. With +prefix SUBTREE, display all fragments in the current subtree. With a +double prefix `C-u C-u', or when the cursor is before the first headline, +display all fragments in the buffer. +The images can be removed again with \\[org-ctrl-c-ctrl-c]." (interactive "P") - (if arg - (let ((b (save-excursion (skip-chars-backward "^|") (point))) - (e (save-excursion (skip-chars-forward "^|\r\n") (point)))) - (remove-text-properties b e '(org-cwidth t invisible t - display t intangible t)) - (if (and (boundp 'font-lock-mode) font-lock-mode) - (font-lock-fontify-block))) - (let ((pos (move-marker (make-marker) (point))) - (field (org-table-get-field)) - (cw (current-window-configuration)) - p) - (switch-to-buffer-other-window "*Org tmp*") - (erase-buffer) - (insert "#\n# Edit field and finish with C-c C-c\n#\n") - (org-mode) - (goto-char (setq p (point-max))) - (insert (org-trim field)) - (remove-text-properties p (point-max) - '(invisible t org-cwidth t display t - intangible t)) - (goto-char p) - (org-set-local 'org-finish-function - 'org-table-finish-edit-field) - (org-set-local 'org-window-configuration cw) - (org-set-local 'org-field-marker pos) - (message "Edit and finish with C-c C-c")))) - -(defun org-table-finish-edit-field () - "Finish editing a table data field. -Remove all newline characters, insert the result into the table, realign -the table and kill the editing buffer." - (let ((pos org-field-marker) - (cw org-window-configuration) - (cb (current-buffer)) - text) - (goto-char (point-min)) - (while (re-search-forward "^#.*\n?" nil t) (replace-match "")) - (while (re-search-forward "\\([ \t]*\n[ \t]*\\)+" nil t) - (replace-match " ")) - (setq text (org-trim (buffer-string))) - (set-window-configuration cw) - (kill-buffer cb) - (select-window (get-buffer-window (marker-buffer pos))) - (goto-char pos) - (move-marker pos nil) - (org-table-check-inside-data-field) - (org-table-get-field nil text) - (org-table-align) - (message "New field value inserted"))) - -(defun org-trim (s) - "Remove whitespace at beginning and end of string." - (if (string-match "^[ \t]+" s) (setq s (replace-match "" t t s))) - (if (string-match "[ \t]+$" s) (setq s (replace-match "" t t s))) - s) - -(defun org-wrap (string &optional width lines) - "Wrap string to either a number of lines, or a width in characters. -If WIDTH is non-nil, the string is wrapped to that width, however many lines -that costs. If there is a word longer than WIDTH, the text is actually -wrapped to the length of that word. -IF WIDTH is nil and LINES is non-nil, the string is forced into at most that -many lines, whatever width that takes. -The return value is a list of lines, without newlines at the end." - (let* ((words (org-split-string string "[ \t\n]+")) - (maxword (apply 'max (mapcar 'org-string-width words))) - w ll) - (cond (width - (org-do-wrap words (max maxword width))) - (lines - (setq w maxword) - (setq ll (org-do-wrap words maxword)) - (if (<= (length ll) lines) - ll - (setq ll words) - (while (> (length ll) lines) - (setq w (1+ w)) - (setq ll (org-do-wrap words w))) - ll)) - (t (error "Cannot wrap this"))))) - - -(defun org-do-wrap (words width) - "Create lines of maximum width WIDTH (in characters) from word list WORDS." - (let (lines line) - (while words - (setq line (pop words)) - (while (and words (< (+ (length line) (length (car words))) width)) - (setq line (concat line " " (pop words)))) - (setq lines (push line lines))) - (nreverse lines))) - -(defun org-split-string (string &optional separators) - "Splits STRING into substrings at SEPARATORS. -No empty strings are returned if there are matches at the beginning -and end of string." - (let ((rexp (or separators "[ \f\t\n\r\v]+")) - (start 0) - notfirst - (list nil)) - (while (and (string-match rexp string - (if (and notfirst - (= start (match-beginning 0)) - (< start (length string))) - (1+ start) start)) - (< (match-beginning 0) (length string))) - (setq notfirst t) - (or (eq (match-beginning 0) 0) - (and (eq (match-beginning 0) (match-end 0)) - (eq (match-beginning 0) start)) - (setq list - (cons (substring string start (match-beginning 0)) - list))) - (setq start (match-end 0))) - (or (eq start (length string)) - (setq list - (cons (substring string start) - list))) - (nreverse list))) - -(defun org-table-map-tables (function) - "Apply FUNCTION to the start of all tables in the buffer." + (org-remove-latex-fragment-image-overlays) (save-excursion (save-restriction - (widen) - (goto-char (point-min)) - (while (re-search-forward org-table-any-line-regexp nil t) - (message "Mapping tables: %d%%" (/ (* 100.0 (point)) (buffer-size))) - (beginning-of-line 1) - (if (looking-at org-table-line-regexp) - (save-excursion (funcall function))) - (re-search-forward org-table-any-border-regexp nil 1)))) - (message "Mapping tables: done")) - -(defun org-table-sum (&optional beg end nlast) - "Sum numbers in region of current table column. -The result will be displayed in the echo area, and will be available -as kill to be inserted with \\[yank]. - -If there is an active region, it is interpreted as a rectangle and all -numbers in that rectangle will be summed. If there is no active -region and point is located in a table column, sum all numbers in that -column. - -If at least one number looks like a time HH:MM or HH:MM:SS, all other -numbers are assumed to be times as well (in decimal hours) and the -numbers are added as such. - -If NLAST is a number, only the NLAST fields will actually be summed." - (interactive) - (save-excursion - (let (col (timecnt 0) diff h m s org-table-clip) - (cond - ((and beg end)) ; beg and end given explicitly - ((org-region-active-p) - (setq beg (region-beginning) end (region-end))) - (t - (setq col (org-table-current-column)) - (goto-char (org-table-begin)) - (unless (re-search-forward "^[ \t]*|[^-]" nil t) - (error "No table data")) - (org-table-goto-column col) -;not needed? (skip-chars-backward "^|") - (setq beg (point)) - (goto-char (org-table-end)) - (unless (re-search-backward "^[ \t]*|[^-]" nil t) - (error "No table data")) - (org-table-goto-column col) -;not needed? (skip-chars-forward "^|") - (setq end (point)))) - (let* ((items (apply 'append (org-table-copy-region beg end))) - (items1 (cond ((not nlast) items) - ((>= nlast (length items)) items) - (t (setq items (reverse items)) - (setcdr (nthcdr (1- nlast) items) nil) - (nreverse items)))) - (numbers (delq nil (mapcar 'org-table-get-number-for-summing - items1))) - (res (apply '+ numbers)) - (sres (if (= timecnt 0) - (format "%g" res) - (setq diff (* 3600 res) - h (floor (/ diff 3600)) diff (mod diff 3600) - m (floor (/ diff 60)) diff (mod diff 60) - s diff) - (format "%d:%02d:%02d" h m s)))) - (kill-new sres) - (if (interactive-p) - (message "%s" - (substitute-command-keys - (format "Sum of %d items: %-20s (\\[yank] will insert result into buffer)" - (length numbers) sres)))) - sres)))) - -(defun org-table-get-number-for-summing (s) - (let (n) - (if (string-match "^ *|? *" s) - (setq s (replace-match "" nil nil s))) - (if (string-match " *|? *$" s) - (setq s (replace-match "" nil nil s))) - (setq n (string-to-number s)) - (cond - ((and (string-match "0" s) - (string-match "\\`[-+ \t0.edED]+\\'" s)) 0) - ((string-match "\\`[ \t]+\\'" s) nil) - ((string-match "\\`\\([0-9]+\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?\\'" s) - (let ((h (string-to-number (or (match-string 1 s) "0"))) - (m (string-to-number (or (match-string 2 s) "0"))) - (s (string-to-number (or (match-string 4 s) "0")))) - (if (boundp 'timecnt) (setq timecnt (1+ timecnt))) - (* 1.0 (+ h (/ m 60.0) (/ s 3600.0))))) - ((equal n 0) nil) - (t n)))) - -(defun org-table-get-vertical-vector (desc &optional tbeg col) - "Get a calc vector from a column, accorting to descriptor DESC. -Optional arguments TBEG and COL can give the beginning of the table and -the current column, to avoid unnecessary parsing." - (save-excursion - (or tbeg (setq tbeg (org-table-begin))) - (or col (setq col (org-table-current-column))) - (let (beg end nn n n1 n2 l (thisline (org-current-line)) hline-list) - (cond - ((string-match "\\(I+\\)\\(-\\(I+\\)\\)?" desc) - (setq n1 (- (match-end 1) (match-beginning 1))) - (if (match-beginning 3) - (setq n2 (- (match-end 2) (match-beginning 3)))) - (setq n (if n2 (max n1 n2) n1)) - (setq n1 (if n2 (min n1 n2))) - (setq nn n) - (while (and (> nn 0) - (re-search-backward org-table-hline-regexp tbeg t)) - (push (org-current-line) hline-list) - (setq nn (1- nn))) - (setq hline-list (nreverse hline-list)) - (goto-line (nth (1- n) hline-list)) - (when (re-search-forward org-table-dataline-regexp) - (org-table-goto-column col) - (setq beg (point))) - (goto-line (if n1 (nth (1- n1) hline-list) thisline)) - (when (re-search-backward org-table-dataline-regexp) - (org-table-goto-column col) - (setq end (point))) - (setq l (apply 'append (org-table-copy-region beg end))) - (concat "[" (mapconcat (lambda (x) (setq x (org-trim x)) - (if (equal x "") "0" x)) - l ",") "]")) - ((string-match "\\([0-9]+\\)-\\([0-9]+\\)" desc) - (setq n1 (string-to-number (match-string 1 desc)) - n2 (string-to-number (match-string 2 desc))) - (beginning-of-line 1) - (save-excursion - (when (re-search-backward org-table-dataline-regexp tbeg t n1) - (org-table-goto-column col) - (setq beg (point)))) - (when (re-search-backward org-table-dataline-regexp tbeg t n2) - (org-table-goto-column col) - (setq end (point))) - (setq l (apply 'append (org-table-copy-region beg end))) - (concat "[" (mapconcat - (lambda (x) (setq x (org-trim x)) - (if (equal x "") "0" x)) - l ",") "]")) - ((string-match "\\([0-9]+\\)" desc) - (beginning-of-line 1) - (when (re-search-backward org-table-dataline-regexp tbeg t - (string-to-number (match-string 0 desc))) - (org-table-goto-column col) - (org-trim (org-table-get-field)))))))) - -(defvar org-table-formula-history nil) - -(defvar org-table-column-names nil - "Alist with column names, derived from the `!' line.") -(defvar org-table-column-name-regexp nil - "Regular expression matching the current column names.") -(defvar org-table-local-parameters nil - "Alist with parameter names, derived from the `$' line.") -(defvar org-table-named-field-locations nil - "Alist with locations of named fields.") - -(defun org-table-get-formula (&optional equation named) - "Read a formula from the minibuffer, offer stored formula as default." - (let* ((name (car (rassoc (list (org-current-line) - (org-table-current-column)) - org-table-named-field-locations))) - (scol (if named - (if name name - (error "Not in a named field")) - (int-to-string (org-table-current-column)))) - (dummy (and name (not named) - (not (y-or-n-p "Replace named-field formula with column equation? " )) - (error "Abort"))) - (org-table-may-need-update nil) - (stored-list (org-table-get-stored-formulas)) - (stored (cdr (assoc scol stored-list))) - (eq (cond - ((and stored equation (string-match "^ *=? *$" equation)) - stored) - ((stringp equation) - equation) - (t (read-string - (format "%s formula $%s=" (if named "Field" "Column") scol) - (or stored "") 'org-table-formula-history - ;stored - )))) - mustsave) - (when (not (string-match "\\S-" eq)) - ;; remove formula - (setq stored-list (delq (assoc scol stored-list) stored-list)) - (org-table-store-formulas stored-list) - (error "Formula removed")) - (if (string-match "^ *=?" eq) (setq eq (replace-match "" t t eq))) - (if (string-match " *$" eq) (setq eq (replace-match "" t t eq))) - (if (and name (not named)) - ;; We set the column equation, delete the named one. - (setq stored-list (delq (assoc name stored-list) stored-list) - mustsave t)) - (if stored - (setcdr (assoc scol stored-list) eq) - (setq stored-list (cons (cons scol eq) stored-list))) - (if (or mustsave (not (equal stored eq))) - (org-table-store-formulas stored-list)) - eq)) - -(defun org-table-store-formulas (alist) - "Store the list of formulas below the current table." - (setq alist (sort alist (lambda (a b) (string< (car a) (car b))))) - (save-excursion - (goto-char (org-table-end)) - (if (looking-at "\\([ \t]*\n\\)*#\\+TBLFM:.*\n?") - (delete-region (point) (match-end 0))) - (insert "#+TBLFM: " - (mapconcat (lambda (x) - (concat "$" (car x) "=" (cdr x))) - alist "::") - "\n"))) - -(defun org-table-get-stored-formulas () - "Return an alist with the stored formulas directly after current table." - (interactive) - (let (scol eq eq-alist strings string seen) - (save-excursion - (goto-char (org-table-end)) - (when (looking-at "\\([ \t]*\n\\)*#\\+TBLFM: *\\(.*\\)") - (setq strings (org-split-string (match-string 2) " *:: *")) - (while (setq string (pop strings)) - (when (string-match "\\$\\([a-zA-Z0-9]+\\) *= *\\(.*[^ \t]\\)" string) - (setq scol (match-string 1 string) - eq (match-string 2 string) - eq-alist (cons (cons scol eq) eq-alist)) - (if (member scol seen) - (error "Double definition `$%s=' in TBLFM line, please fix by hand" scol) - (push scol seen)))))) - (nreverse eq-alist))) - -(defun org-table-modify-formulas (action &rest columns) - "Modify the formulas stored below the current table. -ACTION can be `remove', `insert', `swap'. For `swap', two column numbers are -expected, for the other actions only a single column number is needed." - (let ((list (org-table-get-stored-formulas)) - (nmax (length (org-split-string - (buffer-substring (point-at-bol) (point-at-eol)) - "|"))) - col col1 col2 scol si sc1 sc2) - (cond - ((null list)) ; No action needed if there are no stored formulas - ((eq action 'remove) - (setq col (car columns) - scol (int-to-string col)) - (org-table-replace-in-formulas list scol "INVALID") - (if (assoc scol list) (setq list (delq (assoc scol list) list))) - (loop for i from (1+ col) upto nmax by 1 do - (setq si (int-to-string i)) - (org-table-replace-in-formulas list si (int-to-string (1- i))) - (if (assoc si list) (setcar (assoc si list) - (int-to-string (1- i)))))) - ((eq action 'insert) - (setq col (car columns)) - (loop for i from nmax downto col by 1 do - (setq si (int-to-string i)) - (org-table-replace-in-formulas list si (int-to-string (1+ i))) - (if (assoc si list) (setcar (assoc si list) - (int-to-string (1+ i)))))) - ((eq action 'swap) - (setq col1 (car columns) col2 (nth 1 columns) - sc1 (int-to-string col1) sc2 (int-to-string col2)) - ;; Hopefully, ZqZtZ will never be a name in a table - (org-table-replace-in-formulas list sc1 "ZqZtZ") - (org-table-replace-in-formulas list sc2 sc1) - (org-table-replace-in-formulas list "ZqZtZ" sc2) - (if (assoc sc1 list) (setcar (assoc sc1 list) "ZqZtZ")) - (if (assoc sc2 list) (setcar (assoc sc2 list) sc1)) - (if (assoc "ZqZtZ" list) (setcar (assoc "ZqZtZ" list) sc2))) - (t (error "Invalid action in `org-table-modify-formulas'"))) - (if list (org-table-store-formulas list)))) - -(defun org-table-replace-in-formulas (list s1 s2) - (let (elt re s) - (setq s1 (concat "$" (if (integerp s1) (int-to-string s1) s1)) - s2 (concat "$" (if (integerp s2) (int-to-string s2) s2)) - re (concat (regexp-quote s1) "\\>")) - (while (setq elt (pop list)) - (setq s (cdr elt)) - (while (string-match re s) - (setq s (replace-match s2 t t s))) - (setcdr elt s)))) - -(defun org-table-get-specials () - "Get the column names and local parameters for this table." - (save-excursion - (let ((beg (org-table-begin)) (end (org-table-end)) - names name fields fields1 field cnt c v line col) - (setq org-table-column-names nil - org-table-local-parameters nil - org-table-named-field-locations nil) - (goto-char beg) - (when (re-search-forward "^[ \t]*| *! *\\(|.*\\)" end t) - (setq names (org-split-string (match-string 1) " *| *") - cnt 1) - (while (setq name (pop names)) - (setq cnt (1+ cnt)) - (if (string-match "^[a-zA-Z][a-zA-Z0-9]*$" name) - (push (cons name (int-to-string cnt)) org-table-column-names)))) - (setq org-table-column-names (nreverse org-table-column-names)) - (setq org-table-column-name-regexp - (concat "\\$\\(" (mapconcat 'car org-table-column-names "\\|") "\\)\\>")) - (goto-char beg) - (while (re-search-forward "^[ \t]*| *\\$ *\\(|.*\\)" end t) - (setq fields (org-split-string (match-string 1) " *| *")) - (while (setq field (pop fields)) - (if (string-match "^\\([a-zA-Z][a-zA-Z0-9]*\\|%\\) *= *\\(.*\\)" field) - (push (cons (match-string 1 field) (match-string 2 field)) - org-table-local-parameters)))) - (goto-char beg) - (while (re-search-forward "^[ \t]*| *\\([_^]\\) *\\(|.*\\)" end t) - (setq c (match-string 1) - fields (org-split-string (match-string 2) " *| *")) - (save-excursion - (beginning-of-line (if (equal c "_") 2 0)) - (setq line (org-current-line) col 1) - (and (looking-at "^[ \t]*|[^|]*\\(|.*\\)") - (setq fields1 (org-split-string (match-string 1) " *| *")))) - (while (and fields1 (setq field (pop fields))) - (setq v (pop fields1) col (1+ col)) - (when (and (stringp field) (stringp v) - (string-match "^[a-zA-Z][a-zA-Z0-9]*$" field)) - (push (cons field v) org-table-local-parameters) - (push (list field line col) org-table-named-field-locations))))))) - -(defun org-this-word () - ;; Get the current word - (save-excursion - (let ((beg (progn (skip-chars-backward "^ \t\n") (point))) - (end (progn (skip-chars-forward "^ \t\n") (point)))) - (buffer-substring-no-properties beg end)))) - -(defun org-table-maybe-eval-formula () - "Check if the current field starts with \"=\" or \":=\". -If yes, store the formula and apply it." - ;; We already know we are in a table. Get field will only return a formula - ;; when appropriate. It might return a separator line, but no problem. - (when org-table-formula-evaluate-inline - (let* ((field (org-trim (or (org-table-get-field) ""))) - named eq) - (when (string-match "^:?=\\(.*\\)" field) - (setq named (equal (string-to-char field) ?:) - eq (match-string 1 field)) - (if (fboundp 'calc-eval) - (org-table-eval-formula (if named '(4) nil) eq)))))) - -(defvar org-recalc-commands nil - "List of commands triggering the recalculation of a line. -Will be filled automatically during use.") + (let (beg end at msg) + (cond + ((or (equal subtree '(16)) + (not (save-excursion + (re-search-backward (concat "^" outline-regexp) nil t)))) + (setq beg (point-min) end (point-max) + msg "Creating images for buffer...%s")) + ((equal subtree '(4)) + (org-back-to-heading) + (setq beg (point) end (org-end-of-subtree t) + msg "Creating images for subtree...%s")) + (t + (if (setq at (org-inside-LaTeX-fragment-p)) + (goto-char (max (point-min) (- (cdr at) 2))) + (org-back-to-heading)) + (setq beg (point) end (progn (outline-next-heading) (point)) + msg (if at "Creating image...%s" + "Creating images for entry...%s")))) + (message msg "") + (narrow-to-region beg end) + (org-format-latex + (concat "ltxpng/" (file-name-sans-extension + (file-name-nondirectory + buffer-file-name))) + default-directory 'overlays msg at) + (message msg "done. Use `C-c C-c' to remove images."))))) -(defvar org-recalc-marks - '((" " . "Unmarked: no special line, no automatic recalculation") - ("#" . "Automatically recalculate this line upon TAB, RET, and C-c C-c in the line") - ("*" . "Recalculate only when entire table is recalculated with `C-u C-c *'") - ("!" . "Column name definition line. Reference in formula as $name.") - ("$" . "Parameter definition line name=value. Reference in formula as $name.") - ("_" . "Names for values in row below this one.") - ("^" . "Names for values in row above this one."))) +(defvar org-latex-regexps + '(("begin" "^[ \t]*\\(\\\\begin{\\([a-zA-Z0-9\\*]+\\)[^\000]+?\\\\end{\\2}\\)" 1 t) + ;; ("$" "\\([ (]\\|^\\)\\(\\(\\([$]\\)\\([^ \r\n,.$].*?\\(\n.*?\\)\\{0,5\\}[^ \r\n,.$]\\)\\4\\)\\)\\([ .,?;:'\")]\\|$\\)" 2 nil) + ;; \000 in the following regex is needed for org-inside-LaTeX-fragment-p + ("$" "\\([^$]\\)\\(\\(\\$\\([^ \r\n,;.$][^$\n\r]*?\\(\n[^$\n\r]*?\\)\\{0,2\\}[^ \r\n,.$]\\)\\$\\)\\)\\([ .,?;:'\")\000]\\|$\\)" 2 nil) + ("\\(" "\\\\([^\000]*?\\\\)" 0 nil) + ("\\[" "\\\\\\[[^\000]*?\\\\\\]" 0 t) + ("$$" "\\$\\$[^\000]*?\\$\\$" 0 t)) + "Regular expressions for matching embedded LaTeX.") -(defun org-table-rotate-recalc-marks (&optional newchar) - "Rotate the recalculation mark in the first column. -If in any row, the first field is not consistent with a mark, -insert a new column for the markers. -When there is an active region, change all the lines in the region, -after prompting for the marking character. -After each change, a message will be displayed indicating the meaning -of the new mark." - (interactive) - (unless (org-at-table-p) (error "Not at a table")) - (let* ((marks (append (mapcar 'car org-recalc-marks) '(" "))) - (beg (org-table-begin)) - (end (org-table-end)) - (l (org-current-line)) - (l1 (if (org-region-active-p) (org-current-line (region-beginning)))) - (l2 (if (org-region-active-p) (org-current-line (region-end)))) - (have-col - (save-excursion +(defun org-format-latex (prefix &optional dir overlays msg at) + "Replace LaTeX fragments with links to an image, and produce images." + (if (and overlays (fboundp 'clear-image-cache)) (clear-image-cache)) + (let* ((prefixnodir (file-name-nondirectory prefix)) + (absprefix (expand-file-name prefix dir)) + (todir (file-name-directory absprefix)) + (opt org-format-latex-options) + (matchers (plist-get opt :matchers)) + (re-list org-latex-regexps) + (cnt 0) txt link beg end re e oldfiles + m n block linkfile movefile ov) + ;; Make sure the directory exists + (or (file-directory-p todir) (make-directory todir)) + ;; Check if there are old images files with this prefix, and remove them + (setq oldfiles (directory-files + todir 'full + (concat (regexp-quote prefixnodir) "_[0-9]+\\.png$"))) + (while oldfiles (delete-file (pop oldfiles))) + ;; Check the different regular expressions + (while (setq e (pop re-list)) + (setq m (car e) re (nth 1 e) n (nth 2 e) + block (if (nth 3 e) "\n\n" "")) + (when (member m matchers) + (goto-char (point-min)) + (while (re-search-forward re nil t) + (when (or (not at) (equal (cdr at) (match-beginning n))) + (setq txt (match-string n) + beg (match-beginning n) end (match-end n) + cnt (1+ cnt) + linkfile (format "%s_%04d.png" prefix cnt) + movefile (format "%s_%04d.png" absprefix cnt) + link (concat block "[[file:" linkfile "]]" block)) + (if msg (message msg cnt)) (goto-char beg) - (not (re-search-forward "^[ \t]*|[^-|][^|]*[^#!$*_^| \t][^|]*|" end t)))) - (col (org-table-current-column)) - (forcenew (car (assoc newchar org-recalc-marks))) - epos new) - (when l1 - (message "Change region to what mark? Type # * ! $ or SPC: ") - (setq newchar (char-to-string (read-char-exclusive)) - forcenew (car (assoc newchar org-recalc-marks)))) - (if (and newchar (not forcenew)) - (error "Invalid NEWCHAR `%s' in `org-table-rotate-recalc-marks'" - newchar)) - (if l1 (goto-line l1)) - (save-excursion - (beginning-of-line 1) - (unless (looking-at org-table-dataline-regexp) - (error "Not at a table data line"))) - (unless have-col - (org-table-goto-column 1) - (org-table-insert-column) - (org-table-goto-column (1+ col))) - (setq epos (point-at-eol)) - (save-excursion - (beginning-of-line 1) - (org-table-get-field - 1 (if (looking-at "^[ \t]*| *\\([#!$*^_ ]\\) *|") - (concat " " - (setq new (or forcenew - (cadr (member (match-string 1) marks)))) - " ") - " # "))) - (if (and l1 l2) - (progn - (goto-line l1) - (while (progn (beginning-of-line 2) (not (= (org-current-line) l2))) - (and (looking-at org-table-dataline-regexp) - (org-table-get-field 1 (concat " " new " ")))) - (goto-line l1))) - (if (not (= epos (point-at-eol))) (org-table-align)) - (goto-line l) - (and (interactive-p) (message (cdr (assoc new org-recalc-marks)))))) - -(defun org-table-maybe-recalculate-line () - "Recompute the current line if marked for it, and if we haven't just done it." - (interactive) - (and org-table-allow-automatic-line-recalculation - (not (and (memq last-command org-recalc-commands) - (equal org-last-recalc-line (org-current-line)))) - (save-excursion (beginning-of-line 1) - (looking-at org-table-auto-recalculate-regexp)) - (fboundp 'calc-eval) - (org-table-recalculate) t)) - -(defvar org-table-formula-debug nil - "Non-nil means, debug table formulas. -When nil, simply write \"#ERROR\" in corrupted fields.") - -(defvar modes) -(defsubst org-set-calc-mode (var &optional value) - (if (stringp var) - (setq var (assoc var '(("D" calc-angle-mode deg) - ("R" calc-angle-mode rad) - ("F" calc-prefer-frac t) - ("S" calc-symbolic-mode t))) - value (nth 2 var) var (nth 1 var))) - (if (memq var modes) - (setcar (cdr (memq var modes)) value) - (cons var (cons value modes))) - modes) - -(defun org-table-eval-formula (&optional arg equation - suppress-align suppress-const - suppress-store) - "Replace the table field value at the cursor by the result of a calculation. - -This function makes use of Dave Gillespie's Calc package, in my view the -most exciting program ever written for GNU Emacs. So you need to have Calc -installed in order to use this function. - -In a table, this command replaces the value in the current field with the -result of a formula. It also installs the formula as the \"current\" column -formula, by storing it in a special line below the table. When called -with a `C-u' prefix, the current field must ba a named field, and the -formula is installed as valid in only this specific field. - -When called, the command first prompts for a formula, which is read in -the minibuffer. Previously entered formulas are available through the -history list, and the last used formula is offered as a default. -These stored formulas are adapted correctly when moving, inserting, or -deleting columns with the corresponding commands. - -The formula can be any algebraic expression understood by the Calc package. -For details, see the Org-mode manual. - -This function can also be called from Lisp programs and offers -additional arguments: EQUATION can be the formula to apply. If this -argument is given, the user will not be prompted. SUPPRESS-ALIGN is -used to speed-up recursive calls by by-passing unnecessary aligns. -SUPPRESS-CONST suppresses the interpretation of constants in the -formula, assuming that this has been done already outside the function. -SUPPRESS-STORE means the formula should not be stored, either because -it is already stored, or because it is a modified equation that should -not overwrite the stored one." - (interactive "P") - (require 'calc) - (org-table-check-inside-data-field) - (org-table-get-specials) - (let* (fields - (ndown (if (integerp arg) arg 1)) - (org-table-automatic-realign nil) - (case-fold-search nil) - (down (> ndown 1)) - (formula (if (and equation suppress-store) - equation - (org-table-get-formula equation (equal arg '(4))))) - (n0 (org-table-current-column)) - (modes (copy-sequence org-calc-default-modes)) - n form fmt x ev orig c lispp) - ;; Parse the format string. Since we have a lot of modes, this is - ;; a lot of work. However, I think calc still uses most of the time. - (if (string-match ";" formula) - (let ((tmp (org-split-string formula ";"))) - (setq formula (car tmp) - fmt (concat (cdr (assoc "%" org-table-local-parameters)) - (nth 1 tmp))) - (while (string-match "\\([pnfse]\\)\\(-?[0-9]+\\)" fmt) - (setq c (string-to-char (match-string 1 fmt)) - n (string-to-number (match-string 2 fmt))) - (if (= c ?p) - (setq modes (org-set-calc-mode 'calc-internal-prec n)) - (setq modes (org-set-calc-mode - 'calc-float-format - (list (cdr (assoc c '((?n . float) (?f . fix) - (?s . sci) (?e . eng)))) - n)))) - (setq fmt (replace-match "" t t fmt))) - (while (string-match "[DRFS]" fmt) - (setq modes (org-set-calc-mode (match-string 0 fmt))) - (setq fmt (replace-match "" t t fmt))) - (unless (string-match "\\S-" fmt) - (setq fmt nil)))) - (if (and (not suppress-const) org-table-formula-use-constants) - (setq formula (org-table-formula-substitute-names formula))) - (setq orig (or (get-text-property 1 :orig-formula formula) "?")) - (while (> ndown 0) - (setq fields (org-split-string - (buffer-substring - (point-at-bol) (point-at-eol)) " *| *")) - (if org-table-formula-numbers-only - (setq fields (mapcar - (lambda (x) (number-to-string (string-to-number x))) - fields))) - (setq ndown (1- ndown)) - (setq form (copy-sequence formula) - lispp (equal (substring form 0 2) "'(")) - ;; Insert the references to fields in same row - (while (string-match "\\$\\([0-9]+\\)?" form) - (setq n (if (match-beginning 1) - (string-to-number (match-string 1 form)) - n0) - x (nth (1- n) fields)) - (unless x (error "Invalid field specifier \"%s\"" - (match-string 0 form))) - (if (equal x "") (setq x "0")) - (setq form (replace-match - (if lispp x (concat "(" x ")")) - t t form))) - ;; Insert ranges in current column - (while (string-match "\\&[-I0-9]+" form) - (setq form (replace-match - (save-match-data - (org-table-get-vertical-vector (match-string 0 form) - nil n0)) - t t form))) - (if lispp - (setq ev (eval (eval (read form))) - ev (if (numberp ev) (number-to-string ev) ev)) - (setq ev (calc-eval (cons form modes) - (if org-table-formula-numbers-only 'num)))) - - (when org-table-formula-debug - (with-output-to-temp-buffer "*Help*" - (princ (format "Substitution history of formula -Orig: %s -$xyz-> %s -$1-> %s\n" orig formula form)) - (if (listp ev) - (princ (format " %s^\nError: %s" - (make-string (car ev) ?\-) (nth 1 ev))) - (princ (format "Result: %s\nFormat: %s\nFinal: %s" - ev (or fmt "NONE") - (if fmt (format fmt (string-to-number ev)) ev))))) - (shrink-window-if-larger-than-buffer (get-buffer-window "*Help*")) - (unless (and (interactive-p) (not ndown)) - (unless (let (inhibit-redisplay) - (y-or-n-p "Debugging Formula. Continue to next? ")) - (org-table-align) - (error "Abort")) - (delete-window (get-buffer-window "*Help*")) - (message ""))) - (if (listp ev) (setq fmt nil ev "#ERROR")) - (org-table-justify-field-maybe - (if fmt (format fmt (string-to-number ev)) ev)) - (if (and down (> ndown 0) (looking-at ".*\n[ \t]*|[^-]")) - (call-interactively 'org-return) - (setq ndown 0))) - (and down (org-table-maybe-recalculate-line)) - (or suppress-align (and org-table-may-need-update - (org-table-align))))) - -(defun org-table-recalculate (&optional all noalign) - "Recalculate the current table line by applying all stored formulas. -With prefix arg ALL, do this for all lines in the table." - (interactive "P") - (or (memq this-command org-recalc-commands) - (setq org-recalc-commands (cons this-command org-recalc-commands))) - (unless (org-at-table-p) (error "Not at a table")) - (org-table-get-specials) - (let* ((eqlist (sort (org-table-get-stored-formulas) - (lambda (a b) (string< (car a) (car b))))) - (inhibit-redisplay t) - (line-re org-table-dataline-regexp) - (thisline (org-current-line)) - (thiscol (org-table-current-column)) - beg end entry eqlnum eqlname eql (cnt 0) eq a name) - ;; Insert constants in all formulas - (setq eqlist - (mapcar (lambda (x) - (setcdr x (org-table-formula-substitute-names (cdr x))) - x) - eqlist)) - ;; Split the equation list - (while (setq eq (pop eqlist)) - (if (<= (string-to-char (car eq)) ?9) - (push eq eqlnum) - (push eq eqlname))) - (setq eqlnum (nreverse eqlnum) eqlname (nreverse eqlname)) - (if all - (progn - (setq end (move-marker (make-marker) (1+ (org-table-end)))) - (goto-char (setq beg (org-table-begin))) - (if (re-search-forward org-table-calculate-mark-regexp end t) - ;; This is a table with marked lines, only compute selected lines - (setq line-re org-table-recalculate-regexp) - ;; Move forward to the first non-header line - (if (and (re-search-forward org-table-dataline-regexp end t) - (re-search-forward org-table-hline-regexp end t) - (re-search-forward org-table-dataline-regexp end t)) - (setq beg (match-beginning 0)) - nil))) ;; just leave beg where it is - (setq beg (point-at-bol) - end (move-marker (make-marker) (1+ (point-at-eol))))) - (goto-char beg) - (and all (message "Re-applying formulas to full table...")) - (while (re-search-forward line-re end t) - (unless (string-match "^ *[_^!$] *$" (org-table-get-field 1)) - ;; Unprotected line, recalculate - (and all (message "Re-applying formulas to full table...(line %d)" - (setq cnt (1+ cnt)))) - (setq org-last-recalc-line (org-current-line)) - (setq eql eqlnum) - (while (setq entry (pop eql)) - (goto-line org-last-recalc-line) - (org-table-goto-column (string-to-number (car entry)) nil 'force) - (org-table-eval-formula nil (cdr entry) 'noalign 'nocst 'nostore)))) - (goto-line thisline) - (org-table-goto-column thiscol) - (or noalign (and org-table-may-need-update (org-table-align)) - (and all (message "Re-applying formulas to %d lines...done" cnt))) - ;; Now do the names fields - (while (setq eq (pop eqlname)) - (setq name (car eq) - a (assoc name org-table-named-field-locations)) - (when a - (message "Re-applying formula to named field: %s" name) - (goto-line (nth 1 a)) - (org-table-goto-column (nth 2 a)) - (org-table-eval-formula nil (cdr eq) 'noalign 'nocst 'nostore))) - ;; back to initial position - (goto-line thisline) - (org-table-goto-column thiscol) - (or noalign (and org-table-may-need-update (org-table-align)) - (and all (message "Re-applying formulas...done"))))) - -(defun org-table-formula-substitute-names (f) - "Replace $const with values in string F." - (let ((start 0) a n1 n2 nn1 nn2 s (f1 f)) - ;; First, check for column names - (while (setq start (string-match org-table-column-name-regexp f start)) - (setq start (1+ start)) - (setq a (assoc (match-string 1 f) org-table-column-names)) - (setq f (replace-match (concat "$" (cdr a)) t t f))) - ;; Expand ranges to vectors - (while (string-match "\\$\\([0-9]+\\)\\.\\.\\.?\\$\\([0-9]+\\)" f) - (setq n1 (string-to-number (match-string 1 f)) - n2 (string-to-number (match-string 2 f)) - nn1 (1+ (min n1 n2)) nn2 (max n1 n2) - s (concat "[($" (number-to-string (1- nn1)) ")")) - (loop for i from nn1 upto nn2 do - (setq s (concat s ",($" (int-to-string i) ")"))) - (setq s (concat s "]")) - (if (< n2 n1) (setq s (concat "rev(" s ")"))) - (setq f (replace-match s t t f))) - ;; Parameters and constants - (setq start 0) - (while (setq start (string-match "\\$\\([a-zA-Z][a-zA-Z0-9]*\\)" f start)) - (setq start (1+ start)) - (if (setq a (save-match-data - (org-table-get-constant (match-string 1 f)))) - (setq f (replace-match (concat "(" a ")") t t f)))) - (if org-table-formula-debug - (put-text-property 0 (length f) :orig-formula f1 f)) - f)) - -(defun org-table-get-constant (const) - "Find the value for a parameter or constant in a formula. -Parameters get priority." - (or (cdr (assoc const org-table-local-parameters)) - (cdr (assoc const org-table-formula-constants)) - (and (fboundp 'constants-get) (constants-get const)) - "#UNDEFINED_NAME")) - -(defvar org-edit-formulas-map (make-sparse-keymap)) -(define-key org-edit-formulas-map "\C-c\C-c" 'org-finish-edit-formulas) -(define-key org-edit-formulas-map "\C-c\C-q" 'org-abort-edit-formulas) -(define-key org-edit-formulas-map "\C-c?" 'org-show-variable) - -(defvar org-pos) + (org-create-formula-image + txt movefile opt) + (if overlays + (progn + (setq ov (org-make-overlay beg end)) + (if (featurep 'xemacs) + (progn + (org-overlay-put ov 'invisible t) + (org-overlay-put + ov 'end-glyph + (make-glyph (vector 'png :file movefile)))) + (org-overlay-put + ov 'display + (list 'image :type 'png :file movefile :ascent 'center))) + (push ov org-latex-fragment-image-overlays) + (goto-char end)) + (delete-region beg end) + (insert link)))))))) -(defun org-table-edit-formulas () - "Edit the formulas of the current table in a separate buffer." - (interactive) - (unless (org-at-table-p) - (error "Not at a table")) - (org-table-get-specials) - (let ((eql (org-table-get-stored-formulas)) - (pos (move-marker (make-marker) (point))) - (wc (current-window-configuration)) - entry loc s) - (switch-to-buffer-other-window "*Edit Formulas*") - (erase-buffer) - (fundamental-mode) - (org-set-local 'org-pos pos) - (org-set-local 'org-window-configuration wc) - (use-local-map org-edit-formulas-map) - (setq s "# Edit formulas and finish with `C-c C-c'. -# Use `C-u C-c C-c' to also appy them immediately to the entire table. -# Use `C-c ?' to get information about $name at point. -# To cancel editing, press `C-c C-q'.\n") - (put-text-property 0 (length s) 'face 'font-lock-comment-face s) - (insert s) - (while (setq entry (pop eql)) - (when (setq loc (assoc (car entry) org-table-named-field-locations)) - (setq s (format "# Named formula, referring to column %d in line %d\n" - (nth 2 loc) (nth 1 loc))) - (put-text-property 0 (length s) 'face 'font-lock-comment-face s) - (insert s)) - (setq s (concat "$" (car entry) "=" (cdr entry) "\n")) - (remove-text-properties 0 (length s) '(face nil) s) - (insert s)) - (goto-char (point-min)) - (message "Edit formulas and finish with `C-c C-c'."))) +;; This function borrows from Ganesh Swami's latex2png.el +(defun org-create-formula-image (string tofile options) + (let* ((tmpdir (if (featurep 'xemacs) + (temp-directory) + temporary-file-directory)) + (texfilebase (make-temp-name + (expand-file-name "orgtex" tmpdir))) -(defun org-show-variable () - "Show the location/value of the $ expression at point." - (interactive) - (let (var (pos org-pos) (win (selected-window)) e) - (save-excursion - (or (looking-at "\\$") (skip-chars-backward "$a-zA-Z0-9")) - (if (looking-at "\\$\\([a-zA-Z0-9]+\\)") - (setq var (match-string 1)) - (error "No variable at point"))) - (cond - ((setq e (assoc var org-table-named-field-locations)) - (switch-to-buffer-other-window (marker-buffer pos)) - (goto-line (nth 1 e)) - (org-table-goto-column (nth 2 e)) - (select-window win) - (message "Named field, column %d of line %d" (nth 2 e) (nth 1 e))) - ((setq e (assoc var org-table-column-names)) - (switch-to-buffer-other-window (marker-buffer pos)) - (goto-char pos) - (goto-char (org-table-begin)) - (if (re-search-forward (concat "^[ \t]*| *! *.*?| *\\(" var "\\) *|") - (org-table-end) t) - (progn - (goto-char (match-beginning 1)) - (message "Named column (column %s)" (cdr e))) - (error "Column name not found")) - (select-window win)) - ((string-match "^[0-9]$" var) - ;; column number - (switch-to-buffer-other-window (marker-buffer pos)) - (goto-char pos) - (goto-char (org-table-begin)) - (recenter 1) - (if (re-search-forward org-table-dataline-regexp - (org-table-end) t) - (progn - (goto-char (match-beginning 0)) - (org-table-goto-column (string-to-number var)) - (message "Column %s" var)) - (error "Column name not found")) - (select-window win)) - ((setq e (assoc var org-table-local-parameters)) - (switch-to-buffer-other-window (marker-buffer pos)) - (goto-char pos) - (goto-char (org-table-begin)) - (if (re-search-forward (concat "^[ \t]*| *\\$ *.*?| *\\(" var "=\\)") nil t) +;(texfilebase (make-temp-file "orgtex")) +; (dummy (delete-file texfilebase)) + (texfile (concat texfilebase ".tex")) + (dvifile (concat texfilebase ".dvi")) + (pngfile (concat texfilebase ".png")) + (scale (number-to-string (* 1000 (or (plist-get options :scale) 1.0)))) + (fg (or (plist-get options :foreground) "Black")) + (bg (or (plist-get options :background) "Transparent"))) + (with-temp-file texfile + (insert "\\documentclass{article} +\\usepackage{fullpage} +\\usepackage{amssymb} +\\usepackage[usenames]{color} +\\usepackage{amsmath} +\\usepackage{latexsym} +\\usepackage[mathscr]{eucal} +\\pagestyle{empty} +\\begin{document}\n" string "\n\\end{document}\n")) + (let ((dir default-directory)) + (condition-case nil (progn - (goto-char (match-beginning 1)) - (message "Local parameter.")) - (error "Parameter not found")) - (select-window win)) - (t - (cond - ((setq e (assoc var org-table-formula-constants)) - (message "Constant: $%s=%s in `org-table-formula-constants'." var (cdr e))) - ((setq e (and (fboundp 'constants-get) (constants-get var))) - (message "Constant: $%s=%s, retrieved from `constants.el'." var e)) - (t (error "Undefined name $%s" var))))))) - -(defun org-finish-edit-formulas (&optional arg) - "Parse the buffer for formula definitions and install them. -With prefix ARG, apply the new formulas to the table." - (interactive "P") - (let ((pos org-pos) eql) - (goto-char (point-min)) - (while (re-search-forward "^\\$\\([a-zA-Z0-9]+\\) *= *\\(.*?\\) *$" nil t) - (push (cons (match-string 1) (match-string 2)) eql)) - (set-window-configuration org-window-configuration) - (select-window (get-buffer-window (marker-buffer pos))) - (goto-char pos) - (unless (org-at-table-p) - (error "Lost table position - cannot install formulae")) - (org-table-store-formulas eql) - (move-marker pos nil) - (kill-buffer "*Edit Formulas*") - (if arg - (org-table-recalculate 'all) - (message "New formulas installed - press C-u C-c C-c to apply.")))) - -(defun org-abort-edit-formulas () - "Abort editing formulas, without installing the changes." - (interactive) - (let ((pos org-pos)) - (set-window-configuration org-window-configuration) - (select-window (get-buffer-window (marker-buffer pos))) - (goto-char pos) - (message "Formula editing aborted without installing changes"))) - -;;;; The orgtbl minor mode - -;; Define a minor mode which can be used in other modes in order to -;; integrate the org-mode table editor. - -;; This is really a hack, because the org-mode table editor uses several -;; keys which normally belong to the major mode, for example the TAB and -;; RET keys. Here is how it works: The minor mode defines all the keys -;; necessary to operate the table editor, but wraps the commands into a -;; function which tests if the cursor is currently inside a table. If that -;; is the case, the table editor command is executed. However, when any of -;; those keys is used outside a table, the function uses `key-binding' to -;; look up if the key has an associated command in another currently active -;; keymap (minor modes, major mode, global), and executes that command. -;; There might be problems if any of the keys used by the table editor is -;; otherwise used as a prefix key. - -;; Another challenge is that the key binding for TAB can be tab or \C-i, -;; likewise the binding for RET can be return or \C-m. Orgtbl-mode -;; addresses this by checking explicitly for both bindings. - -;; The optimized version (see variable `orgtbl-optimized') takes over -;; all keys which are bound to `self-insert-command' in the *global map*. -;; Some modes bind other commands to simple characters, for example -;; AUCTeX binds the double quote to `Tex-insert-quote'. With orgtbl-mode -;; active, this binding is ignored inside tables and replaced with a -;; modified self-insert. - -(defvar orgtbl-mode nil - "Variable controlling `orgtbl-mode', a minor mode enabling the `org-mode' -table editor in arbitrary modes.") -(make-variable-buffer-local 'orgtbl-mode) - -(defvar orgtbl-mode-map (make-keymap) - "Keymap for `orgtbl-mode'.") - -;;;###autoload -(defun turn-on-orgtbl () - "Unconditionally turn on `orgtbl-mode'." - (orgtbl-mode 1)) - -;;;###autoload -(defun orgtbl-mode (&optional arg) - "The `org-mode' table editor as a minor mode for use in other modes." - (interactive) - (if (org-mode-p) - ;; Exit without error, in case some hook functions calls this - ;; by accident in org-mode. - (message "Orgtbl-mode is not useful in org-mode, command ignored") - (setq orgtbl-mode - (if arg (> (prefix-numeric-value arg) 0) (not orgtbl-mode))) - (if orgtbl-mode - (progn - (and (orgtbl-setup) (defun orgtbl-setup () nil)) - ;; Make sure we are first in minor-mode-map-alist - (let ((c (assq 'orgtbl-mode minor-mode-map-alist))) - (and c (setq minor-mode-map-alist - (cons c (delq c minor-mode-map-alist))))) - (org-set-local (quote org-table-may-need-update) t) - (org-add-hook 'before-change-functions 'org-before-change-function - nil 'local) - (org-set-local 'org-old-auto-fill-inhibit-regexp - auto-fill-inhibit-regexp) - (org-set-local 'auto-fill-inhibit-regexp - (if auto-fill-inhibit-regexp - (concat "\\([ \t]*|\\|" auto-fill-inhibit-regexp) - "[ \t]*|")) - (org-add-to-invisibility-spec '(org-cwidth)) - (easy-menu-add orgtbl-mode-menu) - (run-hooks 'orgtbl-mode-hook)) - (setq auto-fill-inhibit-regexp org-old-auto-fill-inhibit-regexp) - (org-cleanup-narrow-column-properties) - (org-remove-from-invisibility-spec '(org-cwidth)) - (remove-hook 'before-change-functions 'org-before-change-function t) - (easy-menu-remove orgtbl-mode-menu) - (force-mode-line-update 'all)))) - -(defun org-cleanup-narrow-column-properties () - "Remove all properties related to narrow-column invisibility." - (let ((s 1)) - (while (setq s (text-property-any s (point-max) - 'display org-narrow-column-arrow)) - (remove-text-properties s (1+ s) '(display t))) - (setq s 1) - (while (setq s (text-property-any s (point-max) 'org-cwidth 1)) - (remove-text-properties s (1+ s) '(org-cwidth t))) - (setq s 1) - (while (setq s (text-property-any s (point-max) 'invisible 'org-cwidth)) - (remove-text-properties s (1+ s) '(invisible t))))) - -;; Install it as a minor mode. -(put 'orgtbl-mode :included t) -(put 'orgtbl-mode :menu-tag "Org Table Mode") -(add-minor-mode 'orgtbl-mode " OrgTbl" orgtbl-mode-map) - -(defun orgtbl-make-binding (fun n &rest keys) - "Create a function for binding in the table minor mode. -FUN is the command to call inside a table. N is used to create a unique -command name. KEYS are keys that should be checked in for a command -to execute outside of tables." - (eval - (list 'defun - (intern (concat "orgtbl-hijacker-command-" (int-to-string n))) - '(arg) - (concat "In tables, run `" (symbol-name fun) "'.\n" - "Outside of tables, run the binding of `" - (mapconcat (lambda (x) (format "%s" x)) keys "' or `") - "'.") - '(interactive "p") - (list 'if - '(org-at-table-p) - (list 'call-interactively (list 'quote fun)) - (list 'let '(orgtbl-mode) - (list 'call-interactively - (append '(or) - (mapcar (lambda (k) - (list 'key-binding k)) - keys) - '('orgtbl-error)))))))) - -(defun orgtbl-error () - "Error when there is no default binding for a table key." - (interactive) - (error "This key is has no function outside tables")) - -(defun orgtbl-setup () - "Setup orgtbl keymaps." - (let ((nfunc 0) - (bindings - (list - '([(meta shift left)] org-table-delete-column) - '([(meta left)] org-table-move-column-left) - '([(meta right)] org-table-move-column-right) - '([(meta shift right)] org-table-insert-column) - '([(meta shift up)] org-table-kill-row) - '([(meta shift down)] org-table-insert-row) - '([(meta up)] org-table-move-row-up) - '([(meta down)] org-table-move-row-down) - '("\C-c\C-w" org-table-cut-region) - '("\C-c\M-w" org-table-copy-region) - '("\C-c\C-y" org-table-paste-rectangle) - '("\C-c-" org-table-insert-hline) -; '([(shift tab)] org-table-previous-field) - '("\C-m" org-table-next-row) - (list (org-key 'S-return) 'org-table-copy-down) - '([(meta return)] org-table-wrap-region) - '("\C-c\C-q" org-table-wrap-region) - '("\C-c?" org-table-current-column) - '("\C-c " org-table-blank-field) - '("\C-c+" org-table-sum) - '("\C-c=" org-table-eval-formula) - '("\C-c'" org-table-edit-formulas) - '("\C-c`" org-table-edit-field) - '("\C-c*" org-table-recalculate) - '("\C-c|" org-table-create-or-convert-from-region) - '("\C-c^" org-table-sort-lines) - '([(control ?#)] org-table-rotate-recalc-marks))) - elt key fun cmd) - (while (setq elt (pop bindings)) - (setq nfunc (1+ nfunc)) - (setq key (car elt) - fun (nth 1 elt) - cmd (orgtbl-make-binding fun nfunc key)) - (define-key orgtbl-mode-map key cmd)) - ;; Special treatment needed for TAB and RET - (define-key orgtbl-mode-map [(return)] - (orgtbl-make-binding 'orgtbl-ret 100 [(return)] "\C-m")) - (define-key orgtbl-mode-map "\C-m" - (orgtbl-make-binding 'orgtbl-ret 101 "\C-m" [(return)])) - (define-key orgtbl-mode-map [(tab)] - (orgtbl-make-binding 'orgtbl-tab 102 [(tab)] "\C-i")) - (define-key orgtbl-mode-map "\C-i" - (orgtbl-make-binding 'orgtbl-tab 103 "\C-i" [(tab)]))) - (define-key orgtbl-mode-map "\C-i" - (orgtbl-make-binding 'orgtbl-tab 104 [(shift tab)])) - (define-key orgtbl-mode-map "\C-c\C-c" - (orgtbl-make-binding 'org-ctrl-c-ctrl-c 105 "\C-c\C-c")) - (when orgtbl-optimized - ;; If the user wants maximum table support, we need to hijack - ;; some standard editing functions - (org-remap orgtbl-mode-map - 'self-insert-command 'orgtbl-self-insert-command - 'delete-char 'org-delete-char - 'delete-backward-char 'org-delete-backward-char) - (define-key orgtbl-mode-map "|" 'org-force-self-insert)) - (easy-menu-define orgtbl-mode-menu orgtbl-mode-map "OrgTbl menu" - '("OrgTbl" - ["Align" org-ctrl-c-ctrl-c :active (org-at-table-p) :keys "C-c C-c"] - ["Next Field" org-cycle :active (org-at-table-p) :keys "TAB"] - ["Previous Field" org-shifttab :active (org-at-table-p) :keys "S-TAB"] - ["Next Row" org-return :active (org-at-table-p) :keys "RET"] - "--" - ["Blank Field" org-table-blank-field :active (org-at-table-p) :keys "C-c SPC"] - ["Edit Field" org-table-edit-field :active (org-at-table-p) :keys "C-c ` "] - ["Copy Field from Above" - org-table-copy-down :active (org-at-table-p) :keys "S-RET"] - "--" - ("Column" - ["Move Column Left" org-metaleft :active (org-at-table-p) :keys "M-<left>"] - ["Move Column Right" org-metaright :active (org-at-table-p) :keys "M-<right>"] - ["Delete Column" org-shiftmetaleft :active (org-at-table-p) :keys "M-S-<left>"] - ["Insert Column" org-shiftmetaright :active (org-at-table-p) :keys "M-S-<right>"] - "--" - ["Enable Narrowing" (setq org-table-limit-column-width (not org-table-limit-column-width)) :active (org-at-table-p) :selected org-table-limit-column-width :style toggle]) - ("Row" - ["Move Row Up" org-metaup :active (org-at-table-p) :keys "M-<up>"] - ["Move Row Down" org-metadown :active (org-at-table-p) :keys "M-<down>"] - ["Delete Row" org-shiftmetaup :active (org-at-table-p) :keys "M-S-<up>"] - ["Insert Row" org-shiftmetadown :active (org-at-table-p) :keys "M-S-<down>"] - ["Sort lines in region" org-table-sort-lines (org-at-table-p) :keys "C-c ^"] - "--" - ["Insert Hline" org-table-insert-hline :active (org-at-table-p) :keys "C-c -"]) - ("Rectangle" - ["Copy Rectangle" org-copy-special :active (org-at-table-p)] - ["Cut Rectangle" org-cut-special :active (org-at-table-p)] - ["Paste Rectangle" org-paste-special :active (org-at-table-p)] - ["Fill Rectangle" org-table-wrap-region :active (org-at-table-p)]) - "--" - ["Set Column Formula" org-table-eval-formula :active (org-at-table-p) :keys "C-c ="] - ["Set Named Field Formula" (org-table-eval-formula '(4)) :active (org-at-table-p) :keys "C-u C-c ="] - ["Edit Formulas" org-table-edit-formulas :active (org-at-table-p) :keys "C-c '"] - ["Recalculate line" org-table-recalculate :active (org-at-table-p) :keys "C-c *"] - ["Recalculate all" (org-table-recalculate '(4)) :active (org-at-table-p) :keys "C-u C-c *"] - ["Toggle Recalculate Mark" org-table-rotate-recalc-marks :active (org-at-table-p) :keys "C-c #"] - ["Sum Column/Rectangle" org-table-sum - :active (or (org-at-table-p) (org-region-active-p)) :keys "C-c +"] - ["Which Column?" org-table-current-column :active (org-at-table-p) :keys "C-c ?"] - ["Debug Formulas" - (setq org-table-formula-debug (not org-table-formula-debug)) - :style toggle :selected org-table-formula-debug] - )) - t) - -(defun orgtbl-tab (arg) - "Justification and field motion for `orgtbl-mode'." - (interactive "P") - (if arg (org-table-edit-field t) - (org-table-justify-field-maybe) - (org-table-next-field))) - -(defun orgtbl-ret () - "Justification and field motion for `orgtbl-mode'." - (interactive) - (org-table-justify-field-maybe) - (org-table-next-row)) - -(defun orgtbl-self-insert-command (N) - "Like `self-insert-command', use overwrite-mode for whitespace in tables. -If the cursor is in a table looking at whitespace, the whitespace is -overwritten, and the table is not marked as requiring realignment." - (interactive "p") - (if (and (org-at-table-p) - (or - (and org-table-auto-blank-field - (member last-command - '(orgtbl-hijacker-command-100 - orgtbl-hijacker-command-101 - orgtbl-hijacker-command-102 - orgtbl-hijacker-command-103 - orgtbl-hijacker-command-104 - orgtbl-hijacker-command-105)) - (org-table-blank-field)) - t) - (eq N 1) - (looking-at "[^|\n]* +|")) - (let (org-table-may-need-update) - (goto-char (1- (match-end 0))) - (delete-backward-char 1) - (goto-char (match-beginning 0)) - (self-insert-command N)) - (setq org-table-may-need-update t) - (let (orgtbl-mode) - (call-interactively (key-binding (vector last-input-event)))))) - -(defun org-force-self-insert (N) - "Needed to enforce self-insert under remapping." - (interactive "p") - (self-insert-command N)) + (cd tmpdir) + (call-process "latex" nil nil nil texfile)) + (error nil)) + (cd dir)) + (if (not (file-exists-p dvifile)) + (progn (message "Failed to create dvi file from %s" texfile) nil) + (call-process "dvipng" nil nil nil + "-E" "-fg" fg "-bg" bg + "-x" scale "-y" scale "-T" "tight" + "-o" pngfile + dvifile) + (if (not (file-exists-p pngfile)) + (progn (message "Failed to create png file from %s" texfile) nil) + ;; Use the requested file name and clean up + (copy-file pngfile tofile 'replace) + (loop for e in '(".dvi" ".tex" ".aux" ".log" ".png") do + (delete-file (concat texfilebase e))) + pngfile)))) ;;;; Exporting +;;; Variables, constants, and parameter plists + (defconst org-level-max 20) (defvar org-export-html-preamble nil @@ -14533,6 +15003,9 @@ overwritten, and the table is not marked as requiring realignment." "Should default preamble be inserted? Set by publishing functions.") (defvar org-export-html-auto-postamble t "Should default postamble be inserted? Set by publishing functions.") +(defvar org-current-export-file nil) ; dynamically scoped parameter +(defvar org-current-export-dir nil) ; dynamically scoped parameter + (defconst org-export-plist-vars '((:language . org-export-default-language) @@ -14711,8 +15184,6 @@ ones and overrule settings in the other lists." (call-interactively (cdr ass)) (error "No command associated with key %c" r1)))) -;;; ASCII - (defconst org-html-entities '(("nbsp") ("iexcl") @@ -15011,6 +15482,8 @@ The list contains HTML entities for Latin-1, Greek and other symbols. It is supplemented by a number of commonly used TeX macros with appropriate translations. There is currently no way for users to extend this.") +;;; General functions for all backends + (defun org-cleaned-string-for-export (string &rest parameters) "Cleanup a buffer substring so that links can be created safely." (interactive) @@ -15117,48 +15590,56 @@ translations. There is currently no way for users to extend this.") (a (assoc rtn alist))) (or (cdr a) rtn)))) -(defun org-convert-to-odd-levels () - "Convert an org-mode file with all levels allowed to one with odd levels. -This will leave level 1 alone, convert level 2 to level 3, level 3 to -level 5 etc." - (interactive) - (when (yes-or-no-p "Are you sure you want to globally change levels to odd? ") - (let ((org-odd-levels-only nil) n) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "^\\*\\*+" nil t) - (setq n (1- (length (match-string 0)))) - (while (>= (setq n (1- n)) 0) - (org-demote)) - (end-of-line 1)))))) +;; Variable holding the vector with section numbers +(defvar org-section-numbers (make-vector org-level-max 0)) +(defun org-init-section-numbers () + "Initialize the vector for the section numbers." + (let* ((level -1) + (numbers (nreverse (org-split-string "" "\\."))) + (depth (1- (length org-section-numbers))) + (i depth) number-string) + (while (>= i 0) + (if (> i level) + (aset org-section-numbers i 0) + (setq number-string (or (car numbers) "0")) + (if (string-match "\\`[A-Z]\\'" number-string) + (aset org-section-numbers i + (- (string-to-char number-string) ?A -1)) + (aset org-section-numbers i (string-to-number number-string))) + (pop numbers)) + (setq i (1- i))))) -(defun org-convert-to-oddeven-levels () - "Convert an org-mode file with only odd levels to one with odd and even levels. -This promotes level 3 to level 2, level 5 to level 3 etc. If the file contains a -section with an even level, conversion would destroy the structure of the file. An error -is signaled in this case." - (interactive) - (goto-char (point-min)) - ;; First check if there are no even levels - (when (re-search-forward "^\\(\\*\\*\\)+[^*]" nil t) - (org-show-context t) - (error "Not all levels are odd in this file. Conversion not possible.")) - (when (yes-or-no-p "Are you sure you want to globally change levels to odd-even? ") - (let ((org-odd-levels-only nil) n) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "^\\*\\*+" nil t) - (setq n (/ (length (match-string 0)) 2)) - (while (>= (setq n (1- n)) 0) - (org-promote)) - (end-of-line 1)))))) +(defun org-section-number (&optional level) + "Return a string with the current section number. +When LEVEL is non-nil, increase section numbers on that level." + (let* ((depth (1- (length org-section-numbers))) idx n (string "")) + (when level + (when (> level -1) + (aset org-section-numbers + level (1+ (aref org-section-numbers level)))) + (setq idx (1+ level)) + (while (<= idx depth) + (if (not (= idx 1)) + (aset org-section-numbers idx 0)) + (setq idx (1+ idx)))) + (setq idx 0) + (while (<= idx depth) + (setq n (aref org-section-numbers idx)) + (setq string (concat string (if (not (string= string "")) "." "") + (int-to-string n))) + (setq idx (1+ idx))) + (save-match-data + (if (string-match "\\`\\([@0]\\.\\)+" string) + (setq string (replace-match "" t nil string))) + (if (string-match "\\(\\.0\\)+\\'" string) + (setq string (replace-match "" t nil string)))) + string)) -(defun org-tr-level (n) - "Make N odd if required." - (if org-odd-levels-only (1+ (/ n 2)) n)) +;;; ASCII export (defvar org-last-level nil) ; dynamically scoped variable +(defvar org-levels-open nil) ; dynamically scoped parameter (defvar org-ascii-current-indentation nil) ; For communication (defun org-export-as-ascii (arg) @@ -15191,7 +15672,7 @@ underlined headlines. The default is 3." (file-name-nondirectory buffer-file-name)) ".txt")) (buffer (find-file-noselect filename)) - (levels-open (make-vector org-level-max nil)) + (org-levels-open (make-vector org-level-max nil)) (odd org-odd-levels-only) (date (format-time-string "%Y/%m/%d" (current-time))) (time (format-time-string "%X" (org-current-time))) @@ -15452,7 +15933,7 @@ command." (not (get-char-property s 'invisible)))) s)) -;;; HTML +;;; HTML export (defun org-get-current-options () "Return a string with current options as keyword options. @@ -15626,7 +16107,7 @@ org-mode's default settings, but still inferior to file-local settings." ".html")) (current-dir (file-name-directory buffer-file-name)) (buffer (find-file-noselect filename)) - (levels-open (make-vector org-level-max nil)) + (org-levels-open (make-vector org-level-max nil)) (date (format-time-string "%Y/%m/%d" (current-time))) (time (format-time-string "%X" (org-current-time))) (author (plist-get opt-plist :author)) @@ -16379,10 +16860,10 @@ When TITLE is nil, just close all open levels." (org-close-par-maybe) (let ((l (1+ (max level umax)))) (while (<= l org-level-max) - (if (aref levels-open (1- l)) + (if (aref org-levels-open (1- l)) (progn (org-html-level-close l) - (aset levels-open (1- l) nil))) + (aset org-levels-open (1- l) nil))) (setq l (1+ l))) (when title ;; If title is nil, this means this function is called to close @@ -16401,11 +16882,11 @@ When TITLE is nil, just close all open levels." t t title))) (if (> level umax) (progn - (if (aref levels-open (1- level)) + (if (aref org-levels-open (1- level)) (progn (org-close-li) (insert "<li>" title "<br/>\n")) - (aset levels-open (1- level) t) + (aset org-levels-open (1- level) t) (org-close-par-maybe) (insert "<ul>\n<li>" title "<br/>\n"))) (if org-export-with-section-numbers @@ -16422,52 +16903,7 @@ When TITLE is nil, just close all open levels." (org-close-li) (insert "</ul>")) -;; Variable holding the vector with section numbers -(defvar org-section-numbers (make-vector org-level-max 0)) - -(defun org-init-section-numbers () - "Initialize the vector for the section numbers." - (let* ((level -1) - (numbers (nreverse (org-split-string "" "\\."))) - (depth (1- (length org-section-numbers))) - (i depth) number-string) - (while (>= i 0) - (if (> i level) - (aset org-section-numbers i 0) - (setq number-string (or (car numbers) "0")) - (if (string-match "\\`[A-Z]\\'" number-string) - (aset org-section-numbers i - (- (string-to-char number-string) ?A -1)) - (aset org-section-numbers i (string-to-number number-string))) - (pop numbers)) - (setq i (1- i))))) - -(defun org-section-number (&optional level) - "Return a string with the current section number. -When LEVEL is non-nil, increase section numbers on that level." - (let* ((depth (1- (length org-section-numbers))) idx n (string "")) - (when level - (when (> level -1) - (aset org-section-numbers - level (1+ (aref org-section-numbers level)))) - (setq idx (1+ level)) - (while (<= idx depth) - (if (not (= idx 1)) - (aset org-section-numbers idx 0)) - (setq idx (1+ idx)))) - (setq idx 0) - (while (<= idx depth) - (setq n (aref org-section-numbers idx)) - (setq string (concat string (if (not (string= string "")) "." "") - (int-to-string n))) - (setq idx (1+ idx))) - (save-match-data - (if (string-match "\\`\\([@0]\\.\\)+" string) - (setq string (replace-match "" t nil string))) - (if (string-match "\\(\\.0\\)+\\'" string) - (setq string (replace-match "" t nil string)))) - string)) - +;;; iCalendar export ;;;###autoload (defun org-export-icalendar-this-file () @@ -16477,89 +16913,6 @@ file, but with extension `.ics'." (interactive) (org-export-icalendar nil buffer-file-name)) -(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) - -(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))) - ;; A quickie abstraction - - ;; Output everything as XOXO - (with-current-buffer (get-buffer buffer) - (goto-char (point-min)) ;; CD: beginning-of-buffer is not allowed. - (let* ((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)) - ;; 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 "^\\(\\*+\\) \\(.+\\)" (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")) - - ;; Finish the buffer off and clean it up. - (switch-to-buffer-other-window out) - (indent-region (point-min) (point-max) nil) - (save-buffer) - (goto-char (point-min)) - ))) - ;;;###autoload (defun org-export-icalendar-all-agenda-files () "Export all files in `org-agenda-files' to iCalendar .ics files. @@ -16626,6 +16979,8 @@ The iCalendar buffer is still current when this hook is run. A good way to use this is to tell a desktop calenndar application to re-read the iCalendar file.") + +;; FIXME: Strip down the links (defun org-print-icalendar-entries (&optional combine category) "Print iCalendar entries for the current Org-mode file to `standard-output'. When COMBINE is non nil, add the category to each line." @@ -16656,18 +17011,17 @@ When COMBINE is non nil, add the category to each line." (if (or (string-match org-tr-regexp hd) (string-match org-ts-regexp hd)) (setq hd (replace-match "" t t hd))) - (if combine - (setq hd (concat hd " (category " category ")"))) - (if deadlinep (setq hd (concat "DL: " hd " This is a deadline"))) - (if scheduledp (setq hd (concat "S: " hd " Scheduled for this date"))) + (if deadlinep (setq hd (concat "DL: " hd))) + (if scheduledp (setq hd (concat "S: " hd))) (princ (format "BEGIN:VEVENT %s %s SUMMARY:%s +CATEGORIES:%s END:VEVENT\n" (org-ical-ts-to-string ts "DTSTART") (org-ical-ts-to-string ts2 "DTEND" inc) - hd))) + hd category))) (when org-icalendar-include-todo (goto-char (point-min)) (while (re-search-forward org-todo-line-regexp nil t) @@ -16685,10 +17039,11 @@ END:VEVENT\n" (princ (format "BEGIN:VTODO %s SUMMARY:%s +CATEGORIES:%s SEQUENCE:1 PRIORITY:%d END:VTODO\n" - dts hd pri)))))))) + dts hd category pri)))))))) (defun org-start-icalendar-file (name) "Start an iCalendar file by inserting the header." @@ -16725,292 +17080,91 @@ a time), or the day by one (if it does not contain a time)." (setq fmt (if have-time ":%Y%m%dT%H%M%S" ";VALUE=DATE:%Y%m%d")) (concat keyword (format-time-string fmt time)))) -;;;; LaTeX stuff - -(defvar org-cdlatex-mode-map (make-sparse-keymap) - "Keymap for the minor `org-cdlatex-mode'.") - -(define-key org-cdlatex-mode-map "_" 'org-cdlatex-underscore-caret) -(define-key org-cdlatex-mode-map "^" 'org-cdlatex-underscore-caret) -(define-key org-cdlatex-mode-map "`" 'cdlatex-math-symbol) -(define-key org-cdlatex-mode-map "'" 'org-cdlatex-math-modify) -(define-key org-cdlatex-mode-map "\C-c{" 'cdlatex-environment) - -(defvar org-cdlatex-texmathp-advice-is-done nil - "Flag remembering if we have applied the advice to texmathp already.") - -(define-minor-mode org-cdlatex-mode - "Toggle the minor `org-cdlatex-mode'. -This mode supports entering LaTeX environment and math in LaTeX fragments -in Org-mode. -\\{org-cdlatex-mode-map}" - nil " OCDL" nil - (when org-cdlatex-mode (require 'cdlatex)) - (unless org-cdlatex-texmathp-advice-is-done - (setq org-cdlatex-texmathp-advice-is-done t) - (defadvice texmathp (around org-math-always-on activate) - "Always return t in org-mode buffers. -This is because we want to insert math symbols without dollars even outside -the LaTeX math segments. If Orgmode thinks that point is actually inside -en embedded LaTeX fragement, let texmathp do its job. -\\[org-cdlatex-mode-map]" - (interactive) - (let (p) - (cond - ((not (org-mode-p)) ad-do-it) - ((eq this-command 'cdlatex-math-symbol) - (setq ad-return-value t - texmathp-why '("cdlatex-math-symbol in org-mode" . 0))) - (t - (let ((p (org-inside-LaTeX-fragment-p))) - (if (and p (member (car p) (plist-get org-format-latex-options :matchers))) - (setq ad-return-value t - texmathp-why '("Org-mode embedded math" . 0)) - (if p ad-do-it))))))))) - -(defun turn-on-org-cdlatex () - "Unconditionally turn on `org-cdlatex-mode'." - (org-cdlatex-mode 1)) - -(defun org-inside-LaTeX-fragment-p () - "Test if point is inside a LaTeX fragment. -I.e. after a \\begin, \\(, \\[, $, or $$, without the corresponding closing -sequence appearing also before point. -Even though the matchers for math are configurable, this function assumes -that \\begin, \\(, \\[, and $$ are always used. Only the single dollar -delimiters are skipped when they have been removed by customization. -The return value is nil, or a cons cell with the delimiter and -and the position of this delimiter. - -This function does a reasonably good job, but can locally be fooled by -for example currency specifications. For example it will assume being in -inline math after \"$22.34\". The LaTeX fragment formatter will only format -fragments that are properly closed, but during editing, we have to live -with the uncertainty caused by missing closing delimiters. This function -looks only before point, not after." - (catch 'exit - (let ((pos (point)) - (dodollar (member "$" (plist-get org-format-latex-options :matchers))) - (lim (progn - (re-search-backward (concat "^\\(" paragraph-start "\\)") nil t) - (point))) - dd-on str (start 0) m re) - (goto-char pos) - (when dodollar - (setq str (concat (buffer-substring lim (point)) "\000 X$.") - re (nth 1 (assoc "$" org-latex-regexps))) - (while (string-match re str start) - (cond - ((= (match-end 0) (length str)) - (throw 'exit (cons "$" (+ lim (match-beginning 0))))) - ((= (match-end 0) (- (length str) 5)) - (throw 'exit nil)) - (t (setq start (match-end 0)))))) - (when (setq m (re-search-backward "\\(\\\\begin{[^}]*}\\|\\\\(\\|\\\\\\[\\)\\|\\(\\\\end{[^}]*}\\|\\\\)\\|\\\\\\]\\)\\|\\(\\$\\$\\)" lim t)) - (goto-char pos) - (and (match-beginning 1) (throw 'exit (cons (match-string 1) m))) - (and (match-beginning 2) (throw 'exit nil)) - ;; count $$ - (while (re-search-backward "\\$\\$" lim t) - (setq dd-on (not dd-on))) - (goto-char pos) - (if dd-on (cons "$$" m)))))) +;;; XOXO export +(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) -(defun org-try-cdlatex-tab () - "Check if it makes sense to execute `cdlatex-tab', and do it if yes. -It makes sense to do so if `org-cdlatex-mode' is active and if the cursor is - - inside a LaTeX fragment, or - - after the first word in a line, where an abbreviation expansion could - insert a LaTeX environment." - (when org-cdlatex-mode - (cond - ((save-excursion - (skip-chars-backward "a-zA-Z0-9*") - (skip-chars-backward " \t") - (bolp)) - (cdlatex-tab) t) - ((org-inside-LaTeX-fragment-p) - (cdlatex-tab) t) - (t nil)))) +(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))) + ;; A quickie abstraction -(defun org-cdlatex-underscore-caret (&optional arg) - "Execute `cdlatex-sub-superscript' in LaTeX fragments. -Revert to the normal definition outside of these fragments." - (interactive "P") - (if (org-inside-LaTeX-fragment-p) - (call-interactively 'cdlatex-sub-superscript) - (let (org-cdlatex-mode) - (call-interactively (key-binding (vector last-input-event)))))) + ;; Output everything as XOXO + (with-current-buffer (get-buffer buffer) + (goto-char (point-min)) ;; CD: beginning-of-buffer is not allowed. + (let* ((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)) + ;; 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 "^\\(\\*+\\) \\(.+\\)" (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))))))))) -(defun org-cdlatex-math-modify (&optional arg) - "Execute `cdlatex-math-modify' in LaTeX fragments. -Revert to the normal definition outside of these fragments." - (interactive "P") - (if (org-inside-LaTeX-fragment-p) - (call-interactively 'cdlatex-math-modify) - (let (org-cdlatex-mode) - (call-interactively (key-binding (vector last-input-event)))))) + ;; Handle level rendering + (cond + ((> level last-level) + (org-export-as-xoxo-insert-into out "\n<ol>\n")) -(defvar org-latex-fragment-image-overlays nil - "List of overlays carrying the images of latex fragments.") -(make-variable-buffer-local 'org-latex-fragment-image-overlays) + ((< 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))) -(defun org-remove-latex-fragment-image-overlays () - "Remove all overlays with LaTeX fragment images in current buffer." - (mapc 'org-delete-overlay org-latex-fragment-image-overlays) - (setq org-latex-fragment-image-overlays nil)) + ((equal level last-level) + (if hanging-li + (org-export-as-xoxo-insert-into out "</li>\n"))) + ) -(defun org-preview-latex-fragment (&optional subtree) - "Preview the LaTeX fragment at point, or all locally or globally. -If the cursor is in a LaTeX fragment, create the image and overlay -it over the source code. If there is no fragment at point, display -all fragments in the current text, from one headline to the next. With -prefix SUBTREE, display all fragments in the current subtree. With a -double prefix `C-u C-u', or when the cursor is before the first headline, -display all fragments in the buffer. -The images can be removed again with \\[org-ctrl-c-ctrl-c]." - (interactive "P") - (org-remove-latex-fragment-image-overlays) - (save-excursion - (save-restriction - (let (beg end at msg) - (cond - ((or (equal subtree '(16)) - (not (save-excursion - (re-search-backward (concat "^" outline-regexp) nil t)))) - (setq beg (point-min) end (point-max) - msg "Creating images for buffer...%s")) - ((equal subtree '(4)) - (org-back-to-heading) - (setq beg (point) end (org-end-of-subtree t) - msg "Creating images for subtree...%s")) - (t - (if (setq at (org-inside-LaTeX-fragment-p)) - (goto-char (max (point-min) (- (cdr at) 2))) - (org-back-to-heading)) - (setq beg (point) end (progn (outline-next-heading) (point)) - msg (if at "Creating image...%s" - "Creating images for entry...%s")))) - (message msg "") - (narrow-to-region beg end) - (org-format-latex - (concat "ltxpng/" (file-name-sans-extension - (file-name-nondirectory - buffer-file-name))) - default-directory 'overlays msg at) - (message msg "done. Use `C-c C-c' to remove images."))))) + (setq last-level level) -(defvar org-latex-regexps - '(("begin" "^[ \t]*\\(\\\\begin{\\([a-zA-Z0-9\\*]+\\)[^\000]+?\\\\end{\\2}\\)" 1 t) - ;; ("$" "\\([ (]\\|^\\)\\(\\(\\([$]\\)\\([^ \r\n,.$].*?\\(\n.*?\\)\\{0,5\\}[^ \r\n,.$]\\)\\4\\)\\)\\([ .,?;:'\")]\\|$\\)" 2 nil) - ;; \000 in the following regex is needed for org-inside-LaTeX-fragment-p - ("$" "\\([^$]\\)\\(\\(\\$\\([^ \r\n,;.$][^$\n\r]*?\\(\n[^$\n\r]*?\\)\\{0,2\\}[^ \r\n,.$]\\)\\$\\)\\)\\([ .,?;:'\")\000]\\|$\\)" 2 nil) - ("\\(" "\\\\([^\000]*?\\\\)" 0 nil) - ("\\[" "\\\\\\[[^\000]*?\\\\\\]" 0 t) - ("$$" "\\$\\$[^\000]*?\\$\\$" 0 t)) - "Regular expressions for matching embedded LaTeX.") + ;; 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)))) -(defun org-format-latex (prefix &optional dir overlays msg at) - "Replace LaTeX fragments with links to an image, and produce images." - (if (and overlays (fboundp 'clear-image-cache)) (clear-image-cache)) - (let* ((prefixnodir (file-name-nondirectory prefix)) - (absprefix (expand-file-name prefix dir)) - (todir (file-name-directory absprefix)) - (opt org-format-latex-options) - (matchers (plist-get opt :matchers)) - (re-list org-latex-regexps) - (cnt 0) txt link beg end re e oldfiles - m n block linkfile movefile ov) - ;; Make sure the directory exists - (or (file-directory-p todir) (make-directory todir)) - ;; Check if there are old images files with this prefix, and remove them - (setq oldfiles (directory-files - todir 'full - (concat (regexp-quote prefixnodir) "_[0-9]+\\.png$"))) - (while oldfiles (delete-file (pop oldfiles))) - ;; Check the different regular expressions - (while (setq e (pop re-list)) - (setq m (car e) re (nth 1 e) n (nth 2 e) - block (if (nth 3 e) "\n\n" "")) - (when (member m matchers) - (goto-char (point-min)) - (while (re-search-forward re nil t) - (when (or (not at) (equal (cdr at) (match-beginning n))) - (setq txt (match-string n) - beg (match-beginning n) end (match-end n) - cnt (1+ cnt) - linkfile (format "%s_%04d.png" prefix cnt) - movefile (format "%s_%04d.png" absprefix cnt) - link (concat block "[[file:" linkfile "]]" block)) - (if msg (message msg cnt)) - (goto-char beg) - (org-create-formula-image - txt movefile opt) - (if overlays - (progn - (setq ov (org-make-overlay beg end)) - (if (featurep 'xemacs) - (progn - (org-overlay-put ov 'invisible t) - (org-overlay-put - ov 'end-glyph - (make-glyph (vector 'png :file movefile)))) - (org-overlay-put - ov 'display - (list 'image :type 'png :file movefile :ascent 'center))) - (push ov org-latex-fragment-image-overlays) - (goto-char end)) - (delete-region beg end) - (insert link)))))))) + ;; 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")) -;; This function borrows from Ganesh Swami's latex2png.el -(defun org-create-formula-image (string tofile options) - (let* ((tmpdir (if (featurep 'xemacs) - (temp-directory) - temporary-file-directory)) - (texfilebase (make-temp-name - (expand-file-name "orgtex" tmpdir))) + ;; Finish the buffer off and clean it up. + (switch-to-buffer-other-window out) + (indent-region (point-min) (point-max) nil) + (save-buffer) + (goto-char (point-min)) + ))) -;(texfilebase (make-temp-file "orgtex")) -; (dummy (delete-file texfilebase)) - (texfile (concat texfilebase ".tex")) - (dvifile (concat texfilebase ".dvi")) - (pngfile (concat texfilebase ".png")) - (scale (number-to-string (* 1000 (or (plist-get options :scale) 1.0)))) - (fg (or (plist-get options :foreground) "Black")) - (bg (or (plist-get options :background) "Transparent"))) - (with-temp-file texfile - (insert "\\documentclass{article} -\\usepackage{fullpage} -\\usepackage{amssymb} -\\usepackage[usenames]{color} -\\usepackage{amsmath} -\\usepackage{latexsym} -\\usepackage[mathscr]{eucal} -\\pagestyle{empty} -\\begin{document}\n" string "\n\\end{document}\n")) - (let ((dir default-directory)) - (condition-case nil - (progn - (cd tmpdir) - (call-process "latex" nil nil nil texfile)) - (error nil)) - (cd dir)) - (if (not (file-exists-p dvifile)) - (progn (message "Failed to create dvi file from %s" texfile) nil) - (call-process "dvipng" nil nil nil - "-E" "-fg" fg "-bg" bg - "-x" scale "-y" scale "-T" "tight" - "-o" pngfile - dvifile) - (if (not (file-exists-p pngfile)) - (progn (message "Failed to create png file from %s" texfile) nil) - ;; Use the requested file name and clean up - (copy-file pngfile tofile 'replace) - (loop for e in '(".dvi" ".tex" ".aux" ".log" ".png") do - (delete-file (concat texfilebase e))) - pngfile)))) ;;;; Key bindings @@ -17598,7 +17752,7 @@ See the individual commands for more information." ["Reveal Context" org-reveal t] ["Show All" show-all t] "--" - ["Subtree to indirect buffer" 'org-tree-to-indirect-buffer t]) + ["Subtree to indirect buffer" org-tree-to-indirect-buffer t]) "--" ["New Heading" org-insert-heading t] ("Navigate Headings" @@ -17798,6 +17952,9 @@ With optional NODE, go directly to that node." ;;;; Miscellaneous stuff + +;;; Generally useful functions + (defun org-context () "Return a list of contexts of the current cursor position. If several contexts apply, all are returned. @@ -17942,7 +18099,7 @@ return nil." (setq string (replace-match (cdr e) t t string)))) string)) -;;;; Paragraph filling stuff. +;;; Paragraph filling stuff. ;; We want this to be just right, so use the full arsenal. (defun org-set-autofill-regexps () @@ -17999,49 +18156,6 @@ work correctly." (make-string (- (match-end 0) (match-beginning 0)) ?\ )) (t nil))) -;; Functions needed for Emacs/XEmacs region compatibility - -(defun org-add-hook (hook function &optional append local) - "Add-hook, compatible with both Emacsen." - (if (and local (featurep 'xemacs)) - (add-local-hook hook function append) - (add-hook hook function append local))) - -(defun org-region-active-p () - "Is `transient-mark-mode' on and the region active? -Works on both Emacs and XEmacs." - (if org-ignore-region - nil - (if (featurep 'xemacs) - (and zmacs-regions (region-active-p)) - (and transient-mark-mode mark-active)))) - -(defun org-add-to-invisibility-spec (arg) - "Add elements to `buffer-invisibility-spec'. -See documentation for `buffer-invisibility-spec' for the kind of elements -that can be added." - (cond - ((fboundp 'add-to-invisibility-spec) - (add-to-invisibility-spec arg)) - ((or (null buffer-invisibility-spec) (eq buffer-invisibility-spec t)) - (setq buffer-invisibility-spec (list arg))) - (t - (setq buffer-invisibility-spec - (cons arg buffer-invisibility-spec))))) - -(defun org-remove-from-invisibility-spec (arg) - "Remove elements from `buffer-invisibility-spec'." - (if (fboundp 'remove-from-invisibility-spec) - (remove-from-invisibility-spec arg) - (if (consp buffer-invisibility-spec) - (setq buffer-invisibility-spec - (delete arg buffer-invisibility-spec))))) - -(defun org-in-invisibility-spec-p (arg) - "Is ARG a member of `buffer-invisibility-spec'?" - (if (consp buffer-invisibility-spec) - (member arg buffer-invisibility-spec) - nil)) (defun org-image-file-name-regexp () "Return regexp matching the file names of images." Binary files differ@@ -3,7 +3,7 @@ @setfilename ../info/org @settitle Org Mode Manual -@set VERSION 4.58 +@set VERSION 4.59 @set DATE December 2006 @dircategory Emacs @@ -626,14 +626,13 @@ command (@pxref{Agenda commands}). @kindex C-c C-x b @item C-c C-x b Show the current subtree in an indirect buffer@footnote{The indirect -buffer (@pxref{Indirect Buffers,Indirect Buffers,Indirect Buffers,emacs,GNU -Emacs Manual}) will contain the entire buffer, but will -be narrowed to the current tree. Editing the indirect buffer will also -change the original buffer, but without affecting visibility in that -buffer .}, in a separate, dedicated frame. With positive numerical -prefix N, go up to level N before selecting the subtree. With negative -prefix -N, go up N levels. With @kbd{C-u} prefix, don't use the -dedicated frame, but another, new frame. +buffer (@pxref{Indirect Buffers,Indirect Buffers,Indirect +Buffers,emacs,GNU Emacs Manual}) will contain the entire buffer, but +will be narrowed to the current tree. Editing the indirect buffer will +also change the original buffer, but without affecting visibility in +that buffer.}. With numerical prefix ARG, go up to this level and then +take that tree. If ARG is negative, go up that many levels. With +@kbd{C-u} prefix, do not remove the previously used indirect buffer. @end table When Emacs first visits an Org-mode file, the global state is set to @@ -3713,11 +3712,10 @@ agenda buffers can be set with the variable @kindex b @item b -Display the entire subtree of the current item in an indirect buffer, in -a separate, dedicated frame. With positive numerical prefix N, go up to -level N before selecting the subtree. With negative prefix -N, go up N -levels. With @kbd{C-u} prefix, don't use the dedicated frame, but -another, new frame. +Display the entire subtree of the current item in an indirect buffer. +With numerical prefix ARG, go up to this level and then take that tree. +If ARG is negative, go up that many levels. With @kbd{C-u} prefix, do +not remove the previously used indirect buffer. @kindex l @item l diff --git a/orgcard.pdf b/orgcard.pdf Binary files differindex 70f4bf243..9b519f51f 100644 --- a/orgcard.pdf +++ b/orgcard.pdf diff --git a/orgcard.tex b/orgcard.tex index dffb22068..7cceca21b 100644 --- a/orgcard.tex +++ b/orgcard.tex @@ -1,5 +1,5 @@ % Reference Card for Org Mode -\def\orgversionnumber{4.58} +\def\orgversionnumber{4.59} \def\year{2006} % %**start of header @@ -285,6 +285,7 @@ are preserved on all copies. \key{rotate entire buffer between states}{S-TAB} \key{show the whole file}{C-c C-a} \key{reveal context around point}{C-c C-r} +\key{show subtree in indirect buffer, ded.\ frame}{C-c C-k} %\key{show branches}{C-c C-k} \section{Motion} @@ -572,8 +573,10 @@ after ``{\tt :}'', and dictionary words elsewhere. \key{compile TODO list for specific keyword}{C-c a T$^1$} \key{match tags in agenda files}{C-c a m$^1$} \key{match tags in TODO entries}{C-c a M$^1$} +\key{find stuck projects}{C-c a \#$^1$} \key{show timeline of current org file}{C-c a L$^1$} \key{configure custom commands}{C-c a C$^1$} +\key{configure stuck projects}{C-c a !$^1$} \key{agenda for date at cursor}{C-c C-o} \vskip 1mm @@ -593,6 +596,7 @@ To set categories, add lines like$^2$: \key{goto original location in other window}{TAB/mouse-2} %\key{... also available with}{mouse-2} \key{goto original location, delete other windows}{RET} +\key{show subtree in indirect buffer, ded.\ frame}{b} \key{toggle follow-mode}{f} {\bf Change display} @@ -633,6 +637,7 @@ To set categories, add lines like$^2$: \key{Open link in current line}{C-c C-o} +\newcolumn {\bf Calendar commands} \key{find agenda cursor date in calendar}{c} |