procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Update Org to v9.0.9

Browse source 
Please see etc/ORG-NEWS for details.
This commit is contained in:
Rasmus 2017-06-21 13:20:20 +02:00
parent 386a3da920
commit 5cecd27582
125 changed files with 55265 additions and 36875 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9837
doc/misc/org.texi
View file

File diff suppressed because it is too large Load diff

1406
etc/ORG-NEWS
View file

File diff suppressed because it is too large Load diff

20
etc/org/OrgOdtStyles.xml
View file

@ -109,33 +109,53 @@
</style:style>
<style:style style:name="Heading_20_1" style:display-name="Heading 1" style:family="paragraph" style:parent-style-name="Heading" style:next-style-name="Text_20_body" style:default-outline-level="1" style:class="text">
<style:text-properties fo:font-size="115%" fo:font-weight="bold" style:font-size-asian="115%" style:font-weight-asian="bold" style:font-size-complex="115%" style:font-weight-complex="bold"/>
</style:style>
<style:style style:name="Heading_20_1_unnumbered" style:family="paragraph" style:parent-style-name="Heading_20_1" style:list-style-name="">
</style:style>
<style:style style:name="Heading_20_2" style:display-name="Heading 2" style:family="paragraph" style:parent-style-name="Heading" style:next-style-name="Text_20_body" style:default-outline-level="2" style:class="text">
<style:text-properties fo:font-size="14pt" fo:font-style="italic" fo:font-weight="bold" style:font-size-asian="14pt" style:font-style-asian="italic" style:font-weight-asian="bold" style:font-size-complex="14pt" style:font-style-complex="italic" style:font-weight-complex="bold"/>
</style:style>
<style:style style:name="Heading_20_2_unnumbered" style:family="paragraph" style:parent-style-name="Heading_20_2" style:list-style-name="">
</style:style>
<style:style style:name="Heading_20_3" style:display-name="Heading 3" style:family="paragraph" style:parent-style-name="Heading" style:next-style-name="Text_20_body" style:default-outline-level="3" style:class="text">
<style:text-properties fo:font-size="14pt" fo:font-weight="bold" style:font-size-asian="14pt" style:font-weight-asian="bold" style:font-size-complex="14pt" style:font-weight-complex="bold"/>
</style:style>
<style:style style:name="Heading_20_3_unnumbered" style:family="paragraph" style:parent-style-name="Heading_20_3" style:list-style-name="">
</style:style>
<style:style style:name="Heading_20_4" style:display-name="Heading 4" style:family="paragraph" style:parent-style-name="Heading" style:next-style-name="Text_20_body" style:default-outline-level="4" style:class="text">
<style:text-properties fo:font-size="85%" fo:font-style="italic" fo:font-weight="bold" style:font-size-asian="85%" style:font-style-asian="italic" style:font-weight-asian="bold" style:font-size-complex="85%" style:font-style-complex="italic" style:font-weight-complex="bold"/>
</style:style>
<style:style style:name="Heading_20_4_unnumbered" style:family="paragraph" style:parent-style-name="Heading_20_4" style:list-style-name="">
</style:style>
<style:style style:name="Heading_20_5" style:display-name="Heading 5" style:family="paragraph" style:parent-style-name="Heading" style:next-style-name="Text_20_body" style:default-outline-level="5" style:class="text">
<style:text-properties fo:font-size="85%" fo:font-weight="bold" style:font-size-asian="85%" style:font-weight-asian="bold" style:font-size-complex="85%" style:font-weight-complex="bold"/>
</style:style>
<style:style style:name="Heading_20_5_unnumbered" style:family="paragraph" style:parent-style-name="Heading_20_5" style:list-style-name="">
</style:style>
<style:style style:name="Heading_20_6" style:display-name="Heading 6" style:family="paragraph" style:parent-style-name="Heading" style:next-style-name="Text_20_body" style:default-outline-level="6" style:class="text">
<style:text-properties fo:font-size="75%" fo:font-weight="bold" style:font-size-asian="75%" style:font-weight-asian="bold" style:font-size-complex="75%" style:font-weight-complex="bold"/>
</style:style>
<style:style style:name="Heading_20_6_unnumbered" style:family="paragraph" style:parent-style-name="Heading_20_6" style:list-style-name="">
</style:style>
<style:style style:name="Heading_20_7" style:display-name="Heading 7" style:family="paragraph" style:parent-style-name="Heading" style:next-style-name="Text_20_body" style:default-outline-level="7" style:class="text">
<style:text-properties fo:font-size="75%" fo:font-weight="bold" style:font-size-asian="75%" style:font-weight-asian="bold" style:font-size-complex="75%" style:font-weight-complex="bold"/>
</style:style>
<style:style style:name="Heading_20_7_unnumbered" style:family="paragraph" style:parent-style-name="Heading_20_7" style:list-style-name="">
</style:style>
<style:style style:name="Heading_20_8" style:display-name="Heading 8" style:family="paragraph" style:parent-style-name="Heading" style:next-style-name="Text_20_body" style:default-outline-level="8" style:class="text">
<style:text-properties fo:font-size="75%" fo:font-weight="bold" style:font-size-asian="75%" style:font-weight-asian="bold" style:font-size-complex="75%" style:font-weight-complex="bold"/>
</style:style>
<style:style style:name="Heading_20_8_unnumbered" style:family="paragraph" style:parent-style-name="Heading_20_8" style:list-style-name="">
</style:style>
<style:style style:name="Heading_20_9" style:display-name="Heading 9" style:family="paragraph" style:parent-style-name="Heading" style:next-style-name="Text_20_body" style:default-outline-level="9" style:class="text">
<style:text-properties fo:font-size="75%" fo:font-weight="bold" style:font-size-asian="75%" style:font-weight-asian="bold" style:font-size-complex="75%" style:font-weight-complex="bold"/>
</style:style>
<style:style style:name="Heading_20_9_unnumbered" style:family="paragraph" style:parent-style-name="Heading_20_9" style:list-style-name="">
</style:style>
<style:style style:name="Heading_20_10" style:display-name="Heading 10" style:family="paragraph" style:parent-style-name="Heading" style:next-style-name="Text_20_body" style:default-outline-level="10" style:class="text">
<style:text-properties fo:font-size="75%" fo:font-weight="bold" style:font-size-asian="75%" style:font-weight-asian="bold" style:font-size-complex="75%" style:font-weight-complex="bold"/>
</style:style>
<style:style style:name="Heading_20_10_unnumbered" style:family="paragraph" style:parent-style-name="Heading_20_10" style:list-style-name="">
</style:style>
<style:style style:name="Heading_20_1.title" style:display-name="Heading 1.title" style:family="paragraph" style:parent-style-name="Heading_20_1">
<style:paragraph-properties fo:text-align="center" style:justify-single-word="false"/>

2
etc/org/README
View file

@ -1,7 +1,7 @@
The files OrgOdtContentTemplate.xml and OrgOdtStyles.xml have the
following copyright information:
Copyright (C) 2010-2017 Free Software Foundation, Inc.
Copyright (C) 2010-2014 Free Software Foundation, Inc.
These files are part of GNU Emacs.

584
etc/org/library-of-babel.org Normal file
View file

@ -0,0 +1,584 @@
#+title: The Library of Babel
#+author: Org-mode People
#+STARTUP: hideblocks
* Introduction
The Library of Babel is an extensible collection of ready-made and
easily-shortcut-callable source-code blocks for handling common tasks.
Org-babel comes pre-populated with the source-code blocks located in
this file. It is possible to add source-code blocks from any org-mode
file to the library by calling =(org-babel-lob-ingest
"path/to/file.org")=.
This file is included in worg mainly less for viewing through the web
interface, and more for contribution through the worg git repository.
If you have code snippets that you think others may find useful please
add them to this file and [[file:~/src/worg/worg-git.org::contribute-to-worg][contribute them]] to worg.
The raw Org-mode text of this file can be downloaded at
[[repofile:contrib/babel/library-of-babel.org][library-of-babel.org]]
* Simple
A collection of simple utility functions:
#+name: echo
#+begin_src emacs-lisp :var input="echo'd"
input
#+end_src
* File I/O
** Reading and writing files
Read the contents of the file at =file=. The =:results vector= and
=:results scalar= header arguments can be used to read the contents of
file as either a table or a string.
#+name: read
#+begin_src emacs-lisp :var file="" :var format=""
(if (string= format "csv")
(with-temp-buffer
(org-table-import (expand-file-name file) nil)
(org-table-to-lisp))
(with-temp-buffer
(insert-file-contents (expand-file-name file))
(buffer-string)))
#+end_src
Write =data= to a file at =file=. If =data= is a list, then write it
as a table in traditional Org-mode table syntax.
#+name: write
#+begin_src emacs-lisp :var data="" :var file="" :var ext='()
(flet ((echo (r) (if (stringp r) r (format "%S" r))))
(with-temp-file file
(case (and (listp data)
(or ext (intern (file-name-extension file))))
('tsv (insert (orgtbl-to-tsv data '(:fmt echo))))
('csv (insert (orgtbl-to-csv data '(:fmt echo))))
(t (org-babel-insert-result data)))))
nil
#+end_src
** Remote files
*** json
Read local or remote file in [[http://www.json.org/][json]] format into emacs-lisp objects.
#+name: json
#+begin_src emacs-lisp :var file='() :var url='()
(require 'json)
(cond
(file
(with-temp-filebuffer file
(goto-char (point-min))
(json-read)))
(url
(require 'w3m)
(with-temp-buffer
(w3m-retrieve url)
(goto-char (point-min))
(json-read))))
#+end_src
*** Google docs
The following code blocks make use of the [[http://code.google.com/p/googlecl/][googlecl]] Google command line
tool. This tool provides functionality for accessing Google services
from the command line, and the following code blocks use /googlecl/
for reading from and writing to Google docs with Org-mode code blocks.
**** Read a document from Google docs
The =google= command seems to be throwing "Moved Temporarily" errors
when trying to download textual documents, but this is working fine
for spreadsheets.
#+name: gdoc-read
#+begin_src emacs-lisp :var title="example" :var format="csv"
(let* ((file (concat title "." format))
(cmd (format "google docs get --format %S --title %S" format title)))
(message cmd) (message (shell-command-to-string cmd))
(prog1 (if (string= format "csv")
(with-temp-buffer
(org-table-import (shell-quote-argument file) '(4))
(org-table-to-lisp))
(with-temp-buffer
(insert-file-contents (shell-quote-argument file))
(buffer-string)))
(delete-file file)))
#+end_src
For example, a line like the following can be used to read the
contents of a spreadsheet named =num-cells= into a table.
: #+call: gdoc-read(title="num-cells"")
A line like the following can be used to read the contents of a
document as a string.
: #+call: gdoc-read(title="loremi", :format "txt")
**** Write a document to a Google docs
Write =data= to a google document named =title=. If =data= is tabular
it will be saved to a spreadsheet, otherwise it will be saved as a
normal document.
#+name: gdoc-write
#+begin_src emacs-lisp :var title="babel-upload" :var data=fibs(n=10) :results silent
(let* ((format (if (listp data) "csv" "txt"))
(tmp-file (make-temp-file "org-babel-google-doc" nil (concat "." format)))
(cmd (format "google docs upload --title %S %S" title tmp-file)))
(with-temp-file tmp-file
(insert
(if (listp data)
(orgtbl-to-csv
data '(:fmt (lambda (el) (if (stringp el) el (format "%S" el)))))
(if (stringp data) data (format "%S" data)))))
(message cmd)
(prog1 (shell-command-to-string cmd) (delete-file tmp-file)))
#+end_src
example usage
: #+name: fibs
: #+begin_src emacs-lisp :var n=8
: (flet ((fib (m) (if (< m 2) 1 (+ (fib (- m 1)) (fib (- m 2))))))
: (mapcar (lambda (el) (list el (fib el))) (number-sequence 0 (- n 1))))
: #+end_src
:
: #+call: gdoc-write(title="fibs", data=fibs(n=10))
* Plotting code
** R
Plot column 2 (y axis) against column 1 (x axis). Columns 3 and
beyond, if present, are ignored.
#+name: R-plot
#+begin_src R :var data=R-plot-example-data
plot(data)
#+end_src
#+tblname: R-plot-example-data
| 1 | 2 |
| 2 | 4 |
| 3 | 9 |
| 4 | 16 |
| 5 | 25 |
#+call: R-plot(data=R-plot-example-data)
#+resname: R-plot(data=R-plot-example-data)
: nil
** Gnuplot
* Org reference
** Headline references
#+name: headline
#+begin_src emacs-lisp :var headline=top :var file='()
(save-excursion
(when file (get-file-buffer file))
(org-open-link-from-string (org-make-link-string headline))
(save-restriction
(org-narrow-to-subtree)
(buffer-string)))
#+end_src
#+call: headline(headline="headline references")
* Tables
** LaTeX Table Export
*** booktabs
This source block can be used to wrap a table in the latex =booktabs=
environment. The source block adds a =toprule= and =bottomrule= (so
don't use =hline= at the top or bottom of the table). The =hline=
after the header is replaced with a =midrule=.
Note that this function bypasses the Org-mode LaTeX exporter and calls
=orgtbl-to-generic= to create the output table. This means that the
entries in the table are not translated from Org-mode to LaTeX.
It takes the following arguments -- all but the first two are
optional.
| arg | description |
|-------+--------------------------------------------|
| table | a reference to the table |
| align | alignment string |
| env | optional environment, default to "tabular" |
| width | optional width specification string |
#+name: booktabs
#+begin_src emacs-lisp :var table='((:head) hline (:body)) :var align='() :var env="tabular" :var width='() :noweb yes :results latex
(flet ((to-tab (tab)
(orgtbl-to-generic
(mapcar (lambda (lis)
(if (listp lis)
(mapcar (lambda (el)
(if (stringp el)
el
(format "%S" el))) lis)
lis)) tab)
(list :lend " \\\\" :sep " & " :hline "\\hline"))))
(org-fill-template
"
\\begin{%env}%width%align
\\toprule
%table
\\bottomrule
\\end{%env}\n"
(list
(cons "env" (or env "table"))
(cons "width" (if width (format "{%s}" width) ""))
(cons "align" (if align (format "{%s}" align) ""))
(cons "table"
;; only use \midrule if it looks like there are column headers
(if (equal 'hline (second table))
(concat (to-tab (list (first table)))
"\n\\midrule\n"
(to-tab (cddr table)))
(to-tab table))))))
#+end_src
*** longtable
This block can be used to wrap a table in the latex =longtable=
environment, it takes the following arguments -- all but the first two
are optional.
| arg | description |
|-----------+-------------------------------------------------------------|
| table | a reference to the table |
| align | optional alignment string |
| width | optional width specification string |
| hline | the string to use as hline separator, defaults to "\\hline" |
| head | optional "head" string |
| firsthead | optional "firsthead" string |
| foot | optional "foot" string |
| lastfoot | optional "lastfoot" string |
#+name: longtable
#+begin_src emacs-lisp :var table='((:table)) :var align='() :var width='() :var hline="\\hline" :var firsthead='() :var head='() :var foot='() :var lastfoot='() :noweb yes :results latex
(org-fill-template
"
\\begin{longtable}%width%align
%firsthead
%head
%foot
%lastfoot
%table
\\end{longtable}\n"
(list
(cons "width" (if width (format "{%s}" width) ""))
(cons "align" (if align (format "{%s}" align) ""))
(cons "firsthead" (if firsthead (concat firsthead "\n\\endfirsthead\n") ""))
(cons "head" (if head (concat head "\n\\endhead\n") ""))
(cons "foot" (if foot (concat foot "\n\\endfoot\n") ""))
(cons "lastfoot" (if lastfoot (concat lastfoot "\n\\endlastfoot\n") ""))
(cons "table" (orgtbl-to-generic
(mapcar (lambda (lis)
(if (listp lis)
(mapcar (lambda (el)
(if (stringp el)
el
(format "%S" el))) lis)
lis)) table)
(list :lend " \\\\" :sep " & " :hline hline)))))
#+end_src
*** booktabs-notes
This source block builds on [[booktabs]]. It accepts two additional
arguments, both of which are optional.
#+tblname: arguments
| arg | description |
|--------+------------------------------------------------------|
| notes | an org-mode table with footnotes |
| lspace | if non-nil, insert =addlinespace= after =bottomrule= |
An example footnote to the =arguments= table specifies the column
span. Note the use of LaTeX, rather than Org-mode, markup.
#+tblname: arguments-notes
| \multicolumn{2}{l}{This is a footnote to the \emph{arguments} table.} |
#+name: booktabs-notes
#+begin_src emacs-lisp :var table='((:head) hline (:body)) :var notes='() :var align='() :var env="tabular" :var width='() :var lspace='() :noweb yes :results latex
(flet ((to-tab (tab)
(orgtbl-to-generic
(mapcar (lambda (lis)
(if (listp lis)
(mapcar (lambda (el)
(if (stringp el)
el
(format "%S" el))) lis)
lis)) tab)
(list :lend " \\\\" :sep " & " :hline "\\hline"))))
(org-fill-template
"
\\begin{%env}%width%align
\\toprule
%table
\\bottomrule%spacer
%notes
\\end{%env}\n"
(list
(cons "env" (or env "table"))
(cons "width" (if width (format "{%s}" width) ""))
(cons "align" (if align (format "{%s}" align) ""))
(cons "spacer" (if lspace "\\addlinespace" ""))
(cons "table"
;; only use \midrule if it looks like there are column headers
(if (equal 'hline (second table))
(concat (to-tab (list (first table)))
"\n\\midrule\n"
(to-tab (cddr table)))
(to-tab table)))
(cons "notes" (if notes (to-tab notes) ""))
)))
#+end_src
** Elegant lisp for transposing a matrix
#+tblname: transpose-example
| 1 | 2 | 3 |
| 4 | 5 | 6 |
#+name: transpose
#+begin_src emacs-lisp :var table=transpose-example
(apply #'mapcar* #'list table)
#+end_src
#+resname:
| 1 | 4 |
| 2 | 5 |
| 3 | 6 |
** Convert every element of a table to a string
#+tblname: hetero-table
| 1 | 2 | 3 |
| a | b | c |
#+name: all-to-string
#+begin_src emacs-lisp :var tbl='()
(defun all-to-string (tbl)
(if (listp tbl)
(mapcar #'all-to-string tbl)
(if (stringp tbl)
tbl
(format "%s" tbl))))
(all-to-string tbl)
#+end_src
#+begin_src emacs-lisp :var tbl=hetero-table
(mapcar (lambda (row) (mapcar (lambda (cell) (stringp cell)) row)) tbl)
#+end_src
#+name:
| nil | nil | nil |
| t | t | t |
#+begin_src emacs-lisp :var tbl=all-to-string(hetero-table)
(mapcar (lambda (row) (mapcar (lambda (cell) (stringp cell)) row)) tbl)
#+end_src
#+name:
| t | t | t |
| t | t | t |
* Misc
** File-specific Version Control logging
:PROPERTIES:
:AUTHOR: Luke Crook
:END:
This function will attempt to retrieve the entire commit log for the
file associated with the current buffer and insert this log into the
export. The function uses the Emacs VC commands to interface to the
local version control system, but has only been tested to work with
Git. 'limit' is currently unsupported.
#+name: vc-log
#+headers: :var limit=-1
#+headers: :var buf=(buffer-name (current-buffer))
#+begin_src emacs-lisp
;; Most of this code is copied from vc.el vc-print-log
(require 'vc)
(when (vc-find-backend-function
(vc-backend (buffer-file-name (get-buffer buf))) 'print-log)
(let ((limit -1)
(vc-fileset nil)
(backend nil)
(files nil))
(with-current-buffer (get-buffer buf)
(setq vc-fileset (vc-deduce-fileset t)) ; FIXME: Why t? --Stef
(setq backend (car vc-fileset))
(setq files (cadr vc-fileset)))
(with-temp-buffer
(let ((status (vc-call-backend
backend 'print-log files (current-buffer))))
(when (and (processp status) ; Make sure status is a process
(= 0 (process-exit-status status))) ; which has not terminated
(while (not (eq 'exit (process-status status)))
(sit-for 1 t)))
(buffer-string)))))
#+end_src
** Trivial python code blocks
#+name: python-identity
#+begin_src python :var a=1
a
#+end_src
#+name: python-add
#+begin_src python :var a=1 :var b=2
a + b
#+end_src
** Arithmetic
#+name: lob-add
#+begin_src emacs-lisp :var a=0 :var b=0
(+ a b)
#+end_src
#+name: lob-minus
#+begin_src emacs-lisp :var a=0 :var b=0
(- a b)
#+end_src
#+name: lob-times
#+begin_src emacs-lisp :var a=0 :var b=0
(* a b)
#+end_src
#+name: lob-div
#+begin_src emacs-lisp :var a=0 :var b=0
(/ a b)
#+end_src
* GANTT Charts
The =elispgantt= source block was sent to the mailing list by Eric
Fraga. It was modified slightly by Tom Dye.
#+name: elispgantt
#+begin_src emacs-lisp :var table=gantttest
(let ((dates "")
(entries (nthcdr 2 table))
(milestones "")
(nmilestones 0)
(ntasks 0)
(projecttime 0)
(tasks "")
(xlength 1))
(message "Initial: %s\n" table)
(message "Entries: %s\n" entries)
(while entries
(let ((entry (first entries)))
(if (listp entry)
(let ((id (first entry))
(type (nth 1 entry))
(label (nth 2 entry))
(task (nth 3 entry))
(dependencies (nth 4 entry))
(start (nth 5 entry))
(duration (nth 6 entry))
(end (nth 7 entry))
(alignment (nth 8 entry)))
(if (> start projecttime) (setq projecttime start))
(if (string= type "task")
(let ((end (+ start duration))
(textposition (+ start (/ duration 2)))
(flush ""))
(if (string= alignment "left")
(progn
(setq textposition start)
(setq flush "[left]"))
(if (string= alignment "right")
(progn
(setq textposition end)
(setq flush "[right]"))))
(setq tasks
(format "%s \\gantttask{%s}{%s}{%d}{%d}{%d}{%s}\n"
tasks label task start end textposition flush))
(setq ntasks (+ 1 ntasks))
(if (> end projecttime)
(setq projecttime end)))
(if (string= type "milestone")
(progn
(setq milestones
(format
"%s \\ganttmilestone{$\\begin{array}{c}\\mbox{%s}\\\\ \\mbox{%s}\\end{array}$}{%d}\n"
milestones label task start))
(setq nmilestones (+ 1 nmilestones)))
(if (string= type "date")
(setq dates (format "%s \\ganttdateline{%s}{%d}\n"
dates label start))
(message "Ignoring entry with type %s\n" type)))))
(message "Ignoring non-list entry %s\n" entry)) ; end if list entry
(setq entries (cdr entries)))) ; end while entries left
(format "\\pgfdeclarelayer{background}
\\pgfdeclarelayer{foreground}
\\pgfsetlayers{background,foreground}
\\renewcommand{\\ganttprojecttime}{%d}
\\renewcommand{\\ganttntasks}{%d}
\\noindent
\\begin{tikzpicture}[y=-0.75cm,x=0.75\\textwidth]
\\begin{pgfonlayer}{background}
\\draw[very thin, red!10!white] (0,1+\\ganttntasks) grid [ystep=0.75cm,xstep=1/\\ganttprojecttime] (1,0);
\\draw[\\ganttdatelinecolour] (0,0) -- (1,0);
\\draw[\\ganttdatelinecolour] (0,1+\\ganttntasks) -- (1,1+\\ganttntasks);
\\end{pgfonlayer}
%s
%s
%s
\\end{tikzpicture}" projecttime ntasks tasks milestones dates))
#+end_src
* Available languages
:PROPERTIES:
:AUTHOR: Bastien
:END:
** From Org's core
| Language | Identifier | Language | Identifier |
|------------+------------+----------------+------------|
| Asymptote | asymptote | Awk | awk |
| Emacs Calc | calc | C | C |
| C++ | C++ | Clojure | clojure |
| CSS | css | ditaa | ditaa |
| Graphviz | dot | Emacs Lisp | emacs-lisp |
| gnuplot | gnuplot | Haskell | haskell |
| Javascript | js | LaTeX | latex |
| Ledger | ledger | Lisp | lisp |
| Lilypond | lilypond | MATLAB | matlab |
| Mscgen | mscgen | Objective Caml | ocaml |
| Octave | octave | Org-mode | org |
| | | Perl | perl |
| Plantuml | plantuml | Python | python |
| R | R | Ruby | ruby |
| Sass | sass | Scheme | scheme |
| GNU Screen | screen | shell | sh |
| SQL | sql | SQLite | sqlite |
** From Org's contrib/babel/langs
- ob-oz.el, by Torsten Anders and Eric Schulte
- ob-fomus.el, by Torsten Anders

27
etc/refcards/orgcard.tex
View file

@ -1,7 +1,7 @@
% Reference Card for Org Mode
\def\orgversionnumber{8.2}
\def\versionyear{2014} % latest update
\input emacsver.tex
\def\orgversionnumber{9.0.9}
\def\versionyear{2017} % latest update
\def\year{2017} % latest copyright year
%**start of header
\newcount\columnsperpage
@ -80,9 +80,6 @@
\centerline{Released under the terms of the GNU General Public License}
\centerline{version 3 or later.}
\centerline{For more Emacs documentation, and the \TeX{} source for this card, see}
\centerline{the Emacs distribution, or {\tt http://www.gnu.org/software/emacs}}
\endgroup}
% make \bye not \outer so that the \def\bye in the \else clause below
@ -312,10 +309,11 @@ \section{Structure Editing}
\key{turn item/line into headline}{C-c *}
\key{promote/demote heading}{M-LEFT/RIGHT}
\metax{promote/demote current subtree}{M-S-LEFT/RIGHT}
\metax{move subtree/list item up/down}{M-S-UP/DOWN}
\metax{move subtree/list item up/down}{M-UP/DOWN}
\metax{move the line at point up/down}{M-S-UP/DOWN}
\metax{sort subtree/region/plain-list}{C-c \^{}}
\metax{clone a subtree}{C-c C-x c}
\metax{copy visible text}{C-c C-x v}
\metax{copy visible parts of the region}{C-c C-x v}
\metax{kill/copy subtree}{C-c C-x C-w/M-w}
\metax{yank subtree}{C-c C-x C-y or C-y}
\metax{narrow buffer to subtree / widen}{C-x n s/w}
@ -333,7 +331,6 @@ \section{Filtering and Sparse Trees}
\key{construct a sparse tree by various criteria}{C-c /}
\key{view TODO's in sparse tree}{C-c / t/T}
\key{global TODO list in agenda mode}{C-c a t \noteone}
\key{time sorted view of current org file}{C-c a L}
\section{Tables}
@ -375,7 +372,6 @@ \section{Tables}
\metax{cut/copy/paste rectangular region}{C-c C-x C-w/M-w/C-y}
%\key{copy rectangular region}{C-c C-x M-w}
%\key{paste rectangular region}{C-c C-x C-y}
\key{fill paragraph across selected cells}{C-c C-q}
{\bf Miscellaneous}
@ -574,7 +570,6 @@ \section{Agenda Views}
\key{match tags, TODO kwds, properties}{C-c a m \noteone}
\key{match only in TODO entries}{C-c a M \noteone}
\key{find stuck projects}{C-c a \# \noteone}
\key{show timeline of current org file}{C-c a L \noteone}
\key{configure custom commands}{C-c a C \noteone}
%\key{configure stuck projects}{C-c a ! \noteone}
\key{agenda for date at cursor}{C-c C-o}
@ -661,8 +656,11 @@ \section{Exporting and Publishing}
\key{export/publish dispatcher}{C-c C-e}
\key{export visible part only}{C-c C-e v}
\key{insert template of export options}{C-c C-e t}
\key{toggle asynchronous export}{C-c C-e C-a}
\key{toggle body/visible only export}{C-c C-e C-b/v}
\key{toggle subtree export}{C-c C-e C-s}
\key{insert template of export options}{C-c C-e \#}
\key{toggle fixed width for entry or region}{C-c :}
\key{toggle pretty display of scripts, entities}{C-c C-x {\tt\char`\\}}
@ -690,6 +688,5 @@ \section{Notes}
\bye
% Local variables:
% compile-command: "tex refcard"
% compile-command: "pdftex orgcard"
% End:

88
etc/schema/od-manifest-schema-v1.2-os.rnc Normal file
View file

@ -0,0 +1,88 @@
# Open Document Format for Office Applications (OpenDocument) Version 1.2
# OASIS Standard, 29 September 2011
# Manifest Relax-NG Schema
# Source: http://docs.oasis-open.org/office/v1.2/os/
# Copyright (c) OASIS Open 2002-2011, 2013. All Rights Reserved.
#
# All capitalized terms in the following text have the meanings assigned to them
# in the OASIS Intellectual Property Rights Policy (the "OASIS IPR Policy"). The
# full Policy may be found at the OASIS website.
#
# This document and translations of it may be copied and furnished to others, and
# derivative works that comment on or otherwise explain it or assist in its
# implementation may be prepared, copied, published, and distributed, in whole or
# in part, without restriction of any kind, provided that the above copyright
# notice and this section are included on all such copies and derivative works.
# However, this document itself may not be modified in any way, including by
# removing the copyright notice or references to OASIS, except as needed for the
# purpose of developing any document or deliverable produced by an OASIS
# Technical Committee (in which case the rules applicable to copyrights, as set
# forth in the OASIS IPR Policy, must be followed) or as required to translate it
# into languages other than English.
#
# The limited permissions granted above are perpetual and will not be revoked by
# OASIS or its successors or assigns.
#
# This document and the information contained herein is provided on an "AS IS"
# basis and OASIS DISCLAIMS ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING BUT NOT
# LIMITED TO ANY WARRANTY THAT THE USE OF THE INFORMATION HEREIN WILL NOT
# INFRINGE ANY OWNERSHIP RIGHTS OR ANY IMPLIED WARRANTIES OF MERCHANTABILITY OR
# FITNESS FOR A PARTICULAR PURPOSE.
namespace manifest =
"urn:oasis:names:tc:opendocument:xmlns:manifest:1.0"
start = manifest
manifest = element manifest:manifest { manifest-attlist, file-entry+ }
manifest-attlist = attribute manifest:version { "1.2" }
file-entry =
element manifest:file-entry { file-entry-attlist, encryption-data? }
file-entry-attlist =
attribute manifest:full-path { \string }
& attribute manifest:size { nonNegativeInteger }?
& attribute manifest:media-type { \string }
& attribute manifest:preferred-view-mode {
"edit" | "presentation-slide-show" | "read-only" | namespacedToken
}?
& attribute manifest:version { \string }?
encryption-data =
element manifest:encryption-data {
encryption-data-attlist,
algorithm,
start-key-generation?,
key-derivation
}
encryption-data-attlist =
attribute manifest:checksum-type { "SHA1/1K" | anyURI }
& attribute manifest:checksum { base64Binary }
algorithm =
element manifest:algorithm { algorithm-attlist, anyElements }
algorithm-attlist =
attribute manifest:algorithm-name { "Blowfish CFB" | anyURI }
& attribute manifest:initialisation-vector { base64Binary }
anyAttListOrElements =
attribute * { text }*,
anyElements
anyElements =
element * {
mixed { anyAttListOrElements }
}*
key-derivation =
element manifest:key-derivation { key-derivation-attlist, empty }
key-derivation-attlist =
attribute manifest:key-derivation-name { "PBKDF2" | anyURI }
& attribute manifest:salt { base64Binary }
& attribute manifest:iteration-count { nonNegativeInteger }
& attribute manifest:key-size { nonNegativeInteger }?
start-key-generation =
element manifest:start-key-generation {
start-key-generation-attlist, empty
}
start-key-generation-attlist =
attribute manifest:start-key-generation-name { "SHA1" | anyURI }
& attribute manifest:key-size { nonNegativeInteger }?
base64Binary = xsd:base64Binary
namespacedToken = xsd:QName { pattern = "[^:]+:[^:]+" }
nonNegativeInteger = xsd:nonNegativeInteger
\string = xsd:string
anyURI = xsd:anyURI

6280
etc/schema/od-schema-v1.2-os.rnc Normal file
View file

File diff suppressed because it is too large Load diff

421
lisp/org/ob-C.el
View file

@ -1,8 +1,9 @@
;;; ob-C.el --- org-babel functions for C and similar languages
;;; ob-C.el --- Babel Functions for C and Similar Languages -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
;; Author: Eric Schulte
;; Thierry Banel
;; Keywords: literate programming, reproducible research
;; Homepage: http://orgmode.org
@ -23,37 +24,57 @@
;;; Commentary:
;; Org-Babel support for evaluating C code.
;; Org-Babel support for evaluating C, C++, D code.
;;
;; very limited implementation:
;; - currently only support :results output
;; - not much in the way of error feedback
;;; Code:
(eval-when-compile
(require 'cl))
(require 'ob)
(require 'cc-mode)
(require 'ob)
(declare-function org-entry-get "org"
(pom property &optional inherit literal-nil))
(declare-function org-entry-get "org" (pom property &optional inherit literal-nil))
(declare-function org-remove-indentation "org" (code &optional n))
(declare-function org-trim "org" (s &optional keep-lead))
(defvar org-babel-tangle-lang-exts)
(add-to-list 'org-babel-tangle-lang-exts '("C++" . "cpp"))
(add-to-list 'org-babel-tangle-lang-exts '("D" . "d"))
(defvar org-babel-default-header-args:C '())
(defvar org-babel-C-compiler "gcc"
"Command used to compile a C source code file into an
executable.")
(defcustom org-babel-C-compiler "gcc"
"Command used to compile a C source code file into an executable.
May be either a command in the path, like gcc
or an absolute path name, like /usr/local/bin/gcc
parameter may be used, like gcc -v"
:group 'org-babel
:version "24.3"
:type 'string)
(defvar org-babel-C++-compiler "g++"
"Command used to compile a C++ source code file into an
executable.")
(defcustom org-babel-C++-compiler "g++"
"Command used to compile a C++ source code file into an executable.
May be either a command in the path, like g++
or an absolute path name, like /usr/local/bin/g++
parameter may be used, like g++ -v"
:group 'org-babel
:version "24.3"
:type 'string)
(defcustom org-babel-D-compiler "rdmd"
"Command used to compile and execute a D source code file.
May be either a command in the path, like rdmd
or an absolute path name, like /usr/local/bin/rdmd
parameter may be used, like rdmd --chatty"
:group 'org-babel
:version "24.3"
:type 'string)
(defvar org-babel-c-variant nil
"Internal variable used to hold which type of C (e.g. C or C++)
"Internal variable used to hold which type of C (e.g. C or C++ or D)
is currently being evaluated.")
(defun org-babel-execute:cpp (body params)
@ -61,88 +82,189 @@ is currently being evaluated.")
This function calls `org-babel-execute:C++'."
(org-babel-execute:C++ body params))
(defun org-babel-expand-body:cpp (body params)
"Expand a block of C++ code with org-babel according to its
header arguments."
(org-babel-expand-body:C++ body params))
(defun org-babel-execute:C++ (body params)
"Execute a block of C++ code with org-babel.
This function is called by `org-babel-execute-src-block'."
(let ((org-babel-c-variant 'cpp)) (org-babel-C-execute body params)))
(defun org-babel-expand-body:C++ (body params)
"Expand a block of C++ code with org-babel according to it's
header arguments (calls `org-babel-C-expand')."
(let ((org-babel-c-variant 'cpp)) (org-babel-C-expand body params)))
"Expand a block of C++ code with org-babel according to its
header arguments."
(let ((org-babel-c-variant 'cpp)) (org-babel-C-expand-C++ body params)))
(defun org-babel-execute:D (body params)
"Execute a block of D code with org-babel.
This function is called by `org-babel-execute-src-block'."
(let ((org-babel-c-variant 'd)) (org-babel-C-execute body params)))
(defun org-babel-expand-body:D (body params)
"Expand a block of D code with org-babel according to its
header arguments."
(let ((org-babel-c-variant 'd)) (org-babel-C-expand-D body params)))
(defun org-babel-execute:C (body params)
"Execute a block of C code with org-babel.
This function is called by `org-babel-execute-src-block'."
(let ((org-babel-c-variant 'c)) (org-babel-C-execute body params)))
(defun org-babel-expand-body:c (body params)
"Expand a block of C code with org-babel according to it's
header arguments (calls `org-babel-C-expand')."
(let ((org-babel-c-variant 'c)) (org-babel-C-expand body params)))
(defun org-babel-expand-body:C (body params)
"Expand a block of C code with org-babel according to its
header arguments."
(let ((org-babel-c-variant 'c)) (org-babel-C-expand-C body params)))
(defun org-babel-C-execute (body params)
"This function should only be called by `org-babel-execute:C'
or `org-babel-execute:C++'."
or `org-babel-execute:C++' or `org-babel-execute:D'."
(let* ((tmp-src-file (org-babel-temp-file
"C-src-"
(cond
((equal org-babel-c-variant 'c) ".c")
((equal org-babel-c-variant 'cpp) ".cpp"))))
(tmp-bin-file (org-babel-temp-file "C-bin-" org-babel-exeext))
(cmdline (cdr (assoc :cmdline params)))
(flags (cdr (assoc :flags params)))
(full-body (org-babel-C-expand body params))
(compile
(progn
(with-temp-file tmp-src-file (insert full-body))
(org-babel-eval
(format "%s -o %s %s %s"
(cond
((equal org-babel-c-variant 'c) org-babel-C-compiler)
((equal org-babel-c-variant 'cpp) org-babel-C++-compiler))
(org-babel-process-file-name tmp-bin-file)
(mapconcat 'identity
(if (listp flags) flags (list flags)) " ")
(org-babel-process-file-name tmp-src-file)) ""))))
(pcase org-babel-c-variant
(`c ".c") (`cpp ".cpp") (`d ".d"))))
(tmp-bin-file ;not used for D
(org-babel-process-file-name
(org-babel-temp-file "C-bin-" org-babel-exeext)))
(cmdline (cdr (assq :cmdline params)))
(cmdline (if cmdline (concat " " cmdline) ""))
(flags (cdr (assq :flags params)))
(flags (mapconcat 'identity
(if (listp flags) flags (list flags)) " "))
(libs (org-babel-read
(or (cdr (assq :libs params))
(org-entry-get nil "libs" t))
nil))
(libs (mapconcat #'identity
(if (listp libs) libs (list libs))
" "))
(full-body
(pcase org-babel-c-variant
(`c (org-babel-C-expand-C body params))
(`cpp (org-babel-C-expand-C++ body params))
(`d (org-babel-C-expand-D body params)))))
(with-temp-file tmp-src-file (insert full-body))
(pcase org-babel-c-variant
((or `c `cpp)
(org-babel-eval
(format "%s -o %s %s %s %s"
(pcase org-babel-c-variant
(`c org-babel-C-compiler)
(`cpp org-babel-C++-compiler))
tmp-bin-file
flags
(org-babel-process-file-name tmp-src-file)
libs)
""))
(`d nil)) ;; no separate compilation for D
(let ((results
(org-babel-trim
(org-babel-eval
(concat tmp-bin-file (if cmdline (concat " " cmdline) "")) ""))))
(org-babel-reassemble-table
(org-babel-result-cond (cdr (assoc :result-params params))
(org-babel-read results)
(let ((tmp-file (org-babel-temp-file "c-")))
(with-temp-file tmp-file (insert results))
(org-babel-import-elisp-from-file tmp-file)))
(org-babel-pick-name
(cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
(org-babel-pick-name
(cdr (assoc :rowname-names params)) (cdr (assoc :rownames params)))))
))
(org-babel-eval
(pcase org-babel-c-variant
((or `c `cpp)
(concat tmp-bin-file cmdline))
(`d
(format "%s %s %s %s"
org-babel-D-compiler
flags
(org-babel-process-file-name tmp-src-file)
cmdline)))
"")))
(when results
(setq results (org-trim (org-remove-indentation results)))
(org-babel-reassemble-table
(org-babel-result-cond (cdr (assq :result-params params))
(org-babel-read results t)
(let ((tmp-file (org-babel-temp-file "c-")))
(with-temp-file tmp-file (insert results))
(org-babel-import-elisp-from-file tmp-file)))
(org-babel-pick-name
(cdr (assq :colname-names params)) (cdr (assq :colnames params)))
(org-babel-pick-name
(cdr (assq :rowname-names params)) (cdr (assq :rownames params)))))
)))
(defun org-babel-C-expand (body params)
(defun org-babel-C-expand-C++ (body params)
"Expand a block of C or C++ code with org-babel according to
it's header arguments."
(let ((vars (mapcar #'cdr (org-babel-get-header params :var)))
(main-p (not (string= (cdr (assoc :main params)) "no")))
(includes (or (cdr (assoc :includes params))
(org-babel-read (org-entry-get nil "includes" t))))
(defines (org-babel-read
(or (cdr (assoc :defines params))
(org-babel-read (org-entry-get nil "defines" t))))))
its header arguments."
(org-babel-C-expand-C body params))
(defun org-babel-C-expand-C (body params)
"Expand a block of C or C++ code with org-babel according to
its header arguments."
(let ((vars (org-babel--get-vars params))
(colnames (cdr (assq :colname-names params)))
(main-p (not (string= (cdr (assq :main params)) "no")))
(includes (org-babel-read
(or (cdr (assq :includes params))
(org-entry-get nil "includes" t))
nil))
(defines (org-babel-read
(or (cdr (assq :defines params))
(org-entry-get nil "defines" t))
nil)))
(when (stringp includes)
(setq includes (split-string includes)))
(when (stringp defines)
(let ((y nil)
(result (list t)))
(dolist (x (split-string defines))
(if (null y)
(setq y x)
(nconc result (list (concat y " " x)))
(setq y nil)))
(setq defines (cdr result))))
(mapconcat 'identity
(list
;; includes
(mapconcat
(lambda (inc) (format "#include %s" inc))
(if (listp includes) includes (list includes)) "\n")
includes "\n")
;; defines
(mapconcat
(lambda (inc) (format "#define %s" inc))
(if (listp defines) defines (list defines)) "\n")
;; variables
(mapconcat 'org-babel-C-var-to-C vars "\n")
;; table sizes
(mapconcat 'org-babel-C-table-sizes-to-C vars "\n")
;; tables headers utility
(when colnames
(org-babel-C-utility-header-to-C))
;; tables headers
(mapconcat 'org-babel-C-header-to-C colnames "\n")
;; body
(if main-p
(org-babel-C-ensure-main-wrap body)
body) "\n") "\n")))
(defun org-babel-C-expand-D (body params)
"Expand a block of D code with org-babel according to
its header arguments."
(let ((vars (org-babel--get-vars params))
(colnames (cdr (assq :colname-names params)))
(main-p (not (string= (cdr (assq :main params)) "no")))
(imports (or (cdr (assq :imports params))
(org-babel-read (org-entry-get nil "imports" t)))))
(when (stringp imports)
(setq imports (split-string imports)))
(setq imports (append imports '("std.stdio" "std.conv")))
(mapconcat 'identity
(list
"module mmm;"
;; imports
(mapconcat
(lambda (inc) (format "import %s;" inc))
imports "\n")
;; variables
(mapconcat 'org-babel-C-var-to-C vars "\n")
;; table sizes
(mapconcat 'org-babel-C-table-sizes-to-C vars "\n")
;; tables headers utility
(when colnames
(org-babel-C-utility-header-to-C))
;; tables headers
(mapconcat 'org-babel-C-header-to-C colnames "\n")
;; body
(if main-p
(org-babel-C-ensure-main-wrap body)
@ -154,12 +276,12 @@ it's header arguments."
body
(format "int main() {\n%s\nreturn 0;\n}\n" body)))
(defun org-babel-prep-session:C (session params)
(defun org-babel-prep-session:C (_session _params)
"This function does nothing as C is a compiled language with no
support for sessions"
(error "C is a compiled language -- no support for sessions"))
(defun org-babel-load-session:C (session body params)
(defun org-babel-load-session:C (_session _body _params)
"This function does nothing as C is a compiled language with no
support for sessions"
(error "C is a compiled language -- no support for sessions"))
@ -177,58 +299,79 @@ support for sessions"
"Determine the type of VAL.
Return a list (TYPE-NAME FORMAT). TYPE-NAME should be the name of the type.
FORMAT can be either a format string or a function which is called with VAL."
(cond
((integerp val) '("int" "%d"))
((floatp val) '("double" "%f"))
((or (listp val) (vectorp val))
(lexical-let ((type (org-babel-C-val-to-C-list-type val)))
(list (car type)
(lambda (val)
(cons
(format "[%d]%s"
(length val)
(car (org-babel-C-format-val type (elt val 0))))
(concat "{ "
(mapconcat (lambda (v)
(cdr (org-babel-C-format-val type v)))
val
", ")
" }"))))))
(t ;; treat unknown types as string
'("char" (lambda (val)
(let ((s (format "%s" val))) ;; convert to string for unknown types
(cons (format "[%d]" (1+ (length s)))
(concat "\"" s "\""))))))))
(let* ((basetype (org-babel-C-val-to-base-type val))
(type
(pcase basetype
(`integerp '("int" "%d"))
(`floatp '("double" "%f"))
(`stringp
(list
(if (eq org-babel-c-variant 'd) "string" "const char*")
"\"%s\""))
(_ (error "unknown type %S" basetype)))))
(cond
((integerp val) type) ;; an integer declared in the #+begin_src line
((floatp val) type) ;; a numeric declared in the #+begin_src line
((and (listp val) (listp (car val))) ;; a table
`(,(car type)
(lambda (val)
(cons
(format "[%d][%d]" (length val) (length (car val)))
(concat
(if (eq org-babel-c-variant 'd) "[\n" "{\n")
(mapconcat
(lambda (v)
(concat
(if (eq org-babel-c-variant 'd) " [" " {")
(mapconcat (lambda (w) (format ,(cadr type) w)) v ",")
(if (eq org-babel-c-variant 'd) "]" "}")))
val
",\n")
(if (eq org-babel-c-variant 'd) "\n]" "\n}"))))))
((or (listp val) (vectorp val)) ;; a list declared in the #+begin_src line
`(,(car type)
(lambda (val)
(cons
(format "[%d]" (length val))
(concat
(if (eq org-babel-c-variant 'd) "[" "{")
(mapconcat (lambda (v) (format ,(cadr type) v)) val ",")
(if (eq org-babel-c-variant 'd) "]" "}"))))))
(t ;; treat unknown types as string
type))))
(defun org-babel-C-val-to-C-list-type (val)
"Determine the C array type of a VAL."
(let (type)
(mapc
#'(lambda (i)
(let* ((tmp-type (org-babel-C-val-to-C-type i))
(type-name (car type))
(tmp-type-name (car tmp-type)))
(when (and type (not (string= type-name tmp-type-name)))
(if (and (member type-name '("int" "double" "int32_t"))
(member tmp-type-name '("int" "double" "int32_t")))
(setq tmp-type '("double" "" "%f"))
(error "Only homogeneous lists are supported by C. You can not mix %s and %s"
type-name
tmp-type-name)))
(setq type tmp-type)))
val)
type))
(defun org-babel-C-val-to-base-type (val)
"Determine the base type of VAL which may be
`integerp' if all base values are integers
`floatp' if all base values are either floating points or integers
`stringp' otherwise."
(cond
((integerp val) 'integerp)
((floatp val) 'floatp)
((or (listp val) (vectorp val))
(let ((type nil))
(mapc (lambda (v)
(pcase (org-babel-C-val-to-base-type v)
(`stringp (setq type 'stringp))
(`floatp
(if (or (not type) (eq type 'integerp))
(setq type 'floatp)))
(`integerp
(unless type (setq type 'integerp)))))
val)
type))
(t 'stringp)))
(defun org-babel-C-var-to-C (pair)
"Convert an elisp val into a string of C code specifying a var
of the same value."
;; TODO list support
(let ((var (car pair))
(val (cdr pair)))
(val (cdr pair)))
(when (symbolp val)
(setq val (symbol-name val))
(when (= (length val) 1)
(setq val (string-to-char val))))
(setq val (string-to-char val))))
(let* ((type-data (org-babel-C-val-to-C-type val))
(type (car type-data))
(formated (org-babel-C-format-val type-data val))
@ -240,6 +383,66 @@ of the same value."
suffix
data))))
(defun org-babel-C-table-sizes-to-C (pair)
"Create constants of table dimensions, if PAIR is a table."
(when (listp (cdr pair))
(cond
((listp (cadr pair)) ;; a table
(concat
(format "const int %s_rows = %d;" (car pair) (length (cdr pair)))
"\n"
(format "const int %s_cols = %d;" (car pair) (length (cadr pair)))))
(t ;; a list declared in the #+begin_src line
(format "const int %s_cols = %d;" (car pair) (length (cdr pair)))))))
(defun org-babel-C-utility-header-to-C ()
"Generate a utility function to convert a column name
into a column number."
(pcase org-babel-c-variant
((or `c `cpp)
"int get_column_num (int nbcols, const char** header, const char* column)
{
int c;
for (c=0; c<nbcols; c++)
if (strcmp(header[c],column)==0)
return c;
return -1;
}
")
(`d
"int get_column_num (string[] header, string column)
{
foreach (c, h; header)
if (h==column)
return to!int(c);
return -1;
}
")))
(defun org-babel-C-header-to-C (head)
"Convert an elisp list of header table into a C or D vector
specifying a variable with the name of the table."
(let ((table (car head))
(headers (cdr head)))
(concat
(format
(pcase org-babel-c-variant
((or `c `cpp) "const char* %s_header[%d] = {%s};")
(`d "string %s_header[%d] = [%s];"))
table
(length headers)
(mapconcat (lambda (h) (format "%S" h)) headers ","))
"\n"
(pcase org-babel-c-variant
((or `c `cpp)
(format
"const char* %s_h (int row, const char* col) { return %s[row][get_column_num(%d,%s_header,col)]; }"
table table (length headers) table))
(`d
(format
"string %s_h (size_t row, string col) { return %s[row][get_column_num(%s_header,col)]; }"
table table table))))))
(provide 'ob-C)
;;; ob-C.el ends here

186
lisp/org/ob-J.el Normal file
View file

@ -0,0 +1,186 @@
;;; ob-J.el --- Babel Functions for J -*- lexical-binding: t; -*-
;; Copyright (C) 2011-2017 Free Software Foundation, Inc.
;; Author: Oleh Krehel
;; Keywords: literate programming, reproducible research
;; Homepage: http://orgmode.org
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Org-Babel support for evaluating J code.
;;
;; Session interaction depends on `j-console' from package `j-mode'
;; (available in MELPA).
;;; Code:
(require 'ob)
(declare-function org-trim "org" (s &optional keep-lead))
(declare-function j-console-ensure-session "ext:j-console" ())
(defcustom org-babel-J-command "jconsole"
"Command to call J."
:group 'org-babel
:version "26.1"
:package-version '(Org . "9.0")
:type 'string)
(defun org-babel-expand-body:J (body _params &optional _processed-params)
"Expand BODY according to PARAMS, return the expanded body.
PROCESSED-PARAMS isn't used yet."
(org-babel-J-interleave-echos-except-functions body))
(defun org-babel-J-interleave-echos (body)
"Interleave echo',' between each source line of BODY."
(mapconcat #'identity (split-string body "\n") "\necho','\n"))
(defun org-babel-J-interleave-echos-except-functions (body)
"Interleave echo',' between source lines of BODY that aren't functions."
(if (obj-string-match-m "\\(?:^\\|\n\\)[^\n]*\\(?:0\\|1\\|2\\|3\\|4\\|dyad\\) : 0\n.*\n)\\(?:\n\\|$\\)" body)
(let ((s1 (substring body 0 (match-beginning 0)))
(s2 (match-string 0 body))
(s3 (substring body (match-end 0))))
(concat
(if (string= s1 "")
""
(concat (org-babel-J-interleave-echos s1)
"\necho','\n"))
s2
"\necho','\n"
(org-babel-J-interleave-echos-except-functions s3)))
(org-babel-J-interleave-echos body)))
(defalias 'org-babel-execute:j 'org-babel-execute:J)
(defun org-babel-execute:J (body params)
"Execute a block of J code BODY.
PARAMS are given by org-babel.
This function is called by `org-babel-execute-src-block'"
(message "executing J source code block")
(let* ((processed-params (org-babel-process-params params))
(sessionp (cdr (assq :session params)))
(full-body (org-babel-expand-body:J
body params processed-params))
(tmp-script-file (org-babel-temp-file "J-src")))
(org-babel-j-initiate-session sessionp)
(org-babel-J-strip-whitespace
(if (string= sessionp "none")
(progn
(with-temp-file tmp-script-file
(insert full-body))
(org-babel-eval (format "%s < %s" org-babel-J-command tmp-script-file) ""))
(org-babel-J-eval-string full-body)))))
(defun org-babel-J-eval-string (str)
"Sends STR to the `j-console-cmd' session and exectues it."
(let ((session (j-console-ensure-session)))
(with-current-buffer (process-buffer session)
(goto-char (point-max))
(insert (format "\n%s\n" str))
(let ((beg (point)))
(comint-send-input)
(sit-for .1)
(buffer-substring-no-properties
beg (point-max))))))
(defun org-babel-J-strip-whitespace (str)
"Remove whitespace from jconsole output STR."
(mapconcat
#'identity
(delete "" (mapcar
#'org-babel-J-print-block
(split-string str "^ *,\n" t)))
"\n\n"))
(defun obj-get-string-alignment (str)
"Return a number to describe STR alignment.
STR represents a table.
Positive/negative/zero result means right/left/undetermined.
Don't trust first line."
(let* ((str (org-trim str))
(lines (split-string str "\n" t))
n1 n2)
(cond ((<= (length lines) 1)
0)
((= (length lines) 2)
;; numbers are right-aligned
(if (and
(numberp (read (car lines)))
(numberp (read (cadr lines)))
(setq n1 (obj-match-second-space-right (nth 0 lines)))
(setq n2 (obj-match-second-space-right (nth 1 lines))))
n2
0))
((not (obj-match-second-space-left (nth 0 lines)))
0)
((and
(setq n1 (obj-match-second-space-left (nth 1 lines)))
(setq n2 (obj-match-second-space-left (nth 2 lines)))
(= n1 n2))
n1)
((and
(setq n1 (obj-match-second-space-right (nth 1 lines)))
(setq n2 (obj-match-second-space-right (nth 2 lines)))
(= n1 n2))
(- n1))
(t 0))))
(defun org-babel-J-print-block (x)
"Prettify jconsole output X."
(let* ((x (org-trim x))
(a (obj-get-string-alignment x))
(lines (split-string x "\n" t))
b)
(cond ((< a 0)
(setq b (obj-match-second-space-right (nth 0 lines)))
(concat (make-string (+ a b) ? ) x))
((> a 0)
(setq b (obj-match-second-space-left (nth 0 lines)))
(concat (make-string (- a b) ? ) x))
(t x))))
(defun obj-match-second-space-left (s)
"Return position of leftmost space in second space block of S or nil."
(and (string-match "^ *[^ ]+\\( \\)" s)
(match-beginning 1)))
(defun obj-match-second-space-right (s)
"Return position of rightmost space in second space block of S or nil."
(and (string-match "^ *[^ ]+ *\\( \\)[^ ]" s)
(match-beginning 1)))
(defun obj-string-match-m (regexp string &optional start)
"Call (string-match REGEXP STRING START).
REGEXP is modified so that .* matches newlines as well."
(string-match
(replace-regexp-in-string "\\.\\*" "[\0-\377[:nonascii:]]*" regexp)
string
start))
(defun org-babel-j-initiate-session (&optional session)
"Initiate a J session.
SESSION is a parameter given by org-babel."
(unless (string= session "none")
(require 'j-console)
(j-console-ensure-session)))
(provide 'ob-J)
;;; ob-J.el ends here

266
lisp/org/ob-R.el
View file

@ -1,4 +1,4 @@
;;; ob-R.el --- org-babel functions for R code evaluation
;;; ob-R.el --- Babel Functions for R -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -27,16 +27,17 @@
;; Org-Babel support for evaluating R code
;;; Code:
(require 'cl-lib)
(require 'ob)
(eval-when-compile (require 'cl))
(declare-function orgtbl-to-tsv "org-table" (table params))
(declare-function R "ext:essd-r" (&optional start-args))
(declare-function inferior-ess-send-input "ext:ess-inf" ())
(declare-function ess-make-buffer-current "ext:ess-inf" ())
(declare-function ess-eval-buffer "ext:ess-inf" (vis))
(declare-function org-number-sequence "org-compat" (from &optional to inc))
(declare-function org-remove-if-not "org" (predicate seq))
(declare-function ess-wait-for-process "ext:ess-inf"
(&optional proc sec-prompt wait force-redisplay))
(defconst org-babel-header-args:R
'((width . :any)
@ -60,12 +61,25 @@
(useDingbats . :any)
(horizontal . :any)
(results . ((file list vector table scalar verbatim)
(raw org html latex code pp wrap)
(replace silent append prepend)
(raw html latex org code pp drawer)
(replace silent none append prepend)
(output value graphics))))
"R-specific header arguments.")
(defconst ob-R-safe-header-args
(append org-babel-safe-header-args
'(:width :height :bg :units :pointsize :antialias :quality
:compression :res :type :family :title :fonts
:version :paper :encoding :pagecentre :colormodel
:useDingbats :horizontal))
"Header args which are safe for R babel blocks.
See `org-babel-safe-header-args' for documentation of the format of
this variable.")
(defvar org-babel-default-header-args:R '())
(put 'org-babel-default-header-args:R 'safe-local-variable
(org-babel-header-args-safe-fn ob-R-safe-header-args))
(defcustom org-babel-R-command "R --slave --no-save"
"Name of command to use for executing R code."
@ -73,56 +87,103 @@
:version "24.1"
:type 'string)
(defvar ess-local-process-name) ; dynamically scoped
(defvar ess-current-process-name) ; dynamically scoped
(defvar ess-local-process-name) ; dynamically scoped
(defun org-babel-edit-prep:R (info)
(let ((session (cdr (assoc :session (nth 2 info)))))
(when (and session (string-match "^\\*\\(.+?\\)\\*$" session))
(save-match-data (org-babel-R-initiate-session session nil)))))
(let ((session (cdr (assq :session (nth 2 info)))))
(when (and session
(string-prefix-p "*" session)
(string-suffix-p "*" session))
(org-babel-R-initiate-session session nil))))
(defun org-babel-expand-body:R (body params &optional graphics-file)
;; The usage of utils::read.table() ensures that the command
;; read.table() can be found even in circumstances when the utils
;; package is not in the search path from R.
(defconst ob-R-transfer-variable-table-with-header
"%s <- local({
con <- textConnection(
%S
)
res <- utils::read.table(
con,
header = %s,
row.names = %s,
sep = \"\\t\",
as.is = TRUE
)
close(con)
res
})"
"R code used to transfer a table defined as a variable from org to R.
This function is used when the table contains a header.")
(defconst ob-R-transfer-variable-table-without-header
"%s <- local({
con <- textConnection(
%S
)
res <- utils::read.table(
con,
header = %s,
row.names = %s,
sep = \"\\t\",
as.is = TRUE,
fill = TRUE,
col.names = paste(\"V\", seq_len(%d), sep =\"\")
)
close(con)
res
})"
"R code used to transfer a table defined as a variable from org to R.
This function is used when the table does not contain a header.")
(defun org-babel-expand-body:R (body params &optional _graphics-file)
"Expand BODY according to PARAMS, return the expanded body."
(let ((graphics-file
(or graphics-file (org-babel-R-graphical-output-file params))))
(mapconcat
#'identity
(let ((inside
(append
(when (cdr (assoc :prologue params))
(list (cdr (assoc :prologue params))))
(org-babel-variable-assignments:R params)
(list body)
(when (cdr (assoc :epilogue params))
(list (cdr (assoc :epilogue params)))))))
(if graphics-file
(append
(list (org-babel-R-construct-graphics-device-call
graphics-file params))
inside
(list "dev.off()"))
inside))
"\n")))
(mapconcat 'identity
(append
(when (cdr (assq :prologue params))
(list (cdr (assq :prologue params))))
(org-babel-variable-assignments:R params)
(list body)
(when (cdr (assq :epilogue params))
(list (cdr (assq :epilogue params)))))
"\n"))
(defun org-babel-execute:R (body params)
"Execute a block of R code.
This function is called by `org-babel-execute-src-block'."
(save-excursion
(let* ((result-params (cdr (assoc :result-params params)))
(result-type (cdr (assoc :result-type params)))
(let* ((result-params (cdr (assq :result-params params)))
(result-type (cdr (assq :result-type params)))
(session (org-babel-R-initiate-session
(cdr (assoc :session params)) params))
(colnames-p (cdr (assoc :colnames params)))
(rownames-p (cdr (assoc :rownames params)))
(graphics-file (org-babel-R-graphical-output-file params))
(full-body (org-babel-expand-body:R body params graphics-file))
(cdr (assq :session params)) params))
(colnames-p (cdr (assq :colnames params)))
(rownames-p (cdr (assq :rownames params)))
(graphics-file (and (member "graphics" (assq :result-params params))
(org-babel-graphical-output-file params)))
(full-body
(let ((inside
(list (org-babel-expand-body:R body params graphics-file))))
(mapconcat 'identity
(if graphics-file
(append
(list (org-babel-R-construct-graphics-device-call
graphics-file params))
inside
(list "},error=function(e){plot(x=-1:1, y=-1:1, type='n', xlab='', ylab='', axes=FALSE); text(x=0, y=0, labels=e$message, col='red'); paste('ERROR', e$message, sep=' : ')}); dev.off()"))
inside)
"\n")))
(result
(org-babel-R-evaluate
session full-body result-type result-params
(or (equal "yes" colnames-p)
(org-babel-pick-name
(cdr (assoc :colname-names params)) colnames-p))
(cdr (assq :colname-names params)) colnames-p))
(or (equal "yes" rownames-p)
(org-babel-pick-name
(cdr (assoc :rowname-names params)) rownames-p)))))
(cdr (assq :rowname-names params)) rownames-p)))))
(if graphics-file nil result))))
(defun org-babel-prep-session:R (session params)
@ -148,21 +209,21 @@ This function is called by `org-babel-execute-src-block'."
(defun org-babel-variable-assignments:R (params)
"Return list of R statements assigning the block's variables."
(let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
(let ((vars (org-babel--get-vars params)))
(mapcar
(lambda (pair)
(org-babel-R-assign-elisp
(car pair) (cdr pair)
(equal "yes" (cdr (assoc :colnames params)))
(equal "yes" (cdr (assoc :rownames params)))))
(equal "yes" (cdr (assq :colnames params)))
(equal "yes" (cdr (assq :rownames params)))))
(mapcar
(lambda (i)
(cons (car (nth i vars))
(org-babel-reassemble-table
(cdr (nth i vars))
(cdr (nth i (cdr (assoc :colname-names params))))
(cdr (nth i (cdr (assoc :rowname-names params)))))))
(org-number-sequence 0 (1- (length vars)))))))
(cdr (nth i (cdr (assq :colname-names params))))
(cdr (nth i (cdr (assq :rowname-names params)))))))
(number-sequence 0 (1- (length vars)))))))
(defun org-babel-R-quote-tsv-field (s)
"Quote field S for export to R."
@ -173,35 +234,25 @@ This function is called by `org-babel-execute-src-block'."
(defun org-babel-R-assign-elisp (name value colnames-p rownames-p)
"Construct R code assigning the elisp VALUE to a variable named NAME."
(if (listp value)
(let* ((lengths (mapcar 'length (org-remove-if-not 'sequencep value)))
(let* ((lengths (mapcar 'length (cl-remove-if-not 'sequencep value)))
(max (if lengths (apply 'max lengths) 0))
(min (if lengths (apply 'min lengths) 0))
(transition-file (org-babel-temp-file "R-import-")))
(min (if lengths (apply 'min lengths) 0)))
;; Ensure VALUE has an orgtbl structure (depth of at least 2).
(unless (listp (car value)) (setq value (list value)))
(with-temp-file transition-file
(insert
(orgtbl-to-tsv value '(:fmt org-babel-R-quote-tsv-field))
"\n"))
(let ((file (org-babel-process-file-name transition-file 'noquote))
(let ((file (orgtbl-to-tsv value '(:fmt org-babel-R-quote-tsv-field)))
(header (if (or (eq (nth 1 value) 'hline) colnames-p)
"TRUE" "FALSE"))
(row-names (if rownames-p "1" "NULL")))
(if (= max min)
(format "%s <- read.table(\"%s\",
header=%s,
row.names=%s,
sep=\"\\t\",
as.is=TRUE)" name file header row-names)
(format "%s <- read.table(\"%s\",
header=%s,
row.names=%s,
sep=\"\\t\",
as.is=TRUE,
fill=TRUE,
col.names = paste(\"V\", seq_len(%d), sep =\"\"))"
(format ob-R-transfer-variable-table-with-header
name file header row-names)
(format ob-R-transfer-variable-table-without-header
name file header row-names max))))
(format "%s <- %s" name (org-babel-R-quote-tsv-field value))))
(cond ((integerp value) (format "%s <- %s" name (concat (number-to-string value) "L")))
((floatp value) (format "%s <- %s" name value))
((stringp value) (format "%s <- %S" name (org-no-properties value)))
(t (format "%s <- %S" name (prin1-to-string value))))))
(defvar ess-ask-for-ess-directory) ; dynamically scoped
(defun org-babel-R-initiate-session (session params)
@ -209,8 +260,9 @@ This function is called by `org-babel-execute-src-block'."
(unless (string= session "none")
(let ((session (or session "*R*"))
(ess-ask-for-ess-directory
(and (and (boundp 'ess-ask-for-ess-directory) ess-ask-for-ess-directory)
(not (cdr (assoc :dir params))))))
(and (boundp 'ess-ask-for-ess-directory)
ess-ask-for-ess-directory
(not (cdr (assq :dir params))))))
(if (org-babel-comint-buffer-livep session)
session
(save-window-excursion
@ -218,6 +270,10 @@ This function is called by `org-babel-execute-src-block'."
;; Session buffer exists, but with dead process
(set-buffer session))
(require 'ess) (R)
(let ((R-proc (get-process (or ess-local-process-name
ess-current-process-name))))
(while (process-get R-proc 'callbacks)
(ess-wait-for-process R-proc)))
(rename-buffer
(if (bufferp session)
(buffer-name session)
@ -234,11 +290,6 @@ current code buffer."
(process-name (get-buffer-process session)))
(ess-make-buffer-current))
(defun org-babel-R-graphical-output-file (params)
"Name of file to which R should send graphical output."
(and (member "graphics" (cdr (assq :result-params params)))
(cdr (assq :file params))))
(defvar org-babel-R-graphics-devices
'((:bmp "bmp" "filename")
(:jpg "jpeg" "filename")
@ -265,8 +316,7 @@ Each member of this list is a list with three members:
:type :family :title :fonts :version
:paper :encoding :pagecentre :colormodel
:useDingbats :horizontal))
(device (and (string-match ".+\\.\\([^.]+\\)" out-file)
(match-string 1 out-file)))
(device (file-name-extension out-file))
(device-info (or (assq (intern (concat ":" device))
org-babel-R-graphics-devices)
(assq :png org-babel-R-graphics-devices)))
@ -280,14 +330,43 @@ Each member of this list is a list with three members:
(substring (symbol-name (car pair)) 1)
(cdr pair)) ""))
params ""))
(format "%s(%s=\"%s\"%s%s%s)"
(format "%s(%s=\"%s\"%s%s%s); tryCatch({"
device filearg out-file args
(if extra-args "," "") (or extra-args ""))))
(defvar org-babel-R-eoe-indicator "'org_babel_R_eoe'")
(defvar org-babel-R-eoe-output "[1] \"org_babel_R_eoe\"")
(defconst org-babel-R-eoe-indicator "'org_babel_R_eoe'")
(defconst org-babel-R-eoe-output "[1] \"org_babel_R_eoe\"")
(defvar org-babel-R-write-object-command "{function(object,transfer.file){object;invisible(if(inherits(try({tfile<-tempfile();write.table(object,file=tfile,sep=\"\\t\",na=\"nil\",row.names=%s,col.names=%s,quote=FALSE);file.rename(tfile,transfer.file)},silent=TRUE),\"try-error\")){if(!file.exists(transfer.file))file.create(transfer.file)})}}(object=%s,transfer.file=\"%s\")")
(defconst org-babel-R-write-object-command "{
function(object,transfer.file) {
object
invisible(
if (
inherits(
try(
{
tfile<-tempfile()
write.table(object, file=tfile, sep=\"\\t\",
na=\"nil\",row.names=%s,col.names=%s,
quote=FALSE)
file.rename(tfile,transfer.file)
},
silent=TRUE),
\"try-error\"))
{
if(!file.exists(transfer.file))
file.create(transfer.file)
}
)
}
}(object=%s,transfer.file=\"%s\")"
"A template for an R command to evaluate a block of code and write the result to a file.
Has four %s escapes to be filled in:
1. Row names, \"TRUE\" or \"FALSE\"
2. Column names, \"TRUE\" or \"FALSE\"
3. The code to be run (must be an expression, not a statement)
4. The name of the file to write to")
(defun org-babel-R-evaluate
(session body result-type result-params column-names-p row-names-p)
@ -299,12 +378,12 @@ Each member of this list is a list with three members:
body result-type result-params column-names-p row-names-p)))
(defun org-babel-R-evaluate-external-process
(body result-type result-params column-names-p row-names-p)
(body result-type result-params column-names-p row-names-p)
"Evaluate BODY in external R process.
If RESULT-TYPE equals 'output then return standard output as a
string. If RESULT-TYPE equals 'value then return the value of the
If RESULT-TYPE equals `output' then return standard output as a
string. If RESULT-TYPE equals `value' then return the value of the
last statement in BODY, as elisp."
(case result-type
(cl-case result-type
(value
(let ((tmp-file (org-babel-temp-file "R-")))
(org-babel-eval org-babel-R-command
@ -319,7 +398,7 @@ last statement in BODY, as elisp."
(org-babel-result-cond result-params
(with-temp-buffer
(insert-file-contents tmp-file)
(buffer-string))
(org-babel-chomp (buffer-string) "\n"))
(org-babel-import-elisp-from-file tmp-file '(16)))
column-names-p)))
(output (org-babel-eval org-babel-R-command body))))
@ -327,12 +406,12 @@ last statement in BODY, as elisp."
(defvar ess-eval-visibly-p)
(defun org-babel-R-evaluate-session
(session body result-type result-params column-names-p row-names-p)
(session body result-type result-params column-names-p row-names-p)
"Evaluate BODY in SESSION.
If RESULT-TYPE equals 'output then return standard output as a
string. If RESULT-TYPE equals 'value then return the value of the
If RESULT-TYPE equals `output' then return standard output as a
string. If RESULT-TYPE equals `value' then return the value of the
last statement in BODY, as elisp."
(case result-type
(cl-case result-type
(value
(with-temp-buffer
(insert (org-babel-chomp body))
@ -353,12 +432,12 @@ last statement in BODY, as elisp."
(org-babel-result-cond result-params
(with-temp-buffer
(insert-file-contents tmp-file)
(buffer-string))
(org-babel-chomp (buffer-string) "\n"))
(org-babel-import-elisp-from-file tmp-file '(16)))
column-names-p)))
(output
(mapconcat
#'org-babel-chomp
'org-babel-chomp
(butlast
(delq nil
(mapcar
@ -366,11 +445,12 @@ last statement in BODY, as elisp."
(mapcar
(lambda (line) ;; cleanup extra prompts left in output
(if (string-match
"^\\([ ]*[>+\\.][ ]?\\)+\\([[0-9]+\\|[ ]\\)" line)
"^\\([>+.]\\([ ][>.+]\\)*[ ]\\)"
(car (split-string line "\n")))
(substring line (match-end 1))
line))
(org-babel-comint-with-output (session org-babel-R-eoe-output)
(insert (mapconcat #'org-babel-chomp
(insert (mapconcat 'org-babel-chomp
(list body org-babel-R-eoe-indicator)
"\n"))
(inferior-ess-send-input)))))) "\n"))))

92
lisp/org/ob-abc.el Normal file
View file

@ -0,0 +1,92 @@
;;; ob-abc.el --- Org Babel Functions for ABC -*- lexical-binding: t; -*-
;; Copyright (C) 2013-2017 Free Software Foundation, Inc.
;; Author: William Waites
;; Keywords: literate programming, music
;; Homepage: http://www.tardis.ed.ac.uk/wwaites
;; Version: 0.01
;;; License:
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;; This file adds support to Org Babel for music in ABC notation.
;;; It requires that the abcm2ps program is installed.
;;; See http://moinejf.free.fr/
(require 'ob)
;; optionally define a file extension for this language
(add-to-list 'org-babel-tangle-lang-exts '("abc" . "abc"))
;; optionally declare default header arguments for this language
(defvar org-babel-default-header-args:abc
'((:results . "file") (:exports . "results"))
"Default arguments to use when evaluating an ABC source block.")
(defun org-babel-expand-body:abc (body params)
"Expand BODY according to PARAMS, return the expanded body."
(let ((vars (org-babel--get-vars params)))
(mapc
(lambda (pair)
(let ((name (symbol-name (car pair)))
(value (cdr pair)))
(setq body
(replace-regexp-in-string
(concat "\$" (regexp-quote name))
(if (stringp value) value (format "%S" value))
body))))
vars)
body))
(defun org-babel-execute:abc (body params)
"Execute a block of ABC code with org-babel. This function is
called by `org-babel-execute-src-block'"
(message "executing Abc source code block")
(let* ((cmdline (cdr (assq :cmdline params)))
(out-file (let ((file (cdr (assq :file params))))
(if file (replace-regexp-in-string "\.pdf$" ".ps" file)
(error "abc code block requires :file header argument"))))
(in-file (org-babel-temp-file "abc-"))
(render (concat "abcm2ps" " " cmdline
" -O " (org-babel-process-file-name out-file)
" " (org-babel-process-file-name in-file))))
(with-temp-file in-file (insert (org-babel-expand-body:abc body params)))
(org-babel-eval render "")
;;; handle where abcm2ps changes the file name (to support multiple files
(when (or (string= (file-name-extension out-file) "eps")
(string= (file-name-extension out-file) "svg"))
(rename-file (concat
(file-name-sans-extension out-file) "001."
(file-name-extension out-file))
out-file t))
;;; if we were asked for a pdf...
(when (string= (file-name-extension (cdr (assq :file params))) "pdf")
(org-babel-eval (concat "ps2pdf" " " out-file " " (cdr (assq :file params))) ""))
;;; indicate that the file has been written
nil))
;; This function should be used to assign any variables in params in
;; the context of the session environment.
(defun org-babel-prep-session:abc (_session _params)
"Return an error because abc does not support sessions."
(error "ABC does not support sessions"))
(provide 'ob-abc)
;;; ob-abc.el ends here

46
lisp/org/ob-asymptote.el
View file

@ -1,4 +1,4 @@
;;; ob-asymptote.el --- org-babel functions for asymptote evaluation
;;; ob-asymptote.el --- Babel Functions for Asymptote -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -43,11 +43,6 @@
;;; Code:
(require 'ob)
(eval-when-compile (require 'cl))
(declare-function orgtbl-to-generic "org-table"
(table params &optional backend))
(declare-function org-combine-plists "org" (&rest plists))
(defvar org-babel-tangle-lang-exts)
(add-to-list 'org-babel-tangle-lang-exts '("asymptote" . "asy"))
@ -59,13 +54,10 @@
(defun org-babel-execute:asymptote (body params)
"Execute a block of Asymptote code.
This function is called by `org-babel-execute-src-block'."
(let* ((result-params (split-string (or (cdr (assoc :results params)) "")))
(out-file (cdr (assoc :file params)))
(format (or (and out-file
(string-match ".+\\.\\(.+\\)" out-file)
(match-string 1 out-file))
(let* ((out-file (cdr (assq :file params)))
(format (or (file-name-extension out-file)
"pdf"))
(cmdline (cdr (assoc :cmdline params)))
(cmdline (cdr (assq :cmdline params)))
(in-file (org-babel-temp-file "asymptote-"))
(cmd
(concat "asy "
@ -83,7 +75,7 @@ This function is called by `org-babel-execute-src-block'."
(message cmd) (shell-command cmd)
nil)) ;; signal that output has already been written to file
(defun org-babel-prep-session:asymptote (session params)
(defun org-babel-prep-session:asymptote (_session _params)
"Return an error if the :session header argument is set.
Asymptote does not support sessions"
(error "Asymptote does not support sessions"))
@ -91,7 +83,7 @@ Asymptote does not support sessions"
(defun org-babel-variable-assignments:asymptote (params)
"Return list of asymptote statements assigning the block's variables."
(mapcar #'org-babel-asymptote-var-to-asymptote
(mapcar #'cdr (org-babel-get-header params :var))))
(org-babel--get-vars params)))
(defun org-babel-asymptote-var-to-asymptote (pair)
"Convert an elisp value into an Asymptote variable.
@ -128,21 +120,17 @@ a variable of the same value."
DATA is a list. Return type as a symbol.
The type is `string' if any element in DATA is
a string. Otherwise, it is either `real', if some elements are
floats, or `int'."
(let* ((type 'int)
find-type ; for byte-compiler
(find-type
(function
(lambda (row)
(catch 'exit
(mapc (lambda (el)
(cond ((listp el) (funcall find-type el))
((stringp el) (throw 'exit (setq type 'string)))
((floatp el) (setq type 'real))))
row))))))
(funcall find-type data) type))
The type is `string' if any element in DATA is a string.
Otherwise, it is either `real', if some elements are floats, or
`int'."
(letrec ((type 'int)
(find-type
(lambda (row)
(dolist (e row type)
(cond ((listp e) (setq type (funcall find-type e)))
((stringp e) (throw 'exit 'string))
((floatp e) (setq type 'real)))))))
(catch 'exit (funcall find-type data)) type))
(provide 'ob-asymptote)

47
lisp/org/ob-awk.el
View file

@ -1,4 +1,4 @@
;;; ob-awk.el --- org-babel functions for awk evaluation
;;; ob-awk.el --- Babel Functions for Awk -*- lexical-binding: t; -*-
;; Copyright (C) 2011-2017 Free Software Foundation, Inc.
@ -27,17 +27,15 @@
;;
;; - :in-file takes a path to a file of data to be processed by awk
;;
;; - :stdin takes an Org-mode data or code block reference, the value
;; of which will be passed to the awk process through STDIN
;; - :stdin takes an Org data or code block reference, the value of
;; which will be passed to the awk process through STDIN
;;; Code:
(require 'ob)
(require 'org-compat)
(eval-when-compile (require 'cl))
(declare-function org-babel-ref-resolve "ob-ref" (ref))
(declare-function orgtbl-to-generic "org-table"
(table params &optional backend))
(declare-function orgtbl-to-generic "org-table" (table params))
(defvar org-babel-tangle-lang-exts)
(add-to-list 'org-babel-tangle-lang-exts '("awk" . "awk"))
@ -45,34 +43,38 @@
(defvar org-babel-awk-command "awk"
"Name of the awk executable command.")
(defun org-babel-expand-body:awk (body params)
(defun org-babel-expand-body:awk (body _params)
"Expand BODY according to PARAMS, return the expanded body."
(dolist (pair (mapcar #'cdr (org-babel-get-header params :var)))
(setf body (replace-regexp-in-string
(regexp-quote (format "$%s" (car pair))) (cdr pair) body)))
body)
(defun org-babel-execute:awk (body params)
"Execute a block of Awk code with org-babel. This function is
called by `org-babel-execute-src-block'"
(message "executing Awk source code block")
(let* ((result-params (cdr (assoc :result-params params)))
(cmd-line (cdr (assoc :cmd-line params)))
(in-file (cdr (assoc :in-file params)))
(let* ((result-params (cdr (assq :result-params params)))
(cmd-line (cdr (assq :cmd-line params)))
(in-file (cdr (assq :in-file params)))
(full-body (org-babel-expand-body:awk body params))
(code-file (let ((file (org-babel-temp-file "awk-")))
(with-temp-file file (insert full-body)) file))
(stdin (let ((stdin (cdr (assoc :stdin params))))
(stdin (let ((stdin (cdr (assq :stdin params))))
(when stdin
(let ((tmp (org-babel-temp-file "awk-stdin-"))
(res (org-babel-ref-resolve stdin)))
(with-temp-file tmp
(insert (org-babel-awk-var-to-awk res)))
tmp))))
(cmd (mapconcat #'identity (remove nil (list org-babel-awk-command
"-f" code-file
cmd-line
in-file))
(cmd (mapconcat #'identity
(append
(list org-babel-awk-command
"-f" code-file cmd-line)
(mapcar (lambda (pair)
(format "-v %s='%s'"
(car pair)
(org-babel-awk-var-to-awk
(cdr pair))))
(org-babel--get-vars params))
(list in-file))
" ")))
(org-babel-reassemble-table
(let ((results
@ -88,9 +90,9 @@ called by `org-babel-execute-src-block'"
(with-temp-file tmp (insert results))
(org-babel-import-elisp-from-file tmp)))))
(org-babel-pick-name
(cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
(cdr (assq :colname-names params)) (cdr (assq :colnames params)))
(org-babel-pick-name
(cdr (assoc :rowname-names params)) (cdr (assoc :rownames params))))))
(cdr (assq :rowname-names params)) (cdr (assq :rownames params))))))
(defun org-babel-awk-var-to-awk (var &optional sep)
"Return a printed value of VAR suitable for parsing with awk."
@ -102,11 +104,6 @@ called by `org-babel-execute-src-block'"
(mapconcat echo-var var "\n"))
(t (funcall echo-var var)))))
(defun org-babel-awk-table-or-string (results)
"If the results look like a table, then convert them into an
Emacs-lisp table, otherwise return the results as a string."
(org-babel-script-escape results))
(provide 'ob-awk)

20
lisp/org/ob-calc.el
View file

@ -1,4 +1,4 @@
;;; ob-calc.el --- org-babel functions for calc code evaluation
;;; ob-calc.el --- Babel Functions for Calc -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
@ -28,18 +28,18 @@
;;; Code:
(require 'ob)
(require 'calc)
(unless (featurep 'xemacs)
(require 'calc-trail)
(require 'calc-store))
(require 'calc-trail)
(require 'calc-store)
(declare-function calc-store-into "calc-store" (&optional var))
(declare-function calc-recall "calc-store" (&optional var))
(declare-function math-evaluate-expr "calc-ext" (x))
(declare-function org-trim "org" (s &optional keep-lead))
(defvar org-babel-default-header-args:calc nil
"Default arguments for evaluating an calc source block.")
(defun org-babel-expand-body:calc (body params)
(defun org-babel-expand-body:calc (body _params)
"Expand BODY according to PARAMS, return the expanded body." body)
(defvar org--var-syms) ; Dynamically scoped from org-babel-execute:calc
@ -48,7 +48,7 @@
"Execute a block of calc code with Babel."
(unless (get-buffer "*Calculator*")
(save-window-excursion (calc) (calc-quit)))
(let* ((vars (mapcar #'cdr (org-babel-get-header params :var)))
(let* ((vars (org-babel--get-vars params))
(org--var-syms (mapcar #'car vars))
(var-names (mapcar #'symbol-name org--var-syms)))
(mapc
@ -85,15 +85,17 @@
;; parse line into calc objects
(car (math-read-exprs line)))))))))
))))))
(mapcar #'org-babel-trim
(mapcar #'org-trim
(split-string (org-babel-expand-body:calc body params) "[\n\r]"))))
(save-excursion
(with-current-buffer (get-buffer "*Calculator*")
(calc-eval (calc-top 1)))))
(prog1
(calc-eval (calc-top 1))
(calc-pop 1)))))
(defun org-babel-calc-maybe-resolve-var (el)
(if (consp el)
(if (and (equal 'var (car el)) (member (cadr el) org--var-syms))
(if (and (eq 'var (car el)) (member (cadr el) org--var-syms))
(progn
(calc-recall (cadr el))
(prog1 (calc-top 1)

109
lisp/org/ob-clojure.el
View file

@ -1,9 +1,9 @@
;;; ob-clojure.el --- org-babel functions for clojure evaluation
;;; ob-clojure.el --- Babel Functions for Clojure -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
;; Author: Joel Boehland
;; Eric Schulte
;; Author: Joel Boehland, Eric Schulte, Oleh Krehel
;;
;; Keywords: literate programming, reproducible research
;; Homepage: http://orgmode.org
@ -24,21 +24,30 @@
;;; Commentary:
;; Support for evaluating clojure code, relies on slime for all eval.
;; Support for evaluating clojure code
;;; Requirements:
;; Requirements:
;; - clojure (at least 1.2.0)
;; - clojure-mode
;; - slime
;; - either cider or SLIME
;; By far, the best way to install these components is by following
;; For Cider, see https://github.com/clojure-emacs/cider
;; For SLIME, the best way to install these components is by following
;; the directions as set out by Phil Hagelberg (Technomancy) on the
;; web page: http://technomancy.us/126
;;; Code:
(require 'cl-lib)
(require 'ob)
(declare-function cider-current-connection "ext:cider-client" (&optional type))
(declare-function cider-current-session "ext:cider-client" ())
(declare-function nrepl-dict-get "ext:nrepl-client" (dict key))
(declare-function nrepl-sync-request:eval "ext:nrepl-client"
(input connection session &optional ns))
(declare-function org-trim "org" (s &optional keep-lead))
(declare-function slime-eval "ext:slime" (sexp &optional package))
(defvar org-babel-tangle-lang-exts)
@ -47,49 +56,63 @@
(defvar org-babel-default-header-args:clojure '())
(defvar org-babel-header-args:clojure '((package . :any)))
(defcustom org-babel-clojure-backend
(cond ((featurep 'cider) 'cider)
(t 'slime))
"Backend used to evaluate Clojure code blocks."
:group 'org-babel
:type '(choice
(const :tag "cider" cider)
(const :tag "SLIME" slime)))
(defun org-babel-expand-body:clojure (body params)
"Expand BODY according to PARAMS, return the expanded body."
(let* ((vars (mapcar #'cdr (org-babel-get-header params :var)))
(result-params (cdr (assoc :result-params params)))
(let* ((vars (org-babel--get-vars params))
(result-params (cdr (assq :result-params params)))
(print-level nil) (print-length nil)
(body (org-babel-trim
(if (> (length vars) 0)
(concat "(let ["
(mapconcat
(lambda (var)
(format "%S (quote %S)" (car var) (cdr var)))
vars "\n ")
"]\n" body ")")
body))))
(cond ((or (member "code" result-params) (member "pp" result-params))
(format (concat "(let [org-mode-print-catcher (java.io.StringWriter.)] "
"(clojure.pprint/with-pprint-dispatch clojure.pprint/%s-dispatch "
"(clojure.pprint/pprint (do %s) org-mode-print-catcher) "
"(str org-mode-print-catcher)))")
(if (member "code" result-params) "code" "simple") body))
;; if (:results output), collect printed output
((member "output" result-params)
(format "(clojure.core/with-out-str %s)" body))
(t body))))
(body (org-trim
(if (null vars) (org-trim body)
(concat "(let ["
(mapconcat
(lambda (var)
(format "%S (quote %S)" (car var) (cdr var)))
vars "\n ")
"]\n" body ")")))))
(if (or (member "code" result-params)
(member "pp" result-params))
(format "(clojure.pprint/pprint (do %s))" body)
body)))
(defun org-babel-execute:clojure (body params)
"Execute a block of Clojure code with Babel."
(require 'slime)
(with-temp-buffer
(insert (org-babel-expand-body:clojure body params))
(let ((result
(slime-eval
`(swank:eval-and-grab-output
,(buffer-substring-no-properties (point-min) (point-max)))
(cdr (assoc :package params)))))
(let ((result-params (cdr (assoc :result-params params))))
(org-babel-result-cond result-params
result
(condition-case nil (org-babel-script-escape result)
(error result)))))))
(let ((expanded (org-babel-expand-body:clojure body params))
result)
(cl-case org-babel-clojure-backend
(cider
(require 'cider)
(let ((result-params (cdr (assq :result-params params))))
(setq result
(nrepl-dict-get
(nrepl-sync-request:eval
expanded (cider-current-connection) (cider-current-session))
(if (or (member "output" result-params)
(member "pp" result-params))
"out"
"value")))))
(slime
(require 'slime)
(with-temp-buffer
(insert expanded)
(setq result
(slime-eval
`(swank:eval-and-grab-output
,(buffer-substring-no-properties (point-min) (point-max)))
(cdr (assq :package params)))))))
(org-babel-result-cond (cdr (assq :result-params params))
result
(condition-case nil (org-babel-script-escape result)
(error result)))))
(provide 'ob-clojure)
;;; ob-clojure.el ends here

112
lisp/org/ob-comint.el
View file

@ -1,4 +1,4 @@
;;; ob-comint.el --- org-babel functions for interaction with comint buffers
;;; ob-comint.el --- Babel Functions for Interaction with Comint Buffers -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -33,10 +33,7 @@
(require 'ob-core)
(require 'org-compat)
(require 'comint)
(eval-when-compile (require 'cl))
(declare-function with-parsed-tramp-file-name "tramp"
(filename var &rest body) t)
(declare-function tramp-flush-directory-property "tramp-cache" (key directory))
(require 'tramp)
(defun org-babel-comint-buffer-livep (buffer)
"Check if BUFFER is a comint buffer with a live process."
@ -49,12 +46,14 @@ BUFFER is checked with `org-babel-comint-buffer-livep'. BODY is
executed inside the protection of `save-excursion' and
`save-match-data'."
(declare (indent 1))
`(save-excursion
`(progn
(unless (org-babel-comint-buffer-livep ,buffer)
(error "Buffer %s does not exist or has no process" ,buffer))
(save-match-data
(unless (org-babel-comint-buffer-livep ,buffer)
(error "Buffer %s does not exist or has no process" ,buffer))
(set-buffer ,buffer)
,@body)))
(with-current-buffer ,buffer
(save-excursion
(let ((comint-input-filter (lambda (_input) nil)))
,@body))))))
(def-edebug-spec org-babel-comint-in-buffer (form body))
(defmacro org-babel-comint-with-output (meta &rest body)
@ -70,53 +69,49 @@ elements are optional.
This macro ensures that the filter is removed in case of an error
or user `keyboard-quit' during execution of body."
(declare (indent 1))
(let ((buffer (car meta))
(eoe-indicator (cadr meta))
(remove-echo (cadr (cdr meta)))
(full-body (cadr (cdr (cdr meta)))))
(let ((buffer (nth 0 meta))
(eoe-indicator (nth 1 meta))
(remove-echo (nth 2 meta))
(full-body (nth 3 meta)))
`(org-babel-comint-in-buffer ,buffer
(let ((string-buffer "") dangling-text raw)
;; setup filter
(setq comint-output-filter-functions
(let* ((string-buffer "")
(comint-output-filter-functions
(cons (lambda (text) (setq string-buffer (concat string-buffer text)))
comint-output-filter-functions))
(unwind-protect
(progn
;; got located, and save dangling text
(goto-char (process-mark (get-buffer-process (current-buffer))))
(let ((start (point))
(end (point-max)))
(setq dangling-text (buffer-substring start end))
(delete-region start end))
;; pass FULL-BODY to process
,@body
;; wait for end-of-evaluation indicator
(while (progn
(goto-char comint-last-input-end)
(not (save-excursion
(and (re-search-forward
(regexp-quote ,eoe-indicator) nil t)
(re-search-forward
comint-prompt-regexp nil t)))))
(accept-process-output (get-buffer-process (current-buffer)))
;; thought the following this would allow async
;; background running, but I was wrong...
;; (run-with-timer .5 .5 'accept-process-output
;; (get-buffer-process (current-buffer)))
)
;; replace cut dangling text
(goto-char (process-mark (get-buffer-process (current-buffer))))
(insert dangling-text))
;; remove filter
(setq comint-output-filter-functions
(cdr comint-output-filter-functions)))
dangling-text)
;; got located, and save dangling text
(goto-char (process-mark (get-buffer-process (current-buffer))))
(let ((start (point))
(end (point-max)))
(setq dangling-text (buffer-substring start end))
(delete-region start end))
;; pass FULL-BODY to process
,@body
;; wait for end-of-evaluation indicator
(while (progn
(goto-char comint-last-input-end)
(not (save-excursion
(and (re-search-forward
(regexp-quote ,eoe-indicator) nil t)
(re-search-forward
comint-prompt-regexp nil t)))))
(accept-process-output (get-buffer-process (current-buffer)))
;; thought the following this would allow async
;; background running, but I was wrong...
;; (run-with-timer .5 .5 'accept-process-output
;; (get-buffer-process (current-buffer)))
)
;; replace cut dangling text
(goto-char (process-mark (get-buffer-process (current-buffer))))
(insert dangling-text)
;; remove echo'd FULL-BODY from input
(if (and ,remove-echo ,full-body
(string-match
(replace-regexp-in-string
"\n" "[\r\n]+" (regexp-quote (or ,full-body "")))
string-buffer))
(setq raw (substring string-buffer (match-end 0))))
(when (and ,remove-echo ,full-body
(string-match
(replace-regexp-in-string
"\n" "[\r\n]+" (regexp-quote (or ,full-body "")))
string-buffer))
(setq string-buffer (substring string-buffer (match-end 0))))
(split-string string-buffer comint-prompt-regexp)))))
(def-edebug-spec org-babel-comint-with-output (sexp body))
@ -149,15 +144,14 @@ Don't return until FILE exists. Code in STRING must ensure that
FILE exists at end of evaluation."
(unless (org-babel-comint-buffer-livep buffer)
(error "Buffer %s does not exist or has no process" buffer))
(if (file-exists-p file) (delete-file file))
(when (file-exists-p file) (delete-file file))
(process-send-string
(get-buffer-process buffer)
(if (string-match "\n$" string) string (concat string "\n")))
(if (= (aref string (1- (length string))) ?\n) string (concat string "\n")))
;; From Tramp 2.1.19 the following cache flush is not necessary
(if (file-remote-p default-directory)
(let (v)
(with-parsed-tramp-file-name default-directory nil
(tramp-flush-directory-property v ""))))
(when (file-remote-p default-directory)
(with-parsed-tramp-file-name default-directory nil
(tramp-flush-directory-property v "")))
(while (not (file-exists-p file)) (sit-for (or period 0.25))))
(provide 'ob-comint)

78
lisp/org/ob-coq.el Normal file
View file

@ -0,0 +1,78 @@
;;; ob-coq.el --- Babel Functions for Coq -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
;; Author: Eric Schulte
;; Keywords: literate programming, reproducible research
;; Homepage: http://orgmode.org
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Rudimentary support for evaluating Coq code blocks. Currently only
;; session evaluation is supported. Requires both coq.el and
;; coq-inferior.el, both of which are distributed with Coq.
;;
;; http://coq.inria.fr/
;;; Code:
(require 'ob)
(declare-function run-coq "ext:coq-inferior.el" (cmd))
(declare-function coq-proc "ext:coq-inferior.el" ())
(defvar coq-program-name "coqtop"
"Name of the coq toplevel to run.")
(defvar org-babel-coq-buffer "*coq*"
"Buffer in which to evaluate coq code blocks.")
(defun org-babel-coq-clean-prompt (string)
(if (string-match "^[^[:space:]]+ < " string)
(substring string 0 (match-beginning 0))
string))
(defun org-babel-execute:coq (body params)
(let ((full-body (org-babel-expand-body:generic body params))
(session (org-babel-coq-initiate-session))
(pt (lambda ()
(marker-position
(process-mark (get-buffer-process (current-buffer)))))))
(org-babel-coq-clean-prompt
(org-babel-comint-in-buffer session
(let ((start (funcall pt)))
(with-temp-buffer
(insert full-body)
(comint-send-region (coq-proc) (point-min) (point-max))
(comint-send-string (coq-proc)
(if (string= (buffer-substring (- (point-max) 1) (point-max)) ".")
"\n"
".\n")))
(while (equal start (funcall pt)) (sleep-for 0.1))
(buffer-substring start (funcall pt)))))))
(defun org-babel-coq-initiate-session ()
"Initiate a coq session.
If there is not a current inferior-process-buffer in SESSION then
create one. Return the initialized session."
(unless (fboundp 'run-coq)
(error "`run-coq' not defined, load coq-inferior.el"))
(save-window-excursion (run-coq coq-program-name))
(sit-for 0.1)
(get-buffer org-babel-coq-buffer))
(provide 'ob-coq)

2806
lisp/org/ob-core.el
View file

File diff suppressed because it is too large Load diff

8
lisp/org/ob-css.el
View file

@ -1,4 +1,4 @@
;;; ob-css.el --- org-babel functions for css evaluation
;;; ob-css.el --- Babel Functions for CSS -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -24,19 +24,19 @@
;;; Commentary:
;; Since CSS can't be executed, this file exists solely for tangling
;; CSS from org-mode files.
;; CSS from Org files.
;;; Code:
(require 'ob)
(defvar org-babel-default-header-args:css '())
(defun org-babel-execute:css (body params)
(defun org-babel-execute:css (body _params)
"Execute a block of CSS code.
This function is called by `org-babel-execute-src-block'."
body)
(defun org-babel-prep-session:css (session params)
(defun org-babel-prep-session:css (_session _params)
"Return an error if the :session header argument is set.
CSS does not support sessions."
(error "CSS sessions are nonsensical"))

36
lisp/org/ob-ditaa.el
View file

@ -1,4 +1,4 @@
;;; ob-ditaa.el --- org-babel functions for ditaa evaluation
;;; ob-ditaa.el --- Babel Functions for ditaa -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -81,15 +81,21 @@ Do not leave leading or trailing spaces in this string."
(defun org-babel-execute:ditaa (body params)
"Execute a block of Ditaa code with org-babel.
This function is called by `org-babel-execute-src-block'."
(let* ((result-params (split-string (or (cdr (assoc :results params)) "")))
(out-file (let ((el (cdr (assoc :file params))))
(or el
(error
"ditaa code block requires :file header argument"))))
(cmdline (cdr (assoc :cmdline params)))
(java (cdr (assoc :java params)))
(let* ((out-file (or (cdr (assq :file params))
(error
"ditaa code block requires :file header argument")))
(cmdline (cdr (assq :cmdline params)))
(java (cdr (assq :java params)))
(in-file (org-babel-temp-file "ditaa-"))
(eps (cdr (assoc :eps params)))
(eps (cdr (assq :eps params)))
(eps-file (when eps
(org-babel-process-file-name (concat in-file ".eps"))))
(pdf-cmd (when (and (or (string= (file-name-extension out-file) "pdf")
(cdr (assq :pdf params))))
(concat
"epstopdf"
" " eps-file
" -o=" (org-babel-process-file-name out-file))))
(cmd (concat org-babel-ditaa-java-cmd
" " java " " org-ditaa-jar-option " "
(shell-quote-argument
@ -97,13 +103,9 @@ This function is called by `org-babel-execute-src-block'."
(if eps org-ditaa-eps-jar-path org-ditaa-jar-path)))
" " cmdline
" " (org-babel-process-file-name in-file)
" " (org-babel-process-file-name out-file)))
(pdf-cmd (when (and (or (string= (file-name-extension out-file) "pdf")
(cdr (assoc :pdf params))))
(concat
"epstopdf"
" " (org-babel-process-file-name (concat in-file ".eps"))
" -o=" (org-babel-process-file-name out-file)))))
" " (if pdf-cmd
eps-file
(org-babel-process-file-name out-file)))))
(unless (file-exists-p org-ditaa-jar-path)
(error "Could not find ditaa.jar at %s" org-ditaa-jar-path))
(with-temp-file in-file (insert body))
@ -111,7 +113,7 @@ This function is called by `org-babel-execute-src-block'."
(when pdf-cmd (message pdf-cmd) (shell-command pdf-cmd))
nil)) ;; signal that output has already been written to file
(defun org-babel-prep-session:ditaa (session params)
(defun org-babel-prep-session:ditaa (_session _params)
"Return an error because ditaa does not support sessions."
(error "Ditaa does not support sessions"))

17
lisp/org/ob-dot.el
View file

@ -1,4 +1,4 @@
;;; ob-dot.el --- org-babel functions for dot evaluation
;;; ob-dot.el --- Babel Functions for dot -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -46,7 +46,7 @@
(defun org-babel-expand-body:dot (body params)
"Expand BODY according to PARAMS, return the expanded body."
(let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
(let ((vars (org-babel--get-vars params)))
(mapc
(lambda (pair)
(let ((name (symbol-name (car pair)))
@ -55,19 +55,20 @@
(replace-regexp-in-string
(concat "$" (regexp-quote name))
(if (stringp value) value (format "%S" value))
body))))
body
t
t))))
vars)
body))
(defun org-babel-execute:dot (body params)
"Execute a block of Dot code with org-babel.
This function is called by `org-babel-execute-src-block'."
(let* ((result-params (cdr (assoc :result-params params)))
(out-file (cdr (or (assoc :file params)
(let* ((out-file (cdr (or (assq :file params)
(error "You need to specify a :file parameter"))))
(cmdline (or (cdr (assoc :cmdline params))
(cmdline (or (cdr (assq :cmdline params))
(format "-T%s" (file-name-extension out-file))))
(cmd (or (cdr (assoc :cmd params)) "dot"))
(cmd (or (cdr (assq :cmd params)) "dot"))
(in-file (org-babel-temp-file "dot-")))
(with-temp-file in-file
(insert (org-babel-expand-body:dot body params)))
@ -78,7 +79,7 @@ This function is called by `org-babel-execute-src-block'."
" -o " (org-babel-process-file-name out-file)) "")
nil)) ;; signal that output has already been written to file
(defun org-babel-prep-session:dot (session params)
(defun org-babel-prep-session:dot (_session _params)
"Return an error because Dot does not support sessions."
(error "Dot does not support sessions"))

83
lisp/org/ob-ebnf.el Normal file
View file

@ -0,0 +1,83 @@
;;; ob-ebnf.el --- Babel Functions for EBNF -*- lexical-binding: t; -*-
;; Copyright (C) 2013-2017 Free Software Foundation, Inc.
;; Author: Michael Gauland
;; Keywords: literate programming, reproducible research
;; Homepage: http://orgmode.org
;; Version: 1.00
;;; License:
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;; Org-Babel support for using ebnf2ps to generate encapsulated postscript
;;; railroad diagrams. It recogises these arguments:
;;;
;;; :file is required; it must include the extension '.eps.' All the rules
;;; in the block will be drawn in the same file. This is done by
;;; inserting a '[<file>' comment at the start of the block (see the
;;; documentation for ebnf-eps-buffer for more information).
;;;
;;; :style specifies a value in ebnf-style-database. This provides the
;;; ability to customise the output. The style can also specify the
;;; grammar syntax (by setting ebnf-syntax); note that only ebnf,
;;; iso-ebnf, and yacc are supported by this file.
;;; Requirements:
;;; Code:
(require 'ob)
(require 'ebnf2ps)
;; optionally declare default header arguments for this language
(defvar org-babel-default-header-args:ebnf '((:style . nil)))
;; Use ebnf-eps-buffer to produce an encapsulated postscript file.
;;
(defun org-babel-execute:ebnf (body params)
"Execute a block of Ebnf code with org-babel. This function is
called by `org-babel-execute-src-block'"
(save-excursion
(let* ((dest-file (cdr (assq :file params)))
(dest-dir (file-name-directory dest-file))
(dest-root (file-name-sans-extension
(file-name-nondirectory dest-file)))
(style (cdr (assq :style params)))
(result nil))
(with-temp-buffer
(when style (ebnf-push-style style))
(let ((comment-format
(cond ((string= ebnf-syntax 'yacc) "/*%s*/")
((string= ebnf-syntax 'ebnf) ";%s")
((string= ebnf-syntax 'iso-ebnf) "(*%s*)")
(t (setq result
(format "EBNF error: format %s not supported."
ebnf-syntax))))))
(setq ebnf-eps-prefix dest-dir)
(insert (format comment-format (format "[%s" dest-root)))
(newline)
(insert body)
(newline)
(insert (format comment-format (format "]%s" dest-root)))
(ebnf-eps-buffer)
(when style (ebnf-pop-style))))
result)))
(provide 'ob-ebnf)
;;; ob-ebnf.el ends here

55
lisp/org/ob-emacs-lisp.el
View file

@ -1,4 +1,4 @@
;;; ob-emacs-lisp.el --- org-babel functions for emacs-lisp code evaluation
;;; ob-emacs-lisp.el --- Babel Functions for Emacs-lisp Code -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -28,17 +28,21 @@
;;; Code:
(require 'ob)
(defvar org-babel-default-header-args:emacs-lisp
'((:hlines . "yes") (:colnames . "no"))
"Default arguments for evaluating an emacs-lisp source block.")
(defconst org-babel-header-args:emacs-lisp '((lexical . :any))
"Emacs-lisp specific header arguments.")
(declare-function orgtbl-to-generic "org-table"
(table params &optional backend))
(defvar org-babel-default-header-args:emacs-lisp '((:lexical . "no"))
"Default arguments for evaluating an emacs-lisp source block.
A value of \"yes\" or t causes src blocks to be eval'd using
lexical scoping. It can also be an alist mapping symbols to
their value. It is used as the optional LEXICAL argument to
`eval', which see.")
(defun org-babel-expand-body:emacs-lisp (body params)
"Expand BODY according to PARAMS, return the expanded body."
(let* ((vars (mapcar #'cdr (org-babel-get-header params :var)))
(result-params (cdr (assoc :result-params params)))
(let* ((vars (org-babel--get-vars params))
(result-params (cdr (assq :result-params params)))
(print-level nil) (print-length nil)
(body (if (> (length vars) 0)
(concat "(let ("
@ -55,26 +59,33 @@
(defun org-babel-execute:emacs-lisp (body params)
"Execute a block of emacs-lisp code with Babel."
(save-window-excursion
(let ((result
(eval (read (format (if (member "output"
(cdr (assoc :result-params params)))
"(with-output-to-string %s)"
"(progn %s)")
(org-babel-expand-body:emacs-lisp
body params))))))
(org-babel-result-cond (cdr (assoc :result-params params))
(let* ((lexical (cdr (assq :lexical params)))
(result
(eval (read (format (if (member "output"
(cdr (assq :result-params params)))
"(with-output-to-string %s)"
"(progn %s)")
(org-babel-expand-body:emacs-lisp
body params)))
(if (listp lexical)
lexical
(member lexical '("yes" "t"))))))
(org-babel-result-cond (cdr (assq :result-params params))
(let ((print-level nil)
(print-length nil))
(if (or (member "scalar" (cdr (assoc :result-params params)))
(member "verbatim" (cdr (assoc :result-params params))))
(if (or (member "scalar" (cdr (assq :result-params params)))
(member "verbatim" (cdr (assq :result-params params))))
(format "%S" result)
(format "%s" result)))
(org-babel-reassemble-table
result
(org-babel-pick-name (cdr (assoc :colname-names params))
(cdr (assoc :colnames params)))
(org-babel-pick-name (cdr (assoc :rowname-names params))
(cdr (assoc :rownames params))))))))
(org-babel-pick-name (cdr (assq :colname-names params))
(cdr (assq :colnames params)))
(org-babel-pick-name (cdr (assq :rowname-names params))
(cdr (assq :rownames params))))))))
(org-babel-make-language-alias "elisp" "emacs-lisp")
(provide 'ob-emacs-lisp)

34
lisp/org/ob-eval.el
View file

@ -1,4 +1,4 @@
;;; ob-eval.el --- org-babel functions for external code evaluation
;;; ob-eval.el --- Babel Functions for External Code Evaluation -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -28,7 +28,6 @@
;;; Code:
(require 'org-macs)
(eval-when-compile (require 'cl))
(defvar org-babel-error-buffer-name "*Org-Babel Error Output*")
(declare-function org-babel-temp-file "ob-core" (prefix &optional suffix))
@ -57,6 +56,13 @@ STDERR with `org-babel-eval-error-notify'."
(progn
(with-current-buffer err-buff
(org-babel-eval-error-notify exit-code (buffer-string)))
(save-excursion
(when (get-buffer org-babel-error-buffer-name)
(with-current-buffer org-babel-error-buffer-name
(unless (derived-mode-p 'compilation-mode)
(compilation-mode))
;; Compilation-mode enforces read-only, but Babel expects the buffer modifiable.
(setq buffer-read-only nil))))
nil)
(buffer-string)))))
@ -114,18 +120,18 @@ function in various versions of Emacs.
(delete-file input-file))
(when (and error-file (file-exists-p error-file))
(if (< 0 (nth 7 (file-attributes error-file)))
(with-current-buffer (get-buffer-create error-buffer)
(let ((pos-from-end (- (point-max) (point))))
(or (bobp)
(insert "\f\n"))
;; Do no formatting while reading error file,
;; because that can run a shell command, and we
;; don't want that to cause an infinite recursion.
(format-insert-file error-file nil)
;; Put point after the inserted errors.
(goto-char (- (point-max) pos-from-end)))
(current-buffer)))
(when (< 0 (nth 7 (file-attributes error-file)))
(with-current-buffer (get-buffer-create error-buffer)
(let ((pos-from-end (- (point-max) (point))))
(or (bobp)
(insert "\f\n"))
;; Do no formatting while reading error file,
;; because that can run a shell command, and we
;; don't want that to cause an infinite recursion.
(format-insert-file error-file nil)
;; Put point after the inserted errors.
(goto-char (- (point-max) pos-from-end)))
(current-buffer)))
(delete-file error-file))
exit-status))

522
lisp/org/ob-exp.el
View file

@ -1,4 +1,4 @@
;;; ob-exp.el --- Exportation of org-babel source blocks
;;; ob-exp.el --- Exportation of Babel Source Blocks -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -24,81 +24,49 @@
;;; Code:
(require 'ob-core)
(require 'org-src)
(eval-when-compile
(require 'cl))
(defvar org-current-export-file)
(defvar org-babel-lob-one-liner-regexp)
(defvar org-babel-ref-split-regexp)
(defvar org-list-forbidden-blocks)
(declare-function org-babel-lob-get-info "ob-lob" ())
(declare-function org-babel-eval-wipe-error-buffer "ob-eval" ())
(declare-function org-between-regexps-p "org"
(start-re end-re &optional lim-up lim-down))
(declare-function org-get-indentation "org" (&optional line))
(declare-function org-heading-components "org" ())
(declare-function org-in-block-p "org" (names))
(declare-function org-in-verbatim-emphasis "org" ())
(declare-function org-link-search "org" (s &optional type avoid-pos stealth))
(declare-function org-fill-template "org" (template alist))
(declare-function org-split-string "org" (string &optional separators))
(declare-function org-element-at-point "org-element" (&optional keep-trail))
(declare-function org-babel-lob-get-info "ob-lob" (&optional datum))
(declare-function org-element-at-point "org-element" ())
(declare-function org-element-context "org-element" (&optional element))
(declare-function org-element-property "org-element" (property element))
(declare-function org-element-type "org-element" (element))
(declare-function org-escape-code-in-string "org-src" (s))
(declare-function org-export-copy-buffer "ox" ())
(declare-function org-fill-template "org" (template alist))
(declare-function org-get-indentation "org" (&optional line))
(declare-function org-in-commented-heading-p "org" (&optional no-inheritance))
(defvar org-src-preserve-indentation)
(defcustom org-export-babel-evaluate t
"Switch controlling code evaluation during export.
When set to nil no code will be evaluated as part of the export
process. When set to `inline-only', only inline code blocks will
be executed."
process and no header argumentss will be obeyed. When set to
`inline-only', only inline code blocks will be executed. Users
who wish to avoid evaluating code on export should use the header
argument `:eval never-export'."
:group 'org-babel
:version "24.1"
:type '(choice (const :tag "Never" nil)
(const :tag "Only inline code" inline-only)
(const :tag "Always" t)))
(put 'org-export-babel-evaluate 'safe-local-variable (lambda (x) (eq x nil)))
(put 'org-export-babel-evaluate 'safe-local-variable #'null)
(defun org-babel-exp-get-export-buffer ()
"Return the current export buffer if possible."
(cond
((bufferp org-current-export-file) org-current-export-file)
(org-current-export-file (get-file-buffer org-current-export-file))
('otherwise
(error "Requested export buffer when `org-current-export-file' is nil"))))
(defmacro org-babel-exp--at-source (&rest body)
"Evaluate BODY at the source of the Babel block at point.
Source is located in `org-babel-exp-reference-buffer'. The value
returned is the value of the last form in BODY. Assume that
point is at the beginning of the Babel block."
(declare (indent 1) (debug body))
`(let ((source (get-text-property (point) 'org-reference)))
(with-current-buffer org-babel-exp-reference-buffer
(org-with-wide-buffer
(goto-char source)
,@body))))
(defvar org-link-search-inhibit-query)
(defmacro org-babel-exp-in-export-file (lang &rest body)
(declare (indent 1))
`(let* ((lang-headers (intern (concat "org-babel-default-header-args:" ,lang)))
(heading (nth 4 (ignore-errors (org-heading-components))))
(export-buffer (current-buffer))
(original-buffer (org-babel-exp-get-export-buffer)) results)
(when original-buffer
;; resolve parameters in the original file so that
;; headline and file-wide parameters are included, attempt
;; to go to the same heading in the original file
(set-buffer original-buffer)
(save-restriction
(when heading
(condition-case nil
(let ((org-link-search-inhibit-query t))
(org-link-search heading))
(error (when heading
(goto-char (point-min))
(re-search-forward (regexp-quote heading) nil t)))))
(setq results ,@body))
(set-buffer export-buffer)
results)))
(def-edebug-spec org-babel-exp-in-export-file (form body))
(defun org-babel-exp-src-block (&rest headers)
(defun org-babel-exp-src-block ()
"Process source block for export.
Depending on the `export' headers argument, replace the source
Depending on the \":export\" header argument, replace the source
code block like this:
both ---- display the code and the results
@ -107,29 +75,36 @@ code ---- the default, display the code inside the block but do
not process
results - just like none only the block is run on export ensuring
that it's results are present in the org-mode buffer
that its results are present in the Org mode buffer
none ---- do not display either code or results upon export
Assume point is at the beginning of block's starting line."
Assume point is at block opening line."
(interactive)
(unless noninteractive (message "org-babel-exp processing..."))
(save-excursion
(let* ((info (org-babel-get-src-block-info 'light))
(lang (nth 0 info))
(raw-params (nth 2 info)) hash)
(raw-params (nth 2 info))
hash)
;; bail if we couldn't get any info from the block
(unless noninteractive
(message "org-babel-exp process %s at position %d..."
lang
(line-beginning-position)))
(when info
;; if we're actually going to need the parameters
(when (member (cdr (assoc :exports (nth 2 info))) '("both" "results"))
(org-babel-exp-in-export-file lang
(setf (nth 2 info)
(org-babel-process-params
(apply #'org-babel-merge-params
org-babel-default-header-args
(if (boundp lang-headers) (eval lang-headers) nil)
(append (org-babel-params-from-properties lang)
(list raw-params))))))
(when (member (cdr (assq :exports (nth 2 info))) '("both" "results"))
(let ((lang-headers (intern (concat "org-babel-default-header-args:"
lang))))
(org-babel-exp--at-source
(setf (nth 2 info)
(org-babel-process-params
(apply #'org-babel-merge-params
org-babel-default-header-args
(and (boundp lang-headers)
(symbol-value lang-headers))
(append (org-babel-params-from-properties lang)
(list raw-params)))))))
(setf hash (org-babel-sha1-hash info)))
(org-babel-exp-do-export info 'block hash)))))
@ -150,166 +125,180 @@ this template."
:group 'org-babel
:type 'string)
(defvar org-babel-default-lob-header-args)
(defun org-babel-exp-process-buffer ()
"Execute all Babel blocks in current buffer."
(interactive)
(save-window-excursion
(save-excursion
(when org-export-babel-evaluate
(save-window-excursion
(let ((case-fold-search t)
(regexp (concat org-babel-inline-src-block-regexp "\\|"
org-babel-lob-one-liner-regexp "\\|"
"^[ \t]*#\\+BEGIN_SRC")))
(goto-char (point-min))
(while (re-search-forward regexp nil t)
(let* ((element (save-excursion
;; If match is inline, point is at its
;; end. Move backward so
;; `org-element-context' can get the
;; object, not the following one.
(backward-char)
(save-match-data (org-element-context))))
(type (org-element-type element))
(begin (copy-marker (org-element-property :begin element)))
(end (copy-marker
(save-excursion
(goto-char (org-element-property :end element))
(skip-chars-backward " \r\t\n")
(point)))))
(case type
(inline-src-block
(let* ((info (org-babel-parse-inline-src-block-match))
(params (nth 2 info)))
(setf (nth 1 info)
(if (and (cdr (assoc :noweb params))
(string= "yes" (cdr (assoc :noweb params))))
(org-babel-expand-noweb-references
info (org-babel-exp-get-export-buffer))
(nth 1 info)))
(goto-char begin)
(let ((replacement (org-babel-exp-do-export info 'inline)))
(if (equal replacement "")
;; Replacement code is empty: remove inline src
;; block, including extra white space that
;; might have been created when inserting
;; results.
(delete-region begin
(progn (goto-char end)
(skip-chars-forward " \t")
(point)))
;; Otherwise: remove inline src block but
;; preserve following white spaces. Then insert
;; value.
(delete-region begin end)
(insert replacement)))))
((babel-call inline-babel-call)
(let* ((lob-info (org-babel-lob-get-info))
(results
(org-babel-exp-do-export
(list "emacs-lisp" "results"
(apply #'org-babel-merge-params
org-babel-default-header-args
org-babel-default-lob-header-args
(append
(org-babel-params-from-properties)
(list
(org-babel-parse-header-arguments
(org-no-properties
(concat
":var results="
(mapconcat 'identity
(butlast lob-info 2)
" ")))))))
"" (nth 3 lob-info) (nth 2 lob-info))
'lob))
(rep (org-fill-template
org-babel-exp-call-line-template
`(("line" . ,(nth 0 lob-info))))))
;; If replacement is empty, completely remove the
;; object/element, including any extra white space
;; that might have been created when including
;; results.
(if (equal rep "")
(delete-region
begin
(progn (goto-char end)
(if (not (eq type 'babel-call))
(progn (skip-chars-forward " \t") (point))
(skip-chars-forward " \r\t\n")
(line-beginning-position))))
;; Otherwise, preserve following white
;; spaces/newlines and then, insert replacement
;; string.
(goto-char begin)
(delete-region begin end)
(insert rep))))
(src-block
(let* ((match-start (copy-marker (match-beginning 0)))
(ind (org-get-indentation))
(headers
(cons
(org-element-property :language element)
(let ((params (org-element-property :parameters
element)))
(and params (org-split-string params "[ \t]+"))))))
;; Take care of matched block: compute replacement
;; string. In particular, a nil REPLACEMENT means
;; the block should be left as-is while an empty
;; string should remove the block.
(let ((replacement (progn (goto-char match-start)
(org-babel-exp-src-block headers))))
(cond ((not replacement) (goto-char end))
((equal replacement "")
(goto-char end)
(skip-chars-forward " \r\t\n")
(beginning-of-line)
(delete-region begin (point)))
(t
(goto-char match-start)
(delete-region (point)
(save-excursion (goto-char end)
(line-end-position)))
(insert replacement)
(if (or org-src-preserve-indentation
(org-element-property :preserve-indent
element))
;; Indent only the code block markers.
(save-excursion (skip-chars-backward " \r\t\n")
(indent-line-to ind)
(goto-char match-start)
(indent-line-to ind))
;; Indent everything.
(indent-rigidly match-start (point) ind)))))
(set-marker match-start nil))))
(set-marker begin nil)
(set-marker end nil)))))))
(defun org-babel-in-example-or-verbatim ()
"Return true if point is in example or verbatim code.
Example and verbatim code include escaped portions of
an org-mode buffer code that should be treated as normal
org-mode text."
(or (save-match-data
(save-excursion
(goto-char (point-at-bol))
(looking-at "[ \t]*:[ \t]")))
(org-in-verbatim-emphasis)
(org-in-block-p org-list-forbidden-blocks)
(org-between-regexps-p "^[ \t]*#\\+begin_src" "^[ \t]*#\\+end_src")))
(regexp (if (eq org-export-babel-evaluate 'inline-only)
"\\(call\\|src\\)_"
"\\(call\\|src\\)_\\|^[ \t]*#\\+\\(BEGIN_SRC\\|CALL:\\)"))
;; Get a pristine copy of current buffer so Babel
;; references are properly resolved and source block
;; context is preserved.
(org-babel-exp-reference-buffer (org-export-copy-buffer)))
(unwind-protect
(save-excursion
;; First attach to every source block their original
;; position, so that they can be retrieved within
;; `org-babel-exp-reference-buffer', even after heavy
;; modifications on current buffer.
;;
;; False positives are harmless, so we don't check if
;; we're really at some Babel object. Moreover,
;; `line-end-position' ensures that we propertize
;; a noticeable part of the object, without affecting
;; multiple objects on the same line.
(goto-char (point-min))
(while (re-search-forward regexp nil t)
(let ((s (match-beginning 0)))
(put-text-property s (line-end-position) 'org-reference s)))
;; Evaluate from top to bottom every Babel block
;; encountered.
(goto-char (point-min))
(while (re-search-forward regexp nil t)
(unless (save-match-data (org-in-commented-heading-p))
(let* ((object? (match-end 1))
(element (save-match-data
(if object? (org-element-context)
;; No deep inspection if we're
;; just looking for an element.
(org-element-at-point))))
(type
(pcase (org-element-type element)
;; Discard block elements if we're looking
;; for inline objects. False results
;; happen when, e.g., "call_" syntax is
;; located within affiliated keywords:
;;
;; #+name: call_src
;; #+begin_src ...
((and (or `babel-call `src-block) (guard object?))
nil)
(type type)))
(begin
(copy-marker (org-element-property :begin element)))
(end
(copy-marker
(save-excursion
(goto-char (org-element-property :end element))
(skip-chars-backward " \r\t\n")
(point)))))
(pcase type
(`inline-src-block
(let* ((info
(org-babel-get-src-block-info nil element))
(params (nth 2 info)))
(setf (nth 1 info)
(if (and (cdr (assq :noweb params))
(string= "yes"
(cdr (assq :noweb params))))
(org-babel-expand-noweb-references
info org-babel-exp-reference-buffer)
(nth 1 info)))
(goto-char begin)
(let ((replacement
(org-babel-exp-do-export info 'inline)))
(if (equal replacement "")
;; Replacement code is empty: remove
;; inline source block, including extra
;; white space that might have been
;; created when inserting results.
(delete-region begin
(progn (goto-char end)
(skip-chars-forward " \t")
(point)))
;; Otherwise: remove inline src block but
;; preserve following white spaces. Then
;; insert value.
(delete-region begin end)
(insert replacement)))))
((or `babel-call `inline-babel-call)
(org-babel-exp-do-export (org-babel-lob-get-info element)
'lob)
(let ((rep
(org-fill-template
org-babel-exp-call-line-template
`(("line" .
,(org-element-property :value element))))))
;; If replacement is empty, completely remove
;; the object/element, including any extra
;; white space that might have been created
;; when including results.
(if (equal rep "")
(delete-region
begin
(progn (goto-char end)
(if (not (eq type 'babel-call))
(progn (skip-chars-forward " \t")
(point))
(skip-chars-forward " \r\t\n")
(line-beginning-position))))
;; Otherwise, preserve trailing
;; spaces/newlines and then, insert
;; replacement string.
(goto-char begin)
(delete-region begin end)
(insert rep))))
(`src-block
(let ((match-start (copy-marker (match-beginning 0)))
(ind (org-get-indentation)))
;; Take care of matched block: compute
;; replacement string. In particular, a nil
;; REPLACEMENT means the block is left as-is
;; while an empty string removes the block.
(let ((replacement
(progn (goto-char match-start)
(org-babel-exp-src-block))))
(cond ((not replacement) (goto-char end))
((equal replacement "")
(goto-char end)
(skip-chars-forward " \r\t\n")
(beginning-of-line)
(delete-region begin (point)))
(t
(goto-char match-start)
(delete-region (point)
(save-excursion
(goto-char end)
(line-end-position)))
(insert replacement)
(if (or org-src-preserve-indentation
(org-element-property
:preserve-indent element))
;; Indent only code block
;; markers.
(save-excursion
(skip-chars-backward " \r\t\n")
(indent-line-to ind)
(goto-char match-start)
(indent-line-to ind))
;; Indent everything.
(indent-rigidly
match-start (point) ind)))))
(set-marker match-start nil))))
(set-marker begin nil)
(set-marker end nil)))))
(kill-buffer org-babel-exp-reference-buffer)
(remove-text-properties (point-min) (point-max) '(org-reference)))))))
(defun org-babel-exp-do-export (info type &optional hash)
"Return a string with the exported content of a code block.
The function respects the value of the :exports header argument."
(let ((silently (lambda () (let ((session (cdr (assoc :session (nth 2 info)))))
(when (not (and session (equal "none" session)))
(org-babel-exp-results info type 'silent)))))
(clean (lambda () (unless (eq type 'inline) (org-babel-remove-result info)))))
(case (intern (or (cdr (assoc :exports (nth 2 info))) "code"))
('none (funcall silently) (funcall clean) "")
('code (funcall silently) (funcall clean) (org-babel-exp-code info))
('results (org-babel-exp-results info type nil hash) "")
('both (org-babel-exp-results info type nil hash)
(org-babel-exp-code info)))))
(let ((silently (lambda () (let ((session (cdr (assq :session (nth 2 info)))))
(unless (equal "none" session)
(org-babel-exp-results info type 'silent)))))
(clean (lambda () (if (eq type 'inline)
(org-babel-remove-inline-result)
(org-babel-remove-result info)))))
(pcase (or (cdr (assq :exports (nth 2 info))) "code")
("none" (funcall silently) (funcall clean) "")
("code" (funcall silently) (funcall clean) (org-babel-exp-code info type))
("results" (org-babel-exp-results info type nil hash) "")
("both"
(org-babel-exp-results info type nil hash)
(org-babel-exp-code info type)))))
(defcustom org-babel-exp-code-template
"#+BEGIN_SRC %lang%switches%flags\n%body\n#+END_SRC"
@ -331,18 +320,42 @@ replaced with its value."
:group 'org-babel
:type 'string)
(defun org-babel-exp-code (info)
(defcustom org-babel-exp-inline-code-template
"src_%lang[%switches%flags]{%body}"
"Template used to export the body of inline code blocks.
This template may be customized to include additional information
such as the code block name, or the values of particular header
arguments. The template is filled out using `org-fill-template',
and the following %keys may be used.
lang ------ the language of the code block
name ------ the name of the code block
body ------ the body of the code block
switches -- the switches associated to the code block
flags ----- the flags passed to the code block
In addition to the keys mentioned above, every header argument
defined for the code block may be used as a key and will be
replaced with its value."
:group 'org-babel
:type 'string
:version "26.1"
:package-version '(Org . "8.3"))
(defun org-babel-exp-code (info type)
"Return the original code block formatted for export."
(setf (nth 1 info)
(if (string= "strip-export" (cdr (assoc :noweb (nth 2 info))))
(if (string= "strip-export" (cdr (assq :noweb (nth 2 info))))
(replace-regexp-in-string
(org-babel-noweb-wrap) "" (nth 1 info))
(if (org-babel-noweb-p (nth 2 info) :export)
(org-babel-expand-noweb-references
info (org-babel-exp-get-export-buffer))
info org-babel-exp-reference-buffer)
(nth 1 info))))
(org-fill-template
org-babel-exp-code-template
(if (eq type 'inline)
org-babel-exp-inline-code-template
org-babel-exp-code-template)
`(("lang" . ,(nth 0 info))
("body" . ,(org-escape-code-in-string (nth 1 info)))
("switches" . ,(let ((f (nth 3 info)))
@ -357,48 +370,41 @@ replaced with its value."
(defun org-babel-exp-results (info type &optional silent hash)
"Evaluate and return the results of the current code block for export.
Results are prepared in a manner suitable for export by org-mode.
Results are prepared in a manner suitable for export by Org mode.
This function is called by `org-babel-exp-do-export'. The code
block will be evaluated. Optional argument SILENT can be used to
inhibit insertion of results into the buffer."
(when (and (or (eq org-export-babel-evaluate t)
(and (eq type 'inline)
(eq org-export-babel-evaluate 'inline-only)))
(not (and hash (equal hash (org-babel-current-result-hash)))))
(unless (and hash (equal hash (org-babel-current-result-hash)))
(let ((lang (nth 0 info))
(body (if (org-babel-noweb-p (nth 2 info) :eval)
(org-babel-expand-noweb-references
info (org-babel-exp-get-export-buffer))
info org-babel-exp-reference-buffer)
(nth 1 info)))
(info (copy-sequence info))
(org-babel-current-src-block-location (point-marker)))
;; skip code blocks which we can't evaluate
;; Skip code blocks which we can't evaluate.
(when (fboundp (intern (concat "org-babel-execute:" lang)))
(org-babel-eval-wipe-error-buffer)
(prog1 nil
(setf (nth 1 info) body)
(setf (nth 2 info)
(org-babel-exp-in-export-file lang
(org-babel-process-params
(org-babel-merge-params
(nth 2 info)
`((:results . ,(if silent "silent" "replace")))))))
(cond
((equal type 'block)
(setf (nth 1 info) body)
(setf (nth 2 info)
(org-babel-exp--at-source
(org-babel-process-params
(org-babel-merge-params
(nth 2 info)
`((:results . ,(if silent "silent" "replace")))))))
(pcase type
(`block (org-babel-execute-src-block nil info))
(`inline
;; Position the point on the inline source block
;; allowing `org-babel-insert-result' to check that the
;; block is inline.
(goto-char (nth 5 info))
(org-babel-execute-src-block nil info))
((equal type 'inline)
;; position the point on the inline source block allowing
;; `org-babel-insert-result' to check that the block is
;; inline
(re-search-backward "[ \f\t\n\r\v]" nil t)
(re-search-forward org-babel-inline-src-block-regexp nil t)
(re-search-backward "src_" nil t)
(org-babel-execute-src-block nil info))
((equal type 'lob)
(save-excursion
(re-search-backward org-babel-lob-one-liner-regexp nil t)
(let (org-confirm-babel-evaluate)
(org-babel-execute-src-block nil info))))))))))
(`lob
(save-excursion
(goto-char (nth 5 info))
(let (org-confirm-babel-evaluate)
(org-babel-execute-src-block nil info)))))))))
(provide 'ob-exp)

87
lisp/org/ob-forth.el Normal file
View file

@ -0,0 +1,87 @@
;;; ob-forth.el --- Babel Functions for Forth -*- lexical-binding: t; -*-
;; Copyright (C) 2014-2017 Free Software Foundation, Inc.
;; Author: Eric Schulte
;; Keywords: literate programming, reproducible research, forth
;; Homepage: http://orgmode.org
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Requires the gforth forth compiler and `forth-mode' (see below).
;; https://www.gnu.org/software/gforth/
;;; Requirements:
;; Session evaluation requires the gforth forth compiler as well as
;; `forth-mode' which is distributed with gforth (in gforth.el).
;;; Code:
(require 'ob)
(declare-function forth-proc "ext:gforth" ())
(declare-function org-trim "org" (s &optional keep-lead))
(defvar org-babel-default-header-args:forth '((:session . "yes"))
"Default header arguments for forth code blocks.")
(defun org-babel-execute:forth (body params)
"Execute a block of Forth code with org-babel.
This function is called by `org-babel-execute-src-block'"
(if (string= "none" (cdr (assq :session params)))
(error "Non-session evaluation not supported for Forth code blocks")
(let ((all-results (org-babel-forth-session-execute body params)))
(if (member "output" (cdr (assq :result-params params)))
(mapconcat #'identity all-results "\n")
(car (last all-results))))))
(defun org-babel-forth-session-execute (body params)
(require 'forth-mode)
(let ((proc (forth-proc))
(rx " \\(\n:\\|compiled\n\\\|ok\n\\)")
(result-start))
(with-current-buffer (process-buffer (forth-proc))
(mapcar (lambda (line)
(setq result-start (progn (goto-char (process-mark proc))
(point)))
(comint-send-string proc (concat line "\n"))
;; wait for forth to say "ok"
(while (not (progn (goto-char result-start)
(re-search-forward rx nil t)))
(accept-process-output proc 0.01))
(let ((case (match-string 1)))
(cond
((string= "ok\n" case)
;; Collect intermediate output.
(buffer-substring (+ result-start 1 (length line))
(match-beginning 0)))
((string= "compiled\n" case))
;; Ignore partial compilation.
((string= "\n:" case)
;; Report errors.
(org-babel-eval-error-notify 1
(buffer-substring
(+ (match-beginning 0) 1) (point-max))) nil))))
(split-string (org-trim
(org-babel-expand-body:generic body params))
"\n"
'omit-nulls)))))
(provide 'ob-forth)
;;; ob-forth.el ends here

61
lisp/org/ob-fortran.el
View file

@ -1,4 +1,4 @@
;;; ob-fortran.el --- org-babel functions for fortran
;;; ob-fortran.el --- Babel Functions for Fortran -*- lexical-binding: t; -*-
;; Copyright (C) 2011-2017 Free Software Foundation, Inc.
@ -29,10 +29,12 @@
;;; Code:
(require 'ob)
(require 'cc-mode)
(require 'cl-lib)
(declare-function org-entry-get "org"
(pom property &optional inherit literal-nil))
(declare-function org-every "org" (pred seq))
(declare-function org-remove-indentation "org" (code &optional n))
(declare-function org-trim "org" (s &optional keep-lead))
(defvar org-babel-tangle-lang-exts)
(add-to-list 'org-babel-tangle-lang-exts '("fortran" . "F90"))
@ -47,43 +49,42 @@
"This function should only be called by `org-babel-execute:fortran'"
(let* ((tmp-src-file (org-babel-temp-file "fortran-src-" ".F90"))
(tmp-bin-file (org-babel-temp-file "fortran-bin-" org-babel-exeext))
(cmdline (cdr (assoc :cmdline params)))
(flags (cdr (assoc :flags params)))
(full-body (org-babel-expand-body:fortran body params))
(compile
(progn
(with-temp-file tmp-src-file (insert full-body))
(org-babel-eval
(format "%s -o %s %s %s"
org-babel-fortran-compiler
(org-babel-process-file-name tmp-bin-file)
(mapconcat 'identity
(if (listp flags) flags (list flags)) " ")
(org-babel-process-file-name tmp-src-file)) ""))))
(cmdline (cdr (assq :cmdline params)))
(flags (cdr (assq :flags params)))
(full-body (org-babel-expand-body:fortran body params)))
(with-temp-file tmp-src-file (insert full-body))
(org-babel-eval
(format "%s -o %s %s %s"
org-babel-fortran-compiler
(org-babel-process-file-name tmp-bin-file)
(mapconcat 'identity
(if (listp flags) flags (list flags)) " ")
(org-babel-process-file-name tmp-src-file)) "")
(let ((results
(org-babel-trim
(org-babel-eval
(concat tmp-bin-file (if cmdline (concat " " cmdline) "")) ""))))
(org-trim
(org-remove-indentation
(org-babel-eval
(concat tmp-bin-file (if cmdline (concat " " cmdline) "")) "")))))
(org-babel-reassemble-table
(org-babel-result-cond (cdr (assoc :result-params params))
(org-babel-result-cond (cdr (assq :result-params params))
(org-babel-read results)
(let ((tmp-file (org-babel-temp-file "f-")))
(with-temp-file tmp-file (insert results))
(org-babel-import-elisp-from-file tmp-file)))
(org-babel-pick-name
(cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
(cdr (assq :colname-names params)) (cdr (assq :colnames params)))
(org-babel-pick-name
(cdr (assoc :rowname-names params)) (cdr (assoc :rownames params)))))))
(cdr (assq :rowname-names params)) (cdr (assq :rownames params)))))))
(defun org-babel-expand-body:fortran (body params)
"Expand a block of fortran or fortran code with org-babel according to
it's header arguments."
(let ((vars (mapcar #'cdr (org-babel-get-header params :var)))
(main-p (not (string= (cdr (assoc :main params)) "no")))
(includes (or (cdr (assoc :includes params))
its header arguments."
(let ((vars (org-babel--get-vars params))
(main-p (not (string= (cdr (assq :main params)) "no")))
(includes (or (cdr (assq :includes params))
(org-babel-read (org-entry-get nil "includes" t))))
(defines (org-babel-read
(or (cdr (assoc :defines params))
(or (cdr (assq :defines params))
(org-babel-read (org-entry-get nil "defines" t))))))
(mapconcat 'identity
(list
@ -107,17 +108,17 @@ it's header arguments."
(defun org-babel-fortran-ensure-main-wrap (body params)
"Wrap body in a \"program ... end program\" block if none exists."
(if (string-match "^[ \t]*program[ \t]*.*" (capitalize body))
(let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
(let ((vars (org-babel--get-vars params)))
(if vars (error "Cannot use :vars if `program' statement is present"))
body)
(format "program main\n%s\nend program main\n" body)))
(defun org-babel-prep-session:fortran (session params)
(defun org-babel-prep-session:fortran (_session _params)
"This function does nothing as fortran is a compiled language with no
support for sessions"
(error "Fortran is a compiled languages -- no support for sessions"))
(defun org-babel-load-session:fortran (session body params)
(defun org-babel-load-session:fortran (_session _body _params)
"This function does nothing as fortran is a compiled language with no
support for sessions"
(error "Fortran is a compiled languages -- no support for sessions"))
@ -145,7 +146,7 @@ of the same value."
(format "character(len=%d), parameter :: %S = '%s'\n"
(length val) var val))
;; val is a matrix
((and (listp val) (org-every #'listp val))
((and (listp val) (cl-every #'listp val))
(format "real, parameter :: %S(%d,%d) = transpose( reshape( %s , (/ %d, %d /) ) )\n"
var (length val) (length (car val))
(org-babel-fortran-transform-list val)

76
lisp/org/ob-gnuplot.el
View file

@ -1,4 +1,4 @@
;;; ob-gnuplot.el --- org-babel functions for gnuplot evaluation
;;; ob-gnuplot.el --- Babel Functions for Gnuplot -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -39,12 +39,10 @@
;;; Code:
(require 'ob)
(eval-when-compile (require 'cl))
(declare-function org-time-string-to-time "org" (s &optional buffer pos))
(declare-function org-combine-plists "org" (&rest plists))
(declare-function orgtbl-to-generic "org-table"
(table params &optional backend))
(declare-function orgtbl-to-generic "org-table" (table params))
(declare-function gnuplot-mode "ext:gnuplot-mode" ())
(declare-function gnuplot-send-string-to-gnuplot "ext:gnuplot-mode" (str txt))
(declare-function gnuplot-send-buffer-to-gnuplot "ext:gnuplot-mode" ())
@ -65,7 +63,7 @@
(term . :any))
"Gnuplot specific header args.")
(defvar org-babel-gnuplot-timestamp-fmt nil)
(defvar org-babel-gnuplot-timestamp-fmt nil) ; Dynamically scoped.
(defvar *org-babel-gnuplot-missing* nil)
@ -81,7 +79,7 @@
Dumps all vectors into files and returns an association list
of variable names and the related value to be used in the gnuplot
code."
(let ((*org-babel-gnuplot-missing* (cdr (assoc :missing params))))
(let ((*org-babel-gnuplot-missing* (cdr (assq :missing params))))
(mapcar
(lambda (pair)
(cons
@ -95,38 +93,33 @@ code."
(if tablep val (mapcar 'list val)))
(org-babel-temp-file "gnuplot-") params)
val))))
(mapcar #'cdr (org-babel-get-header params :var)))))
(org-babel--get-vars params))))
(defun org-babel-expand-body:gnuplot (body params)
"Expand BODY according to PARAMS, return the expanded body."
(save-window-excursion
(let* ((vars (org-babel-gnuplot-process-vars params))
(out-file (cdr (assoc :file params)))
(prologue (cdr (assoc :prologue params)))
(epilogue (cdr (assoc :epilogue params)))
(term (or (cdr (assoc :term params))
(out-file (cdr (assq :file params)))
(prologue (cdr (assq :prologue params)))
(epilogue (cdr (assq :epilogue params)))
(term (or (cdr (assq :term params))
(when out-file
(let ((ext (file-name-extension out-file)))
(or (cdr (assoc (intern (downcase ext))
*org-babel-gnuplot-terms*))
ext)))))
(cmdline (cdr (assoc :cmdline params)))
(title (cdr (assoc :title params)))
(lines (cdr (assoc :line params)))
(sets (cdr (assoc :set params)))
(x-labels (cdr (assoc :xlabels params)))
(y-labels (cdr (assoc :ylabels params)))
(timefmt (cdr (assoc :timefmt params)))
(time-ind (or (cdr (assoc :timeind params))
(title (cdr (assq :title params)))
(lines (cdr (assq :line params)))
(sets (cdr (assq :set params)))
(x-labels (cdr (assq :xlabels params)))
(y-labels (cdr (assq :ylabels params)))
(timefmt (cdr (assq :timefmt params)))
(time-ind (or (cdr (assq :timeind params))
(when timefmt 1)))
(missing (cdr (assoc :missing params)))
(add-to-body (lambda (text) (setq body (concat text "\n" body))))
output)
(add-to-body (lambda (text) (setq body (concat text "\n" body)))))
;; append header argument settings to body
(when title (funcall add-to-body (format "set title '%s'" title)))
(when lines (mapc (lambda (el) (funcall add-to-body el)) lines))
(when missing
(funcall add-to-body (format "set datafile missing '%s'" missing)))
(when sets
(mapc (lambda (el) (funcall add-to-body (format "set %s" el))) sets))
(when x-labels
@ -175,9 +168,8 @@ code."
"Execute a block of Gnuplot code.
This function is called by `org-babel-execute-src-block'."
(require 'gnuplot)
(let ((session (cdr (assoc :session params)))
(result-type (cdr (assoc :results params)))
(out-file (cdr (assoc :file params)))
(let ((session (cdr (assq :session params)))
(result-type (cdr (assq :results params)))
(body (org-babel-expand-body:gnuplot body params))
output)
(save-window-excursion
@ -195,7 +187,7 @@ This function is called by `org-babel-execute-src-block'."
script-file
(if (member system-type '(cygwin windows-nt ms-dos))
t nil)))))
(message output))
(message "%s" output))
(with-temp-buffer
(insert (concat body "\n"))
(gnuplot-mode)
@ -210,10 +202,12 @@ This function is called by `org-babel-execute-src-block'."
(var-lines (org-babel-variable-assignments:gnuplot params)))
(message "%S" session)
(org-babel-comint-in-buffer session
(mapc (lambda (var-line)
(insert var-line) (comint-send-input nil t)
(org-babel-comint-wait-for-output session)
(sit-for .1) (goto-char (point-max))) var-lines))
(dolist (var-line var-lines)
(insert var-line)
(comint-send-input nil t)
(org-babel-comint-wait-for-output session)
(sit-for .1)
(goto-char (point-max))))
session))
(defun org-babel-load-session:gnuplot (session body params)
@ -232,7 +226,7 @@ This function is called by `org-babel-execute-src-block'."
(org-babel-gnuplot-process-vars params)))
(defvar gnuplot-buffer)
(defun org-babel-gnuplot-initiate-session (&optional session params)
(defun org-babel-gnuplot-initiate-session (&optional session _params)
"Initiate a gnuplot session.
If there is not a current inferior-process-buffer in SESSION
then create one. Return the initialized session. The current
@ -268,15 +262,13 @@ then create one. Return the initialized session. The current
"Export TABLE to DATA-FILE in a format readable by gnuplot.
Pass PARAMS through to `orgtbl-to-generic' when exporting TABLE."
(with-temp-file data-file
(make-local-variable 'org-babel-gnuplot-timestamp-fmt)
(setq org-babel-gnuplot-timestamp-fmt (or
(plist-get params :timefmt)
"%Y-%m-%d-%H:%M:%S"))
(insert (orgtbl-to-generic
table
(org-combine-plists
'(:sep "\t" :fmt org-babel-gnuplot-quote-tsv-field)
params))))
(insert (let ((org-babel-gnuplot-timestamp-fmt
(or (plist-get params :timefmt) "%Y-%m-%d-%H:%M:%S")))
(orgtbl-to-generic
table
(org-combine-plists
'(:sep "\t" :fmt org-babel-gnuplot-quote-tsv-field)
params)))))
data-file)
(provide 'ob-gnuplot)

116
lisp/org/ob-groovy.el Normal file
View file

@ -0,0 +1,116 @@
;;; ob-groovy.el --- Babel Functions for Groovy -*- lexical-binding: t; -*-
;; Copyright (C) 2013-2017 Free Software Foundation, Inc.
;; Author: Miro Bezjak
;; Keywords: literate programming, reproducible research
;; Homepage: http://orgmode.org
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Currently only supports the external execution. No session support yet.
;;; Requirements:
;; - Groovy language :: http://groovy.codehaus.org
;; - Groovy major mode :: Can be installed from MELPA or
;; https://github.com/russel/Emacs-Groovy-Mode
;;; Code:
(require 'ob)
(defvar org-babel-tangle-lang-exts) ;; Autoloaded
(add-to-list 'org-babel-tangle-lang-exts '("groovy" . "groovy"))
(defvar org-babel-default-header-args:groovy '())
(defcustom org-babel-groovy-command "groovy"
"Name of the command to use for executing Groovy code.
May be either a command in the path, like groovy
or an absolute path name, like /usr/local/bin/groovy
parameters may be used, like groovy -v"
:group 'org-babel
:version "24.3"
:type 'string)
(defun org-babel-execute:groovy (body params)
"Execute a block of Groovy code with org-babel. This function is
called by `org-babel-execute-src-block'"
(message "executing Groovy source code block")
(let* ((processed-params (org-babel-process-params params))
(session (org-babel-groovy-initiate-session (nth 0 processed-params)))
(result-params (nth 2 processed-params))
(result-type (cdr (assq :result-type params)))
(full-body (org-babel-expand-body:generic
body params))
(result (org-babel-groovy-evaluate
session full-body result-type result-params)))
(org-babel-reassemble-table
result
(org-babel-pick-name
(cdr (assq :colname-names params)) (cdr (assq :colnames params)))
(org-babel-pick-name
(cdr (assq :rowname-names params)) (cdr (assq :rownames params))))))
(defvar org-babel-groovy-wrapper-method
"class Runner extends Script {
def out = new PrintWriter(new ByteArrayOutputStream())
def run() { %s }
}
println(new Runner().run())
")
(defun org-babel-groovy-evaluate
(session body &optional result-type result-params)
"Evaluate BODY in external Groovy process.
If RESULT-TYPE equals `output' then return standard output as a string.
If RESULT-TYPE equals `value' then return the value of the last statement
in BODY as elisp."
(when session (error "Sessions are not (yet) supported for Groovy"))
(pcase result-type
(`output
(let ((src-file (org-babel-temp-file "groovy-")))
(progn (with-temp-file src-file (insert body))
(org-babel-eval
(concat org-babel-groovy-command " " src-file) ""))))
(`value
(let* ((src-file (org-babel-temp-file "groovy-"))
(wrapper (format org-babel-groovy-wrapper-method body)))
(with-temp-file src-file (insert wrapper))
(let ((raw (org-babel-eval
(concat org-babel-groovy-command " " src-file) "")))
(org-babel-result-cond result-params
raw
(org-babel-script-escape raw)))))))
(defun org-babel-prep-session:groovy (_session _params)
"Prepare SESSION according to the header arguments specified in PARAMS."
(error "Sessions are not (yet) supported for Groovy"))
(defun org-babel-groovy-initiate-session (&optional _session)
"If there is not a current inferior-process-buffer in SESSION
then create. Return the initialized session. Sessions are not
supported in Groovy."
nil)
(provide 'ob-groovy)
;;; ob-groovy.el ends here

55
lisp/org/ob-haskell.el
View file

@ -1,4 +1,4 @@
;;; ob-haskell.el --- org-babel functions for haskell evaluation
;;; ob-haskell.el --- Babel Functions for Haskell -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -41,9 +41,9 @@
;;; Code:
(require 'ob)
(require 'comint)
(eval-when-compile (require 'cl))
(declare-function org-remove-indentation "org" (code &optional n))
(declare-function org-trim "org" (s &optional keep-lead))
(declare-function haskell-mode "ext:haskell-mode" ())
(declare-function run-haskell "ext:inf-haskell" (&optional arg))
(declare-function inferior-haskell-load-file
@ -61,42 +61,35 @@
(defun org-babel-execute:haskell (body params)
"Execute a block of Haskell code."
(let* ((session (cdr (assoc :session params)))
(vars (mapcar #'cdr (org-babel-get-header params :var)))
(result-type (cdr (assoc :result-type params)))
(let* ((session (cdr (assq :session params)))
(result-type (cdr (assq :result-type params)))
(full-body (org-babel-expand-body:generic
body params
(org-babel-variable-assignments:haskell params)))
(session (org-babel-haskell-initiate-session session params))
(raw (org-babel-comint-with-output
(session org-babel-haskell-eoe t full-body)
(insert (org-babel-trim full-body))
(insert (org-trim full-body))
(comint-send-input nil t)
(insert org-babel-haskell-eoe)
(comint-send-input nil t)))
(results (mapcar
#'org-babel-haskell-read-string
#'org-babel-strip-quotes
(cdr (member org-babel-haskell-eoe
(reverse (mapcar #'org-babel-trim raw)))))))
(reverse (mapcar #'org-trim raw)))))))
(org-babel-reassemble-table
(let ((result
(case result-type
(output (mapconcat #'identity (reverse (cdr results)) "\n"))
(value (car results)))))
(org-babel-result-cond (cdr (assoc :result-params params))
result (org-babel-haskell-table-or-string result)))
(org-babel-pick-name (cdr (assoc :colname-names params))
(cdr (assoc :colname-names params)))
(org-babel-pick-name (cdr (assoc :rowname-names params))
(cdr (assoc :rowname-names params))))))
(pcase result-type
(`output (mapconcat #'identity (reverse (cdr results)) "\n"))
(`value (car results)))))
(org-babel-result-cond (cdr (assq :result-params params))
result (org-babel-script-escape result)))
(org-babel-pick-name (cdr (assq :colname-names params))
(cdr (assq :colname-names params)))
(org-babel-pick-name (cdr (assq :rowname-names params))
(cdr (assq :rowname-names params))))))
(defun org-babel-haskell-read-string (string)
"Strip \\\"s from around a haskell string."
(if (string-match "^\"\\([^\000]+\\)\"$" string)
(match-string 1 string)
string))
(defun org-babel-haskell-initiate-session (&optional session params)
(defun org-babel-haskell-initiate-session (&optional _session _params)
"Initiate a haskell session.
If there is not a current inferior-process-buffer in SESSION
then create one. Return the initialized session."
@ -131,13 +124,7 @@ then create one. Return the initialized session."
(format "let %s = %s"
(car pair)
(org-babel-haskell-var-to-haskell (cdr pair))))
(mapcar #'cdr (org-babel-get-header params :var))))
(defun org-babel-haskell-table-or-string (results)
"Convert RESULTS to an Emacs-lisp table or string.
If RESULTS look like a table, then convert them into an
Emacs-lisp table, otherwise return the results as a string."
(org-babel-script-escape results))
(org-babel--get-vars params)))
(defun org-babel-haskell-var-to-haskell (var)
"Convert an elisp value VAR into a haskell variable.
@ -157,7 +144,7 @@ specifying a variable of the same value."
When called with a prefix argument the resulting
.lhs file will be exported to a .tex file. This function will
create two new files, base-name.lhs and base-name.tex where
base-name is the name of the current org-mode file.
base-name is the name of the current Org file.
Note that all standard Babel literate programming
constructs (header arguments, no-web syntax etc...) are ignored."
@ -185,12 +172,12 @@ constructs (header arguments, no-web syntax etc...) are ignored."
(save-match-data (setq indentation (length (match-string 1))))
(replace-match (save-match-data
(concat
"#+begin_latex\n\\begin{code}\n"
"#+begin_export latex\n\\begin{code}\n"
(if (or preserve-indentp
(string-match "-i" (match-string 2)))
(match-string 3)
(org-remove-indentation (match-string 3)))
"\n\\end{code}\n#+end_latex\n"))
"\n\\end{code}\n#+end_export\n"))
t t)
(indent-code-rigidly (match-beginning 0) (match-end 0) indentation)))
(save-excursion

46
lisp/org/ob-io.el
View file

@ -1,4 +1,4 @@
;;; ob-io.el --- org-babel functions for Io evaluation
;;; ob-io.el --- Babel Functions for Io -*- lexical-binding: t; -*-
;; Copyright (C) 2012-2017 Free Software Foundation, Inc.
@ -33,7 +33,6 @@
;;; Code:
(require 'ob)
(eval-when-compile (require 'cl))
(defvar org-babel-tangle-lang-exts) ;; Autoloaded
(add-to-list 'org-babel-tangle-lang-exts '("io" . "io"))
@ -47,9 +46,8 @@ called by `org-babel-execute-src-block'"
(message "executing Io source code block")
(let* ((processed-params (org-babel-process-params params))
(session (org-babel-io-initiate-session (nth 0 processed-params)))
(vars (nth 1 processed-params))
(result-params (nth 2 processed-params))
(result-type (cdr (assoc :result-type params)))
(result-type (cdr (assq :result-type params)))
(full-body (org-babel-expand-body:generic
body params))
(result (org-babel-io-evaluate
@ -58,17 +56,9 @@ called by `org-babel-execute-src-block'"
(org-babel-reassemble-table
result
(org-babel-pick-name
(cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
(cdr (assq :colname-names params)) (cdr (assq :colnames params)))
(org-babel-pick-name
(cdr (assoc :rowname-names params)) (cdr (assoc :rownames params))))))
(defun org-babel-io-table-or-string (results)
"Convert RESULTS into an appropriate elisp value.
If RESULTS look like a table, then convert them into an
Emacs-lisp table, otherwise return the results as a string."
(org-babel-script-escape results))
(cdr (assq :rowname-names params)) (cdr (assq :rownames params))))))
(defvar org-babel-io-wrapper-method
"(
@ -79,33 +69,33 @@ Emacs-lisp table, otherwise return the results as a string."
(defun org-babel-io-evaluate (session body &optional result-type result-params)
"Evaluate BODY in external Io process.
If RESULT-TYPE equals 'output then return standard output as a string.
If RESULT-TYPE equals 'value then return the value of the last statement
If RESULT-TYPE equals `output' then return standard output as a string.
If RESULT-TYPE equals `value' then return the value of the last statement
in BODY as elisp."
(when session (error "Sessions are not (yet) supported for Io"))
(case result-type
(output
(pcase result-type
(`output
(if (member "repl" result-params)
(org-babel-eval org-babel-io-command body)
(let ((src-file (org-babel-temp-file "io-")))
(progn (with-temp-file src-file (insert body))
(org-babel-eval
(concat org-babel-io-command " " src-file) "")))))
(value (let* ((src-file (org-babel-temp-file "io-"))
(wrapper (format org-babel-io-wrapper-method body)))
(with-temp-file src-file (insert wrapper))
(let ((raw (org-babel-eval
(concat org-babel-io-command " " src-file) "")))
(org-babel-result-cond result-params
raw
(org-babel-io-table-or-string raw)))))))
(`value (let* ((src-file (org-babel-temp-file "io-"))
(wrapper (format org-babel-io-wrapper-method body)))
(with-temp-file src-file (insert wrapper))
(let ((raw (org-babel-eval
(concat org-babel-io-command " " src-file) "")))
(org-babel-result-cond result-params
raw
(org-babel-script-escape raw)))))))
(defun org-babel-prep-session:io (session params)
(defun org-babel-prep-session:io (_session _params)
"Prepare SESSION according to the header arguments specified in PARAMS."
(error "Sessions are not (yet) supported for Io"))
(defun org-babel-io-initiate-session (&optional session)
(defun org-babel-io-initiate-session (&optional _session)
"If there is not a current inferior-process-buffer in SESSION
then create. Return the initialized session. Sessions are not
supported in Io."

44
lisp/org/ob-java.el
View file

@ -1,4 +1,4 @@
;;; ob-java.el --- org-babel functions for java evaluation
;;; ob-java.el --- Babel Functions for Java -*- lexical-binding: t; -*-
;; Copyright (C) 2011-2017 Free Software Foundation, Inc.
@ -32,41 +32,51 @@
(defvar org-babel-tangle-lang-exts)
(add-to-list 'org-babel-tangle-lang-exts '("java" . "java"))
(defvar org-babel-java-command "java"
"Name of the java command.")
(defcustom org-babel-java-command "java"
"Name of the java command.
May be either a command in the path, like java
or an absolute path name, like /usr/local/bin/java
parameters may be used, like java -verbose"
:group 'org-babel
:version "24.3"
:type 'string)
(defvar org-babel-java-compiler "javac"
"Name of the java compiler.")
(defcustom org-babel-java-compiler "javac"
"Name of the java compiler.
May be either a command in the path, like javac
or an absolute path name, like /usr/local/bin/javac
parameters may be used, like javac -verbose"
:group 'org-babel
:version "24.3"
:type 'string)
(defun org-babel-execute:java (body params)
(let* ((classname (or (cdr (assoc :classname params))
(let* ((classname (or (cdr (assq :classname params))
(error
"Can't compile a java block without a classname")))
(packagename (file-name-directory classname))
(src-file (concat classname ".java"))
(cmpflag (or (cdr (assoc :cmpflag params)) ""))
(cmdline (or (cdr (assoc :cmdline params)) ""))
(full-body (org-babel-expand-body:generic body params))
(compile
(progn (with-temp-file src-file (insert full-body))
(org-babel-eval
(concat org-babel-java-compiler
" " cmpflag " " src-file) ""))))
(cmpflag (or (cdr (assq :cmpflag params)) ""))
(cmdline (or (cdr (assq :cmdline params)) ""))
(full-body (org-babel-expand-body:generic body params)))
(with-temp-file src-file (insert full-body))
(org-babel-eval
(concat org-babel-java-compiler " " cmpflag " " src-file) "")
;; created package-name directories if missing
(unless (or (not packagename) (file-exists-p packagename))
(make-directory packagename 'parents))
(let ((results (org-babel-eval (concat org-babel-java-command
" " cmdline " " classname) "")))
(org-babel-reassemble-table
(org-babel-result-cond (cdr (assoc :result-params params))
(org-babel-result-cond (cdr (assq :result-params params))
(org-babel-read results)
(let ((tmp-file (org-babel-temp-file "c-")))
(with-temp-file tmp-file (insert results))
(org-babel-import-elisp-from-file tmp-file)))
(org-babel-pick-name
(cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
(cdr (assq :colname-names params)) (cdr (assq :colnames params)))
(org-babel-pick-name
(cdr (assoc :rowname-names params)) (cdr (assoc :rownames params)))))))
(cdr (assq :rowname-names params)) (cdr (assq :rownames params)))))))
(provide 'ob-java)

28
lisp/org/ob-js.el
View file

@ -1,4 +1,4 @@
;;; ob-js.el --- org-babel functions for Javascript
;;; ob-js.el --- Babel Functions for Javascript -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
@ -39,7 +39,6 @@
;;; Code:
(require 'ob)
(eval-when-compile (require 'cl))
(declare-function run-mozilla "ext:moz" (arg))
@ -56,20 +55,20 @@
:type 'string)
(defvar org-babel-js-function-wrapper
"require('sys').print(require('sys').inspect(function(){%s}()));"
"require('sys').print(require('sys').inspect(function(){\n%s\n}()));"
"Javascript code to print value of body.")
(defun org-babel-execute:js (body params)
"Execute a block of Javascript code with org-babel.
This function is called by `org-babel-execute-src-block'"
(let* ((org-babel-js-cmd (or (cdr (assoc :cmd params)) org-babel-js-cmd))
(result-type (cdr (assoc :result-type params)))
(let* ((org-babel-js-cmd (or (cdr (assq :cmd params)) org-babel-js-cmd))
(result-type (cdr (assq :result-type params)))
(full-body (org-babel-expand-body:generic
body params (org-babel-variable-assignments:js params)))
(result (if (not (string= (cdr (assoc :session params)) "none"))
(result (if (not (string= (cdr (assq :session params)) "none"))
;; session evaluation
(let ((session (org-babel-prep-session:js
(cdr (assoc :session params)) params)))
(cdr (assq :session params)) params)))
(nth 1
(org-babel-comint-with-output
(session (format "%S" org-babel-js-eoe) t body)
@ -89,7 +88,7 @@ This function is called by `org-babel-execute-src-block'"
(org-babel-eval
(format "%s %s" org-babel-js-cmd
(org-babel-process-file-name script-file)) "")))))
(org-babel-result-cond (cdr (assoc :result-params params))
(org-babel-result-cond (cdr (assq :result-params params))
result (org-babel-js-read result))))
(defun org-babel-js-read (results)
@ -97,14 +96,17 @@ This function is called by `org-babel-execute-src-block'"
If RESULTS look like a table, then convert them into an
Emacs-lisp table, otherwise return the results as a string."
(org-babel-read
(if (and (stringp results) (string-match "^\\[.+\\]$" results))
(if (and (stringp results)
(string-prefix-p "[" results)
(string-suffix-p "]" results))
(org-babel-read
(concat "'"
(replace-regexp-in-string
"\\[" "(" (replace-regexp-in-string
"\\]" ")" (replace-regexp-in-string
", " " " (replace-regexp-in-string
"'" "\"" results))))))
",[[:space:]]" " "
(replace-regexp-in-string
"'" "\"" results))))))
results)))
(defun org-babel-js-var-to-js (var)
@ -113,7 +115,7 @@ Convert an elisp value into a string of js source code
specifying a variable of the same value."
(if (listp var)
(concat "[" (mapconcat #'org-babel-js-var-to-js var ", ") "]")
(format "%S" var)))
(replace-regexp-in-string "\n" "\\\\n" (format "%S" var))))
(defun org-babel-prep-session:js (session params)
"Prepare SESSION according to the header arguments specified in PARAMS."
@ -133,7 +135,7 @@ specifying a variable of the same value."
(mapcar
(lambda (pair) (format "var %s=%s;"
(car pair) (org-babel-js-var-to-js (cdr pair))))
(mapcar #'cdr (org-babel-get-header params :var))))
(org-babel--get-vars params)))
(defun org-babel-js-initiate-session (&optional session)
"If there is not a current inferior-process-buffer in SESSION

7
lisp/org/ob-keys.el
View file

@ -1,4 +1,4 @@
;;; ob-keys.el --- key bindings for org-babel
;;; ob-keys.el --- Key Bindings for Babel -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -23,8 +23,8 @@
;;; Commentary:
;; Add org-babel keybindings to the org-mode keymap for exposing
;; org-babel functions. These will all share a common prefix. See
;; Add Org Babel keybindings to the Org mode keymap for exposing
;; Org Babel functions. These will all share a common prefix. See
;; the value of `org-babel-key-bindings' for a list of interactive
;; functions and their associated keys.
@ -89,6 +89,7 @@ functions which are assigned key bindings, and see
("h" . org-babel-describe-bindings)
("\C-x" . org-babel-do-key-sequence-in-edit-buffer)
("x" . org-babel-do-key-sequence-in-edit-buffer)
("k" . org-babel-remove-result-one-or-many)
("\C-\M-h" . org-babel-mark-block))
"Alist of key bindings and interactive Babel functions.
This list associates interactive Babel functions

159
lisp/org/ob-latex.el
View file

@ -1,4 +1,4 @@
;;; ob-latex.el --- org-babel functions for latex "evaluation"
;;; ob-latex.el --- Babel Functions for LaTeX -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -32,12 +32,11 @@
;;; Code:
(require 'ob)
(declare-function org-create-formula-image "org"
(string tofile options buffer &optional type))
(declare-function org-splice-latex-header "org"
(tpl def-pkg pkg snippets-p &optional extra))
(declare-function org-latex-guess-inputenc "ox-latex" (header))
(declare-function org-create-formula-image "org" (string tofile options buffer &optional type))
(declare-function org-latex-compile "ox-latex" (texfile &optional snippet))
(declare-function org-latex-guess-inputenc "ox-latex" (header))
(declare-function org-splice-latex-header "org" (tpl def-pkg pkg snippets-p &optional extra))
(declare-function org-trim "org" (s &optional keep-lead))
(defvar org-babel-tangle-lang-exts)
(add-to-list 'org-babel-tangle-lang-exts '("latex" . "tex"))
@ -51,7 +50,22 @@
'((:results . "latex") (:exports . "results"))
"Default arguments to use when evaluating a LaTeX source block.")
(defcustom org-babel-latex-htlatex ""
(defconst org-babel-header-args:latex
'((border . :any)
(fit . :any)
(imagemagick . ((nil t)))
(iminoptions . :any)
(imoutoptions . :any)
(packages . :any)
(pdfheight . :any)
(pdfpng . :any)
(pdfwidth . :any)
(headers . :any)
(packages . :any)
(buffer . ((yes no))))
"LaTeX-specific header arguments.")
(defcustom org-babel-latex-htlatex "htlatex"
"The htlatex command to enable conversion of latex to SVG or HTML."
:group 'org-babel
:type 'string)
@ -70,37 +84,82 @@
(regexp-quote (format "%S" (car pair)))
(if (stringp (cdr pair))
(cdr pair) (format "%S" (cdr pair)))
body))) (mapcar #'cdr (org-babel-get-header params :var)))
(org-babel-trim body))
body))) (org-babel--get-vars params))
(org-trim body))
(defun org-babel-execute:latex (body params)
"Execute a block of Latex code with Babel.
This function is called by `org-babel-execute-src-block'."
(setq body (org-babel-expand-body:latex body params))
(if (cdr (assoc :file params))
(let* ((out-file (cdr (assoc :file params)))
(if (cdr (assq :file params))
(let* ((out-file (cdr (assq :file params)))
(extension (file-name-extension out-file))
(tex-file (org-babel-temp-file "latex-" ".tex"))
(border (cdr (assoc :border params)))
(imagemagick (cdr (assoc :imagemagick params)))
(im-in-options (cdr (assoc :iminoptions params)))
(im-out-options (cdr (assoc :imoutoptions params)))
(pdfpng (cdr (assoc :pdfpng params)))
(fit (or (cdr (assoc :fit params)) border))
(height (and fit (cdr (assoc :pdfheight params))))
(width (and fit (cdr (assoc :pdfwidth params))))
(headers (cdr (assoc :headers params)))
(in-buffer (not (string= "no" (cdr (assoc :buffer params)))))
(border (cdr (assq :border params)))
(imagemagick (cdr (assq :imagemagick params)))
(im-in-options (cdr (assq :iminoptions params)))
(im-out-options (cdr (assq :imoutoptions params)))
(fit (or (cdr (assq :fit params)) border))
(height (and fit (cdr (assq :pdfheight params))))
(width (and fit (cdr (assq :pdfwidth params))))
(headers (cdr (assq :headers params)))
(in-buffer (not (string= "no" (cdr (assq :buffer params)))))
(org-latex-packages-alist
(append (cdr (assoc :packages params)) org-latex-packages-alist)))
(append (cdr (assq :packages params)) org-latex-packages-alist)))
(cond
((and (string-match "\\.png$" out-file) (not imagemagick))
((and (string-suffix-p ".png" out-file) (not imagemagick))
(org-create-formula-image
body out-file org-format-latex-options in-buffer))
((string-match "\\.tikz$" out-file)
((string-suffix-p ".tikz" out-file)
(when (file-exists-p out-file) (delete-file out-file))
(with-temp-file out-file
(insert body)))
((or (string-match "\\.pdf$" out-file) imagemagick)
((and (or (string= "svg" extension)
(string= "html" extension))
(executable-find org-babel-latex-htlatex))
;; TODO: this is a very different way of generating the
;; frame latex document than in the pdf case. Ideally, both
;; would be unified. This would prevent bugs creeping in
;; such as the one fixed on Aug 16 2014 whereby :headers was
;; not included in the SVG/HTML case.
(with-temp-file tex-file
(insert (concat
"\\documentclass[preview]{standalone}
\\def\\pgfsysdriver{pgfsys-tex4ht.def}
"
(mapconcat (lambda (pkg)
(concat "\\usepackage" pkg))
org-babel-latex-htlatex-packages
"\n")
(if headers
(concat "\n"
(if (listp headers)
(mapconcat #'identity headers "\n")
headers) "\n")
"")
"\\begin{document}"
body
"\\end{document}")))
(when (file-exists-p out-file) (delete-file out-file))
(let ((default-directory (file-name-directory tex-file)))
(shell-command (format "%s %s" org-babel-latex-htlatex tex-file)))
(cond
((file-exists-p (concat (file-name-sans-extension tex-file) "-1.svg"))
(if (string-suffix-p ".svg" out-file)
(progn
(shell-command "pwd")
(shell-command (format "mv %s %s"
(concat (file-name-sans-extension tex-file) "-1.svg")
out-file)))
(error "SVG file produced but HTML file requested")))
((file-exists-p (concat (file-name-sans-extension tex-file) ".html"))
(if (string-suffix-p ".html" out-file)
(shell-command "mv %s %s"
(concat (file-name-sans-extension tex-file)
".html")
out-file)
(error "HTML file produced but SVG file requested")))))
((or (string= "pdf" extension) imagemagick)
(with-temp-file tex-file
(require 'ox-latex)
(insert
@ -133,54 +192,20 @@ This function is called by `org-babel-execute-src-block'."
(when (file-exists-p out-file) (delete-file out-file))
(let ((transient-pdf-file (org-babel-latex-tex-to-pdf tex-file)))
(cond
((string-match "\\.pdf$" out-file)
((string= "pdf" extension)
(rename-file transient-pdf-file out-file))
(imagemagick
(convert-pdf
(org-babel-latex-convert-pdf
transient-pdf-file out-file im-in-options im-out-options)
(when (file-exists-p transient-pdf-file)
(delete-file transient-pdf-file))))))
((and (or (string-match "\\.svg$" out-file)
(string-match "\\.html$" out-file))
(not (string= "" org-babel-latex-htlatex)))
(with-temp-file tex-file
(insert (concat
"\\documentclass[preview]{standalone}
\\def\\pgfsysdriver{pgfsys-tex4ht.def}
"
(mapconcat (lambda (pkg)
(concat "\\usepackage" pkg))
org-babel-latex-htlatex-packages
"\n")
"\\begin{document}"
body
"\\end{document}")))
(when (file-exists-p out-file) (delete-file out-file))
(let ((default-directory (file-name-directory tex-file)))
(shell-command (format "%s %s" org-babel-latex-htlatex tex-file)))
(cond
((file-exists-p (concat (file-name-sans-extension tex-file) "-1.svg"))
(if (string-match "\\.svg$" out-file)
(progn
(shell-command "pwd")
(shell-command (format "mv %s %s"
(concat (file-name-sans-extension tex-file) "-1.svg")
out-file)))
(error "SVG file produced but HTML file requested.")))
((file-exists-p (concat (file-name-sans-extension tex-file) ".html"))
(if (string-match "\\.html$" out-file)
(shell-command "mv %s %s"
(concat (file-name-sans-extension tex-file)
".html")
out-file)
(error "HTML file produced but SVG file requested.")))))
((string-match "\\.\\([^\\.]+\\)$" out-file)
(error "Can not create %s files, please specify a .png or .pdf file or try the :imagemagick header argument"
(match-string 1 out-file))))
(delete-file transient-pdf-file)))
(t
(error "Can not create %s files, please specify a .png or .pdf file or try the :imagemagick header argument"
extension))))))
nil) ;; signal that output has already been written to file
body))
(defun convert-pdf (pdffile out-file im-in-options im-out-options)
(defun org-babel-latex-convert-pdf (pdffile out-file im-in-options im-out-options)
"Generate a file from a pdf file using imagemagick."
(let ((cmd (concat "convert " im-in-options " " pdffile " "
im-out-options " " out-file)))
@ -192,7 +217,7 @@ This function is called by `org-babel-execute-src-block'."
(require 'ox-latex)
(org-latex-compile file))
(defun org-babel-prep-session:latex (session params)
(defun org-babel-prep-session:latex (_session _params)
"Return an error because LaTeX doesn't support sessions."
(error "LaTeX does not support sessions"))

7
lisp/org/ob-ledger.el
View file

@ -1,4 +1,4 @@
;;; ob-ledger.el --- org-babel functions for ledger evaluation
;;; ob-ledger.el --- Babel Functions for Ledger -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
@ -46,8 +46,7 @@
"Execute a block of Ledger entries with org-babel. This function is
called by `org-babel-execute-src-block'."
(message "executing Ledger source code block")
(let ((result-params (split-string (or (cdr (assoc :results params)) "")))
(cmdline (cdr (assoc :cmdline params)))
(let ((cmdline (cdr (assq :cmdline params)))
(in-file (org-babel-temp-file "ledger-"))
(out-file (org-babel-temp-file "ledger-output-")))
(with-temp-file in-file (insert body))
@ -61,7 +60,7 @@ called by `org-babel-execute-src-block'."
" > " (org-babel-process-file-name out-file))))
(with-temp-buffer (insert-file-contents out-file) (buffer-string))))
(defun org-babel-prep-session:ledger (session params)
(defun org-babel-prep-session:ledger (_session _params)
(error "Ledger does not support sessions"))
(provide 'ob-ledger)

186
lisp/org/ob-lilypond.el
View file

@ -1,4 +1,4 @@
;;; ob-lilypond.el --- org-babel functions for lilypond evaluation
;;; ob-lilypond.el --- Babel Functions for Lilypond -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
@ -28,6 +28,8 @@
;;
;; Lilypond documentation can be found at
;; http://lilypond.org/manuals.html
;;
;; This depends on epstopdf --- See http://www.ctan.org/pkg/epstopdf.
;;; Code:
(require 'ob)
@ -60,51 +62,68 @@ org-babel-lilypond-play-midi-post-tangle determines whether to automate the
playing of the resultant midi file. If the value is nil,
the midi file is not automatically played. Default value is t")
(defvar org-babel-lilypond-OSX-ly-path
"/Applications/lilypond.app/Contents/Resources/bin/lilypond")
(defvar org-babel-lilypond-OSX-pdf-path "open")
(defvar org-babel-lilypond-OSX-midi-path "open")
(defvar org-babel-lilypond-nix-ly-path "/usr/bin/lilypond")
(defvar org-babel-lilypond-nix-pdf-path "evince")
(defvar org-babel-lilypond-nix-midi-path "timidity")
(defvar org-babel-lilypond-w32-ly-path "lilypond")
(defvar org-babel-lilypond-w32-pdf-path "")
(defvar org-babel-lilypond-w32-midi-path "")
(defvar org-babel-lilypond-ly-command ""
"Command to execute lilypond on your system.
Do not set it directly. Customize `org-babel-lilypond-commands' instead.")
(defvar org-babel-lilypond-pdf-command ""
"Command to show a PDF file on your system.
Do not set it directly. Customize `org-babel-lilypond-commands' instead.")
(defvar org-babel-lilypond-midi-command ""
"Command to play a MIDI file on your system.
Do not set it directly. Customize `org-babel-lilypond-commands' instead.")
(defcustom org-babel-lilypond-commands
(cond
((eq system-type 'darwin)
'("/Applications/lilypond.app/Contents/Resources/bin/lilypond" "open" "open"))
((eq system-type 'windows-nt)
'("lilypond" "" ""))
(t
'("lilypond" "xdg-open" "xdg-open")))
"Commands to run lilypond and view or play the results.
These should be executables that take a filename as an argument.
On some system it is possible to specify the filename directly
and the viewer or player will be determined from the file type;
you can leave the string empty on this case."
:group 'org-babel
:type '(list
(string :tag "Lilypond ")
(string :tag "PDF Viewer ")
(string :tag "MIDI Player"))
:version "24.3"
:package-version '(Org . "8.2.7")
:set
(lambda (_symbol value)
(setq
org-babel-lilypond-ly-command (nth 0 value)
org-babel-lilypond-pdf-command (nth 1 value)
org-babel-lilypond-midi-command (nth 2 value))))
(defvar org-babel-lilypond-gen-png nil
"Image generation (png) can be turned on by default by setting
ORG-BABEL-LILYPOND-GEN-PNG to t")
"Non-nil means image generation (PNG) is turned on by default.")
(defvar org-babel-lilypond-gen-svg nil
"Image generation (SVG) can be turned on by default by setting
ORG-BABEL-LILYPOND-GEN-SVG to t")
"Non-nil means image generation (SVG) is be turned on by default.")
(defvar org-babel-lilypond-gen-html nil
"HTML generation can be turned on by default by setting
ORG-BABEL-LILYPOND-GEN-HTML to t")
"Non-nil means HTML generation is turned on by default.")
(defvar org-babel-lilypond-gen-pdf nil
"PDF generation can be turned on by default by setting
ORG-BABEL-LILYPOND-GEN-PDF to t")
"Non-nil means PDF generation is be turned on by default.")
(defvar org-babel-lilypond-use-eps nil
"You can force the compiler to use the EPS backend by setting
ORG-BABEL-LILYPOND-USE-EPS to t")
"Non-nil forces the compiler to use the EPS backend.")
(defvar org-babel-lilypond-arrange-mode nil
"Arrange mode is turned on by setting ORG-BABEL-LILYPOND-ARRANGE-MODE
to t. In Arrange mode the following settings are altered
from default...
"Non-nil turns Arrange mode on.
In Arrange mode the following settings are altered from default:
:tangle yes, :noweb yes
:results silent :comments yes.
In addition lilypond block execution causes tangling of all lilypond
blocks")
blocks.")
(defun org-babel-expand-body:lilypond (body params)
"Expand BODY according to PARAMS, return the expanded body."
(let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
(let ((vars (org-babel--get-vars params)))
(mapc
(lambda (pair)
(let ((name (symbol-name (car pair)))
@ -138,9 +157,8 @@ specific arguments to =org-babel-tangle="
(defun org-babel-lilypond-process-basic (body params)
"Execute a lilypond block in basic mode."
(let* ((result-params (cdr (assoc :result-params params)))
(out-file (cdr (assoc :file params)))
(cmdline (or (cdr (assoc :cmdline params))
(let* ((out-file (cdr (assq :file params)))
(cmdline (or (cdr (assq :cmdline params))
""))
(in-file (org-babel-temp-file "lilypond-")))
@ -148,7 +166,7 @@ specific arguments to =org-babel-tangle="
(insert (org-babel-expand-body:generic body params)))
(org-babel-eval
(concat
(org-babel-lilypond-determine-ly-path)
org-babel-lilypond-ly-command
" -dbackend=eps "
"-dno-gs-load-fonts "
"-dinclude-eps-fonts "
@ -163,7 +181,7 @@ specific arguments to =org-babel-tangle="
cmdline
in-file) "")) nil)
(defun org-babel-prep-session:lilypond (session params)
(defun org-babel-prep-session:lilypond (_session _params)
"Return an error because LilyPond exporter does not support sessions."
(error "Sorry, LilyPond does not currently support sessions!"))
@ -175,29 +193,27 @@ If error in compilation, attempt to mark the error in lilypond org file"
(buffer-file-name) ".lilypond"))
(org-babel-lilypond-temp-file (org-babel-lilypond-switch-extension
(buffer-file-name) ".ly")))
(if (file-exists-p org-babel-lilypond-tangled-file)
(progn
(when (file-exists-p org-babel-lilypond-temp-file)
(delete-file org-babel-lilypond-temp-file))
(rename-file org-babel-lilypond-tangled-file
org-babel-lilypond-temp-file))
(error "Error: Tangle Failed!") t)
(if (not (file-exists-p org-babel-lilypond-tangled-file))
(error "Error: Tangle Failed!")
(when (file-exists-p org-babel-lilypond-temp-file)
(delete-file org-babel-lilypond-temp-file))
(rename-file org-babel-lilypond-tangled-file
org-babel-lilypond-temp-file))
(switch-to-buffer-other-window "*lilypond*")
(erase-buffer)
(org-babel-lilypond-compile-lilyfile org-babel-lilypond-temp-file)
(goto-char (point-min))
(if (not (org-babel-lilypond-check-for-compile-error org-babel-lilypond-temp-file))
(progn
(other-window -1)
(org-babel-lilypond-attempt-to-open-pdf org-babel-lilypond-temp-file)
(org-babel-lilypond-attempt-to-play-midi org-babel-lilypond-temp-file))
(error "Error in Compilation!")))) nil)
(if (org-babel-lilypond-check-for-compile-error org-babel-lilypond-temp-file)
(error "Error in Compilation!")
(other-window -1)
(org-babel-lilypond-attempt-to-open-pdf org-babel-lilypond-temp-file)
(org-babel-lilypond-attempt-to-play-midi org-babel-lilypond-temp-file)))))
(defun org-babel-lilypond-compile-lilyfile (file-name &optional test)
"Compile lilypond file and check for compile errors
FILE-NAME is full path to lilypond (.ly) file"
(message "Compiling LilyPond...")
(let ((arg-1 (org-babel-lilypond-determine-ly-path)) ;program
(let ((arg-1 org-babel-lilypond-ly-command) ;program
(arg-2 nil) ;infile
(arg-3 "*lilypond*") ;buffer
(arg-4 t) ;display
@ -223,11 +239,10 @@ FILE-NAME is full path to lilypond file.
If TEST is t just return nil if no error found, and pass
nil as file-name since it is unused in this context"
(let ((is-error (search-forward "error:" nil t)))
(if (not test)
(if (not is-error)
nil
(org-babel-lilypond-process-compile-error file-name))
is-error)))
(if test
is-error
(when is-error
(org-babel-lilypond-process-compile-error file-name)))))
(defun org-babel-lilypond-process-compile-error (file-name)
"Process the compilation error that has occurred.
@ -249,32 +264,26 @@ LINE is the erroneous line"
(setq case-fold-search nil)
(if (search-forward line nil t)
(progn
(show-all)
(outline-show-all)
(set-mark (point))
(goto-char (- (point) (length line))))
(goto-char temp))))
(defun org-babel-lilypond-parse-line-num (&optional buffer)
"Extract error line number."
(when buffer
(set-buffer buffer))
(when buffer (set-buffer buffer))
(let ((start
(and (search-backward ":" nil t)
(search-backward ":" nil t)
(search-backward ":" nil t)
(search-backward ":" nil t)))
(num nil))
(if start
(progn
(forward-char)
(let ((num (buffer-substring
(+ 1 start)
(- (search-forward ":" nil t) 1))))
(setq num (string-to-number num))
(if (numberp num)
num
nil)))
nil)))
(search-backward ":" nil t))))
(when start
(forward-char)
(let ((num (string-to-number
(buffer-substring
(+ 1 start)
(- (search-forward ":" nil t) 1)))))
(and (numberp num) num)))))
(defun org-babel-lilypond-parse-error-line (file-name lineNo)
"Extract the erroneous line from the tangled .ly file
@ -298,13 +307,13 @@ If TEST is non-nil, the shell command is returned and is not run"
(let ((pdf-file (org-babel-lilypond-switch-extension file-name ".pdf")))
(if (file-exists-p pdf-file)
(let ((cmd-string
(concat (org-babel-lilypond-determine-pdf-path) " " pdf-file)))
(concat org-babel-lilypond-pdf-command " " pdf-file)))
(if test
cmd-string
(start-process
"\"Audition pdf\""
"*lilypond*"
(org-babel-lilypond-determine-pdf-path)
org-babel-lilypond-pdf-command
pdf-file)))
(message "No pdf file generated so can't display!")))))
@ -316,49 +325,16 @@ If TEST is non-nil, the shell command is returned and is not run"
(let ((midi-file (org-babel-lilypond-switch-extension file-name ".midi")))
(if (file-exists-p midi-file)
(let ((cmd-string
(concat (org-babel-lilypond-determine-midi-path) " " midi-file)))
(concat org-babel-lilypond-midi-command " " midi-file)))
(if test
cmd-string
(start-process
"\"Audition midi\""
"*lilypond*"
(org-babel-lilypond-determine-midi-path)
org-babel-lilypond-midi-command
midi-file)))
(message "No midi file generated so can't play!")))))
(defun org-babel-lilypond-determine-ly-path (&optional test)
"Return correct path to ly binary depending on OS
If TEST is non-nil, it contains a simulation of the OS for test purposes"
(let ((sys-type
(or test system-type)))
(cond ((string= sys-type "darwin")
org-babel-lilypond-OSX-ly-path)
((string= sys-type "windows-nt")
org-babel-lilypond-w32-ly-path)
(t org-babel-lilypond-nix-ly-path))))
(defun org-babel-lilypond-determine-pdf-path (&optional test)
"Return correct path to pdf viewer depending on OS
If TEST is non-nil, it contains a simulation of the OS for test purposes"
(let ((sys-type
(or test system-type)))
(cond ((string= sys-type "darwin")
org-babel-lilypond-OSX-pdf-path)
((string= sys-type "windows-nt")
org-babel-lilypond-w32-pdf-path)
(t org-babel-lilypond-nix-pdf-path))))
(defun org-babel-lilypond-determine-midi-path (&optional test)
"Return correct path to midi player depending on OS
If TEST is non-nil, it contains a simulation of the OS for test purposes"
(let ((sys-type
(or test test system-type)))
(cond ((string= sys-type "darwin")
org-babel-lilypond-OSX-midi-path)
((string= sys-type "windows-nt")
org-babel-lilypond-w32-midi-path)
(t org-babel-lilypond-nix-midi-path))))
(defun org-babel-lilypond-toggle-midi-play ()
"Toggle whether midi will be played following a successful compilation."
(interactive)

94
lisp/org/ob-lisp.el
View file

@ -1,4 +1,4 @@
;;; ob-lisp.el --- org-babel functions for common lisp evaluation
;;; ob-lisp.el --- Babel Functions for Common Lisp -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -25,17 +25,22 @@
;;; Commentary:
;;; support for evaluating common lisp code, relies on slime for all eval
;;; Support for evaluating Common Lisp code, relies on SLY or SLIME
;;; for all eval.
;;; Requirements:
;; Requires SLIME (Superior Lisp Interaction Mode for Emacs.)
;; See http://common-lisp.net/project/slime/
;; Requires SLY (Sylvester the Cat's Common Lisp IDE) or SLIME
;; (Superior Lisp Interaction Mode for Emacs). See:
;; - https://github.com/capitaomorte/sly
;; - http://common-lisp.net/project/slime/
;;; Code:
(require 'ob)
(declare-function sly-eval "ext:sly" (sexp &optional package))
(declare-function slime-eval "ext:slime" (sexp &optional package))
(declare-function org-trim "org" (s &optional keep-lead))
(defvar org-babel-tangle-lang-exts)
(add-to-list 'org-babel-tangle-lang-exts '("lisp" . "lisp"))
@ -43,8 +48,16 @@
(defvar org-babel-default-header-args:lisp '())
(defvar org-babel-header-args:lisp '((package . :any)))
(defcustom org-babel-lisp-eval-fn #'slime-eval
"The function to be called to evaluate code on the Lisp side.
Valid values include `slime-eval' and `sly-eval'."
:group 'org-babel
:version "26.1"
:package-version '(Org . "9.0")
:type 'function)
(defcustom org-babel-lisp-dir-fmt
"(let ((*default-pathname-defaults* #P%S)) %%s)"
"(let ((*default-pathname-defaults* #P%S\n)) %%s\n)"
"Format string used to wrap code bodies to set the current directory.
For example a value of \"(progn ;; %s\\n %%s)\" would ignore the
current directory string."
@ -54,49 +67,54 @@ current directory string."
(defun org-babel-expand-body:lisp (body params)
"Expand BODY according to PARAMS, return the expanded body."
(let* ((vars (mapcar #'cdr (org-babel-get-header params :var)))
(result-params (cdr (assoc :result-params params)))
(let* ((vars (org-babel--get-vars params))
(result-params (cdr (assq :result-params params)))
(print-level nil) (print-length nil)
(body (org-babel-trim
(if (> (length vars) 0)
(concat "(let ("
(mapconcat
(lambda (var)
(format "(%S (quote %S))" (car var) (cdr var)))
vars "\n ")
")\n" body ")")
body))))
(body (if (null vars) (org-trim body)
(concat "(let ("
(mapconcat
(lambda (var)
(format "(%S (quote %S))" (car var) (cdr var)))
vars "\n ")
")\n" body ")"))))
(if (or (member "code" result-params)
(member "pp" result-params))
(format "(pprint %s)" body)
body)))
(defun org-babel-execute:lisp (body params)
"Execute a block of Common Lisp code with Babel."
(require 'slime)
"Execute a block of Common Lisp code with Babel.
BODY is the contents of the block, as a string. PARAMS is
a property list containing the parameters of the block."
(require (pcase org-babel-lisp-eval-fn
(`slime-eval 'slime)
(`sly-eval 'sly)))
(org-babel-reassemble-table
(let ((result
(with-temp-buffer
(insert (org-babel-expand-body:lisp body params))
(slime-eval `(swank:eval-and-grab-output
,(let ((dir (if (assoc :dir params)
(cdr (assoc :dir params))
default-directory)))
(format
(if dir (format org-babel-lisp-dir-fmt dir)
"(progn %s)")
(buffer-substring-no-properties
(point-min) (point-max)))))
(cdr (assoc :package params))))))
(org-babel-result-cond (cdr (assoc :result-params params))
(car result)
(funcall (if (member "output" (cdr (assq :result-params params)))
#'car #'cadr)
(with-temp-buffer
(insert (org-babel-expand-body:lisp body params))
(funcall org-babel-lisp-eval-fn
`(swank:eval-and-grab-output
,(let ((dir (if (assq :dir params)
(cdr (assq :dir params))
default-directory)))
(format
(if dir (format org-babel-lisp-dir-fmt dir)
"(progn %s\n)")
(buffer-substring-no-properties
(point-min) (point-max)))))
(cdr (assq :package params)))))))
(org-babel-result-cond (cdr (assq :result-params params))
result
(condition-case nil
(read (org-babel-lisp-vector-to-list (cadr result)))
(error (cadr result)))))
(org-babel-pick-name (cdr (assoc :colname-names params))
(cdr (assoc :colnames params)))
(org-babel-pick-name (cdr (assoc :rowname-names params))
(cdr (assoc :rownames params)))))
(read (org-babel-lisp-vector-to-list result))
(error result))))
(org-babel-pick-name (cdr (assq :colname-names params))
(cdr (assq :colnames params)))
(org-babel-pick-name (cdr (assq :rowname-names params))
(cdr (assq :rownames params)))))
(defun org-babel-lisp-vector-to-list (results)
;; TODO: better would be to replace #(...) with [...]

179
lisp/org/ob-lob.el
View file

@ -1,4 +1,4 @@
;;; ob-lob.el --- functions supporting the Library of Babel
;;; ob-lob.el --- Functions Supporting the Library of Babel -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -23,27 +23,27 @@
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Code:
(eval-when-compile
(require 'cl))
(require 'cl-lib)
(require 'ob-core)
(require 'ob-table)
(declare-function org-babel-in-example-or-verbatim "ob-exp" nil)
(declare-function org-babel-ref-split-args "ob-ref" (arg-string))
(declare-function org-element-at-point "org-element" ())
(declare-function org-element-context "org-element" (&optional element))
(declare-function org-element-property "org-element" (property element))
(declare-function org-element-type "org-element" (element))
(defvar org-babel-library-of-babel nil
"Library of source-code blocks.
This is an association list. Populate the library by adding
files to `org-babel-lob-files'.")
(defcustom org-babel-lob-files nil
"Files used to populate the `org-babel-library-of-babel'.
To add files to this list use the `org-babel-lob-ingest' command."
:group 'org-babel
:version "24.1"
:type '(repeat file))
This is an association list. Populate the library by calling
`org-babel-lob-ingest' on files containing source blocks.")
(defvar org-babel-default-lob-header-args '((:exports . "results"))
"Default header arguments to use when exporting #+lob/call lines.")
"Default header arguments to use when exporting Babel calls.
By default, a Babel call inherits its arguments from the source
block being called. Header arguments defined in this variable
take precedence over these. It is useful for properties that
should not be inherited from a source block.")
(defun org-babel-lob-ingest (&optional file)
"Add all named source blocks defined in FILE to `org-babel-library-of-babel'."
@ -62,24 +62,7 @@ To add files to this list use the `org-babel-lob-ingest' command."
lob-ingest-count (if (> lob-ingest-count 1) "s" ""))
lob-ingest-count))
(defconst org-babel-block-lob-one-liner-regexp
(concat
"^\\([ \t]*?\\)#\\+call:[ \t]+\\([^()\n]+?\\)\\(\\[\\(.*\\)\\]\\|\\(\\)\\)"
"(\\([^\n]*?\\))\\(\\[.+\\]\\|\\)[ \t]*\\(\\([^\n]*\\)\\)?")
"Regexp to match non-inline calls to predefined source block functions.")
(defconst org-babel-inline-lob-one-liner-regexp
(concat
"\\([^\n]*?\\)call_\\([^()\n]+?\\)\\(\\[\\(.*?\\)\\]\\|\\(\\)\\)"
"(\\([^\n]*?\\))\\(\\[\\(.*?\\)\\]\\)?")
"Regexp to match inline calls to predefined source block functions.")
(defconst org-babel-lob-one-liner-regexp
(concat "\\(" org-babel-block-lob-one-liner-regexp
"\\|" org-babel-inline-lob-one-liner-regexp "\\)")
"Regexp to match calls to predefined source block functions.")
;; functions for executing lob one-liners
;; Functions for executing lob one-liners.
;;;###autoload
(defun org-babel-lob-execute-maybe ()
@ -88,72 +71,76 @@ Detect if this is context for a Library Of Babel source block and
if so then run the appropriate source block from the Library."
(interactive)
(let ((info (org-babel-lob-get-info)))
(if (and (nth 0 info) (not (org-babel-in-example-or-verbatim)))
(progn (org-babel-lob-execute info) t)
nil)))
(when info
(org-babel-execute-src-block nil info)
t)))
(defun org-babel-lob--src-info (name)
"Return internal representation for Babel data named NAME.
NAME is a string. This function looks into the current document
for a Babel call or source block. If none is found, it looks
after NAME in the Library of Babel. Eventually, if that also
fails, it returns nil."
;; During export, look into the pristine copy of the document being
;; exported instead of the current one, which could miss some data.
(with-current-buffer (or org-babel-exp-reference-buffer (current-buffer))
(org-with-wide-buffer
(goto-char (point-min))
(catch :found
(let ((case-fold-search t)
(regexp (org-babel-named-data-regexp-for-name name)))
(while (re-search-forward regexp nil t)
(let ((element (org-element-at-point)))
(when (equal name (org-element-property :name element))
(throw :found
(pcase (org-element-type element)
(`src-block (org-babel-get-src-block-info t element))
(`babel-call (org-babel-lob-get-info element))
;; Non-executable data found. Since names are
;; supposed to be unique throughout a document,
;; bail out.
(_ nil))))))
;; No element named NAME in buffer. Try Library of Babel.
(cdr (assoc-string name org-babel-library-of-babel)))))))
;;;###autoload
(defun org-babel-lob-get-info ()
"Return a Library of Babel function call as a string."
(let ((case-fold-search t)
(nonempty (lambda (a b)
(let ((it (match-string a)))
(if (= (length it) 0) (match-string b) it)))))
(save-excursion
(beginning-of-line 1)
(when (looking-at org-babel-lob-one-liner-regexp)
(append
(mapcar #'org-no-properties
(list
(format "%s%s(%s)%s"
(funcall nonempty 3 12)
(if (not (= 0 (length (funcall nonempty 5 14))))
(concat "[" (funcall nonempty 5 14) "]") "")
(or (funcall nonempty 7 16) "")
(or (funcall nonempty 8 19) ""))
(funcall nonempty 9 18)))
(list (length (if (= (length (match-string 12)) 0)
(match-string 2) (match-string 11)))
(save-excursion
(forward-line -1)
(and (looking-at (concat org-babel-src-name-regexp
"\\([^\n]*\\)$"))
(org-no-properties (match-string 1))))))))))
(defvar org-babel-default-header-args:emacs-lisp) ; Defined in ob-emacs-lisp.el
(defun org-babel-lob-execute (info)
"Execute the lob call specified by INFO."
(let* ((mkinfo (lambda (p)
(list "emacs-lisp" "results" p nil
(nth 3 info) ;; name
(nth 2 info))))
(pre-params (apply #'org-babel-merge-params
org-babel-default-header-args
org-babel-default-header-args:emacs-lisp
(append
(org-babel-params-from-properties)
(list
(org-babel-parse-header-arguments
(org-no-properties
(concat
":var results="
(mapconcat #'identity (butlast info 2)
" "))))))))
(pre-info (funcall mkinfo pre-params))
(cache-p (and (cdr (assoc :cache pre-params))
(string= "yes" (cdr (assoc :cache pre-params)))))
(new-hash (when cache-p (org-babel-sha1-hash pre-info)))
(old-hash (when cache-p (org-babel-current-result-hash)))
(org-babel-current-src-block-location (point-marker)))
(if (and cache-p (equal new-hash old-hash))
(save-excursion (goto-char (org-babel-where-is-src-block-result))
(forward-line 1)
(message "%S" (org-babel-read-result)))
(prog1 (let* ((proc-params (org-babel-process-params pre-params))
org-confirm-babel-evaluate)
(org-babel-execute-src-block nil (funcall mkinfo proc-params)))
;; update the hash
(when new-hash (org-babel-set-current-result-hash new-hash))))))
(defun org-babel-lob-get-info (&optional datum)
"Return internal representation for Library of Babel function call.
Consider DATUM, when provided, or element at point. Return nil
when not on an appropriate location. Otherwise return a list
compatible with `org-babel-get-src-block-info', which see."
(let* ((context (or datum (org-element-context)))
(type (org-element-type context)))
(when (memq type '(babel-call inline-babel-call))
(pcase (org-babel-lob--src-info (org-element-property :call context))
(`(,language ,body ,header ,_ ,_ ,_ ,coderef)
(let ((begin (org-element-property (if (eq type 'inline-babel-call)
:begin
:post-affiliated)
context)))
(list language
body
(apply #'org-babel-merge-params
header
org-babel-default-lob-header-args
(append
(org-with-wide-buffer
(goto-char begin)
(org-babel-params-from-properties language))
(list
(org-babel-parse-header-arguments
(org-element-property :inside-header context))
(let ((args (org-element-property :arguments context)))
(and args
(mapcar (lambda (ref) (cons :var ref))
(org-babel-ref-split-args args))))
(org-babel-parse-header-arguments
(org-element-property :end-header context)))))
nil
(org-element-property :name context)
begin
coderef)))
(_ nil)))))
(provide 'ob-lob)

403
lisp/org/ob-lua.el Normal file
View file

@ -0,0 +1,403 @@
;;; ob-lua.el --- Org Babel functions for Lua evaluation -*- lexical-binding: t; -*-
;; Copyright (C) 2014, 2016, 2017 Free Software Foundation, Inc.
;; Authors: Dieter Schoen
;; Keywords: literate programming, reproducible research
;; Homepage: http://orgmode.org
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;; Requirements:
;; for session support, lua-mode is needed.
;; lua-mode is not part of GNU Emacs/orgmode, but can be obtained
;; from marmalade or melpa.
;; The source respository is here:
;; https://github.com/immerrr/lua-mode
;; However, sessions are not yet working.
;; Org-Babel support for evaluating lua source code.
;;; Code:
(require 'ob)
(require 'cl-lib)
(declare-function org-remove-indentation "org" (code &optional n))
(declare-function org-trim "org" (s &optional keep-lead))
(declare-function lua-shell "ext:lua-mode" (&optional argprompt))
(declare-function lua-toggle-shells "ext:lua-mode" (arg))
(declare-function run-lua "ext:lua" (cmd &optional dedicated show))
(defvar org-babel-tangle-lang-exts)
(add-to-list 'org-babel-tangle-lang-exts '("lua" . "lua"))
(defvar org-babel-default-header-args:lua '())
(defcustom org-babel-lua-command "lua"
"Name of the command for executing Lua code."
:version "24.5"
:package-version '(Org . "8.3")
:group 'org-babel
:type 'string)
(defcustom org-babel-lua-mode 'lua-mode
"Preferred lua mode for use in running lua interactively.
This will typically be 'lua-mode."
:group 'org-babel
:version "24.5"
:package-version '(Org . "8.3")
:type 'symbol)
(defcustom org-babel-lua-hline-to "None"
"Replace hlines in incoming tables with this when translating to lua."
:group 'org-babel
:version "24.5"
:package-version '(Org . "8.3")
:type 'string)
(defcustom org-babel-lua-None-to 'hline
"Replace 'None' in lua tables with this before returning."
:group 'org-babel
:version "24.5"
:package-version '(Org . "8.3")
:type 'symbol)
(defun org-babel-execute:lua (body params)
"Execute a block of Lua code with Babel.
This function is called by `org-babel-execute-src-block'."
(let* ((session (org-babel-lua-initiate-session
(cdr (assq :session params))))
(result-params (cdr (assq :result-params params)))
(result-type (cdr (assq :result-type params)))
(return-val (when (and (eq result-type 'value) (not session))
(cdr (assq :return params))))
(preamble (cdr (assq :preamble params)))
(full-body
(org-babel-expand-body:generic
(concat body (if return-val (format "\nreturn %s" return-val) ""))
params (org-babel-variable-assignments:lua params)))
(result (org-babel-lua-evaluate
session full-body result-type result-params preamble)))
(org-babel-reassemble-table
result
(org-babel-pick-name (cdr (assq :colname-names params))
(cdr (assq :colnames params)))
(org-babel-pick-name (cdr (assq :rowname-names params))
(cdr (assq :rownames params))))))
(defun org-babel-prep-session:lua (session params)
"Prepare SESSION according to the header arguments in PARAMS.
VARS contains resolved variable references"
(let* ((session (org-babel-lua-initiate-session session))
(var-lines
(org-babel-variable-assignments:lua params)))
(org-babel-comint-in-buffer session
(mapc (lambda (var)
(end-of-line 1) (insert var) (comint-send-input)
(org-babel-comint-wait-for-output session)) var-lines))
session))
(defun org-babel-load-session:lua (session body params)
"Load BODY into SESSION."
(save-window-excursion
(let ((buffer (org-babel-prep-session:lua session params)))
(with-current-buffer buffer
(goto-char (process-mark (get-buffer-process (current-buffer))))
(insert (org-babel-chomp body)))
buffer)))
;; helper functions
(defun org-babel-variable-assignments:lua (params)
"Return a list of Lua statements assigning the block's variables."
(mapcar
(lambda (pair)
(format "%s=%s"
(car pair)
(org-babel-lua-var-to-lua (cdr pair))))
(org-babel--get-vars params)))
(defun org-babel-lua-var-to-lua (var)
"Convert an elisp value to a lua variable.
Convert an elisp value, VAR, into a string of lua source code
specifying a variable of the same value."
(if (listp var)
(if (and (= 1 (length var)) (not (listp (car var))))
(org-babel-lua-var-to-lua (car var))
(if (and
(= 2 (length var))
(not (listp (car var))))
(concat
(substring-no-properties (car var))
"="
(org-babel-lua-var-to-lua (cdr var)))
(concat "{" (mapconcat #'org-babel-lua-var-to-lua var ", ") "}")))
(if (eq var 'hline)
org-babel-lua-hline-to
(format
(if (and (stringp var) (string-match "[\n\r]" var)) "\"\"%S\"\"" "%S")
(if (stringp var) (substring-no-properties var) var)))))
(defun org-babel-lua-table-or-string (results)
"Convert RESULTS into an appropriate elisp value.
If the results look like a list or tuple, then convert them into an
Emacs-lisp table, otherwise return the results as a string."
(let ((res (org-babel-script-escape results)))
(if (listp res)
(mapcar (lambda (el) (if (eq el 'None)
org-babel-lua-None-to el))
res)
res)))
(defvar org-babel-lua-buffers '((:default . "*Lua*")))
(defun org-babel-lua-session-buffer (session)
"Return the buffer associated with SESSION."
(cdr (assoc session org-babel-lua-buffers)))
(defun org-babel-lua-with-earmuffs (session)
(let ((name (if (stringp session) session (format "%s" session))))
(if (and (string= "*" (substring name 0 1))
(string= "*" (substring name (- (length name) 1))))
name
(format "*%s*" name))))
(defun org-babel-lua-without-earmuffs (session)
(let ((name (if (stringp session) session (format "%s" session))))
(if (and (string= "*" (substring name 0 1))
(string= "*" (substring name (- (length name) 1))))
(substring name 1 (- (length name) 1))
name)))
(defvar lua-default-interpreter)
(defvar lua-which-bufname)
(defvar lua-shell-buffer-name)
(defun org-babel-lua-initiate-session-by-key (&optional session)
"Initiate a lua session.
If there is not a current inferior-process-buffer in SESSION
then create. Return the initialized session."
;; (require org-babel-lua-mode)
(save-window-excursion
(let* ((session (if session (intern session) :default))
(lua-buffer (org-babel-lua-session-buffer session))
;; (cmd (if (member system-type '(cygwin windows-nt ms-dos))
;; (concat org-babel-lua-command " -i")
;; org-babel-lua-command))
)
(cond
((and (eq 'lua-mode org-babel-lua-mode)
(fboundp 'lua-start-process)) ; lua-mode.el
;; Make sure that lua-which-bufname is initialized, as otherwise
;; it will be overwritten the first time a Lua buffer is
;; created.
;;(lua-toggle-shells lua-default-interpreter)
;; `lua-shell' creates a buffer whose name is the value of
;; `lua-which-bufname' with '*'s at the beginning and end
(let* ((bufname (if (and lua-buffer (buffer-live-p lua-buffer))
(replace-regexp-in-string ;; zap surrounding *
"^\\*\\([^*]+\\)\\*$" "\\1" (buffer-name lua-buffer))
(concat "Lua-" (symbol-name session))))
(lua-which-bufname bufname))
(lua-start-process)
(setq lua-buffer (org-babel-lua-with-earmuffs bufname))))
(t
(error "No function available for running an inferior Lua")))
(setq org-babel-lua-buffers
(cons (cons session lua-buffer)
(assq-delete-all session org-babel-lua-buffers)))
session)))
(defun org-babel-lua-initiate-session (&optional session _params)
"Create a session named SESSION according to PARAMS."
(unless (string= session "none")
(error "Sessions currently not supported, work in progress")
(org-babel-lua-session-buffer
(org-babel-lua-initiate-session-by-key session))))
(defvar org-babel-lua-eoe-indicator "--eoe"
"A string to indicate that evaluation has completed.")
(defvar org-babel-lua-wrapper-method
"
function main()
%s
end
fd=io.open(\"%s\", \"w\")
fd:write( main() )
fd:close()")
(defvar org-babel-lua-pp-wrapper-method
"
-- table to string
function t2s(t, indent)
if indent == nil then
indent = \"\"
end
if type(t) == \"table\" then
ts = \"\"
for k,v in pairs(t) do
if type(v) == \"table\" then
ts = ts .. indent .. t2s(k,indent .. \" \") .. \" = \\n\" ..
t2s(v, indent .. \" \")
else
ts = ts .. indent .. t2s(k,indent .. \" \") .. \" = \" ..
t2s(v, indent .. \" \") .. \"\\n\"
end
end
return ts
else
return tostring(t)
end
end
function main()
%s
end
fd=io.open(\"%s\", \"w\")
fd:write(t2s(main()))
fd:close()")
(defun org-babel-lua-evaluate
(session body &optional result-type result-params preamble)
"Evaluate BODY as Lua code."
(if session
(org-babel-lua-evaluate-session
session body result-type result-params)
(org-babel-lua-evaluate-external-process
body result-type result-params preamble)))
(defun org-babel-lua-evaluate-external-process
(body &optional result-type result-params preamble)
"Evaluate BODY in external lua process.
If RESULT-TYPE equals 'output then return standard output as a
string. If RESULT-TYPE equals 'value then return the value of the
last statement in BODY, as elisp."
(let ((raw
(pcase result-type
(`output (org-babel-eval org-babel-lua-command
(concat (if preamble (concat preamble "\n"))
body)))
(`value (let ((tmp-file (org-babel-temp-file "lua-")))
(org-babel-eval
org-babel-lua-command
(concat
(if preamble (concat preamble "\n") "")
(format
(if (member "pp" result-params)
org-babel-lua-pp-wrapper-method
org-babel-lua-wrapper-method)
(mapconcat
(lambda (line) (format "\t%s" line))
(split-string
(org-remove-indentation
(org-trim body))
"[\r\n]") "\n")
(org-babel-process-file-name tmp-file 'noquote))))
(org-babel-eval-read-file tmp-file))))))
(org-babel-result-cond result-params
raw
(org-babel-lua-table-or-string (org-trim raw)))))
(defun org-babel-lua-evaluate-session
(session body &optional result-type result-params)
"Pass BODY to the Lua process in SESSION.
If RESULT-TYPE equals 'output then return standard output as a
string. If RESULT-TYPE equals 'value then return the value of the
last statement in BODY, as elisp."
(let* ((send-wait (lambda () (comint-send-input nil t) (sleep-for 0 5)))
(dump-last-value
(lambda
(tmp-file pp)
(mapc
(lambda (statement) (insert statement) (funcall send-wait))
(if pp
(list
"-- table to string
function t2s(t, indent)
if indent == nil then
indent = \"\"
end
if type(t) == \"table\" then
ts = \"\"
for k,v in pairs(t) do
if type(v) == \"table\" then
ts = ts .. indent .. t2s(k,indent .. \" \") .. \" = \\n\" ..
t2s(v, indent .. \" \")
else
ts = ts .. indent .. t2s(k,indent .. \" \") .. \" = \" ..
t2s(v, indent .. \" \") .. \"\\n\"
end
end
return ts
else
return tostring(t)
end
end
"
(concat "fd:write(_))
fd:close()"
(org-babel-process-file-name tmp-file 'noquote)))
(list (format "fd=io.open(\"%s\", \"w\")
fd:write( _ )
fd:close()"
(org-babel-process-file-name tmp-file
'noquote)))))))
(input-body (lambda (body)
(mapc (lambda (line) (insert line) (funcall send-wait))
(split-string body "[\r\n]"))
(funcall send-wait)))
(results
(pcase result-type
(`output
(mapconcat
#'org-trim
(butlast
(org-babel-comint-with-output
(session org-babel-lua-eoe-indicator t body)
(funcall input-body body)
(funcall send-wait) (funcall send-wait)
(insert org-babel-lua-eoe-indicator)
(funcall send-wait))
2) "\n"))
(`value
(let ((tmp-file (org-babel-temp-file "lua-")))
(org-babel-comint-with-output
(session org-babel-lua-eoe-indicator nil body)
(let ((comint-process-echoes nil))
(funcall input-body body)
(funcall dump-last-value tmp-file
(member "pp" result-params))
(funcall send-wait) (funcall send-wait)
(insert org-babel-lua-eoe-indicator)
(funcall send-wait)))
(org-babel-eval-read-file tmp-file))))))
(unless (string= (substring org-babel-lua-eoe-indicator 1 -1) results)
(org-babel-result-cond result-params
results
(org-babel-lua-table-or-string results)))))
(defun org-babel-lua-read-string (string)
"Strip 's from around Lua string."
(org-unbracket-string "'" "'" string))
(provide 'ob-lua)
;;; ob-lua.el ends here

8
lisp/org/ob-makefile.el
View file

@ -1,4 +1,4 @@
;;; ob-makefile.el --- org-babel functions for makefile evaluation
;;; ob-makefile.el --- Babel Functions for Makefile -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -24,19 +24,19 @@
;;; Commentary:
;; This file exists solely for tangling a Makefile from org-mode files.
;; This file exists solely for tangling a Makefile from Org files.
;;; Code:
(require 'ob)
(defvar org-babel-default-header-args:makefile '())
(defun org-babel-execute:makefile (body params)
(defun org-babel-execute:makefile (body _params)
"Execute a block of makefile code.
This function is called by `org-babel-execute-src-block'."
body)
(defun org-babel-prep-session:makefile (session params)
(defun org-babel-prep-session:makefile (_session _params)
"Return an error if the :session header argument is set. Make
does not support sessions."
(error "Makefile sessions are nonsensical"))

2
lisp/org/ob-matlab.el
View file

@ -1,4 +1,4 @@
;;; ob-matlab.el --- org-babel support for matlab evaluation
;;; ob-matlab.el --- Babel support for Matlab -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2017 Free Software Foundation, Inc.

19
lisp/org/ob-maxima.el
View file

@ -1,4 +1,4 @@
;;; ob-maxima.el --- org-babel functions for maxima evaluation
;;; ob-maxima.el --- Babel Functions for Maxima -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -48,11 +48,11 @@
(defun org-babel-maxima-expand (body params)
"Expand a block of Maxima code according to its header arguments."
(let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
(let ((vars (org-babel--get-vars params)))
(mapconcat 'identity
(list
;; graphic output
(let ((graphic-file (org-babel-maxima-graphical-output-file params)))
(let ((graphic-file (ignore-errors (org-babel-graphical-output-file params))))
(if graphic-file
(format
"set_plot_option ([gnuplot_term, png]); set_plot_option ([gnuplot_out_file, %S]);"
@ -69,9 +69,9 @@
"Execute a block of Maxima entries with org-babel.
This function is called by `org-babel-execute-src-block'."
(message "executing Maxima source code block")
(let ((result-params (split-string (or (cdr (assoc :results params)) "")))
(let ((result-params (split-string (or (cdr (assq :results params)) "")))
(result
(let* ((cmdline (or (cdr (assoc :cmdline params)) ""))
(let* ((cmdline (or (cdr (assq :cmdline params)) ""))
(in-file (org-babel-temp-file "maxima-" ".max"))
(cmd (format "%s --very-quiet -r 'batchload(%S)$' %s"
org-babel-maxima-command in-file cmdline)))
@ -89,7 +89,7 @@ This function is called by `org-babel-execute-src-block'."
(= 0 (length line)))
line))
(split-string raw "[\r\n]"))) "\n")))))
(if (org-babel-maxima-graphical-output-file params)
(if (ignore-errors (org-babel-graphical-output-file params))
nil
(org-babel-result-cond result-params
result
@ -98,7 +98,7 @@ This function is called by `org-babel-execute-src-block'."
(org-babel-import-elisp-from-file tmp-file))))))
(defun org-babel-prep-session:maxima (session params)
(defun org-babel-prep-session:maxima (_session _params)
(error "Maxima does not support sessions"))
(defun org-babel-maxima-var-to-maxima (pair)
@ -113,11 +113,6 @@ of the same value."
(format "%S: %s$" var
(org-babel-maxima-elisp-to-maxima val))))
(defun org-babel-maxima-graphical-output-file (params)
"Name of file to which maxima should send graphical output."
(and (member "graphics" (cdr (assq :result-params params)))
(cdr (assq :file params))))
(defun org-babel-maxima-elisp-to-maxima (val)
"Return a string of maxima code which evaluates to VAL."
(if (listp val)

10
lisp/org/ob-mscgen.el
View file

@ -1,4 +1,4 @@
;;; ob-msc.el --- org-babel functions for mscgen evaluation
;;; ob-msc.el --- Babel Functions for Mscgen -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
@ -65,15 +65,15 @@
This function is called by `org-babel-execute-src-block'.
Default filetype is png. Modify by setting :filetype parameter to
mscgen supported formats."
(let* ((out-file (or (cdr (assoc :file params)) "output.png" ))
(filetype (or (cdr (assoc :filetype params)) "png" )))
(unless (cdr (assoc :file params))
(let* ((out-file (or (cdr (assq :file params)) "output.png" ))
(filetype (or (cdr (assq :filetype params)) "png" )))
(unless (cdr (assq :file params))
(error "
ERROR: no output file specified. Add \":file name.png\" to the src header"))
(org-babel-eval (concat "mscgen -T " filetype " -o " out-file) body)
nil)) ;; signal that output has already been written to file
(defun org-babel-prep-session:mscgen (session params)
(defun org-babel-prep-session:mscgen (_session _params)
"Raise an error because Mscgen doesn't support sessions."
(error "Mscgen does not support sessions"))

85
lisp/org/ob-ocaml.el
View file

@ -1,4 +1,4 @@
;;; ob-ocaml.el --- org-babel functions for ocaml evaluation
;;; ob-ocaml.el --- Babel Functions for Ocaml -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -37,11 +37,11 @@
;;; Code:
(require 'ob)
(require 'comint)
(eval-when-compile (require 'cl))
(declare-function tuareg-run-caml "ext:tuareg" ())
(declare-function tuareg-run-ocaml "ext:tuareg" ())
(declare-function tuareg-interactive-send-input "ext:tuareg" ())
(declare-function org-trim "org" (s &optional keep-lead))
(defvar org-babel-tangle-lang-exts)
(add-to-list 'org-babel-tangle-lang-exts '("ocaml" . "ml"))
@ -60,17 +60,17 @@
(defun org-babel-execute:ocaml (body params)
"Execute a block of Ocaml code with Babel."
(let* ((vars (mapcar #'cdr (org-babel-get-header params :var)))
(full-body (org-babel-expand-body:generic
(let* ((full-body (org-babel-expand-body:generic
body params
(org-babel-variable-assignments:ocaml params)))
(session (org-babel-prep-session:ocaml
(cdr (assoc :session params)) params))
(cdr (assq :session params)) params))
(raw (org-babel-comint-with-output
(session org-babel-ocaml-eoe-output t full-body)
(session org-babel-ocaml-eoe-output nil full-body)
(insert
(concat
(org-babel-chomp full-body)";;\n"org-babel-ocaml-eoe-indicator))
(org-babel-chomp full-body) ";;\n"
org-babel-ocaml-eoe-indicator))
(tuareg-interactive-send-input)))
(clean
(car (let ((re (regexp-quote org-babel-ocaml-eoe-output)) out)
@ -79,23 +79,31 @@
(progn (setq out nil) line)
(when (string-match re line)
(progn (setq out t) nil))))
(mapcar #'org-babel-trim (reverse raw))))))))
(org-babel-reassemble-table
(let ((raw (org-babel-trim clean))
(result-params (cdr (assoc :result-params params))))
(mapcar #'org-trim (reverse raw)))))))
(raw (org-trim clean))
(result-params (cdr (assq :result-params params))))
(string-match
"\\(\\(.*\n\\)*\\)[^:\n]+ : \\([^=\n]+\\) =\\(\n\\| \\)\\(.+\\)$"
raw)
(let ((output (match-string 1 raw))
(type (match-string 3 raw))
(value (match-string 5 raw)))
(org-babel-reassemble-table
(org-babel-result-cond result-params
;; strip type information from output unless verbatim is specified
(if (and (not (member "verbatim" result-params))
(string-match "= \\(.+\\)$" raw))
(match-string 1 raw) raw)
(org-babel-ocaml-parse-output raw)))
(org-babel-pick-name
(cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
(org-babel-pick-name
(cdr (assoc :rowname-names params)) (cdr (assoc :rownames params))))))
(cond
((member "verbatim" result-params) raw)
((member "output" result-params) output)
(t raw))
(if (and value type)
(org-babel-ocaml-parse-output value type)
raw))
(org-babel-pick-name
(cdr (assq :colname-names params)) (cdr (assq :colnames params)))
(org-babel-pick-name
(cdr (assq :rowname-names params)) (cdr (assq :rownames params)))))))
(defvar tuareg-interactive-buffer-name)
(defun org-babel-prep-session:ocaml (session params)
(defun org-babel-prep-session:ocaml (session _params)
"Prepare SESSION according to the header arguments in PARAMS."
(require 'tuareg)
(let ((tuareg-interactive-buffer-name (if (and (not (string= session "none"))
@ -113,7 +121,7 @@
(mapcar
(lambda (pair) (format "let %s = %s;;" (car pair)
(org-babel-ocaml-elisp-to-ocaml (cdr pair))))
(mapcar #'cdr (org-babel-get-header params :var))))
(org-babel--get-vars params)))
(defun org-babel-ocaml-elisp-to-ocaml (val)
"Return a string of ocaml code which evaluates to VAL."
@ -121,26 +129,29 @@
(concat "[|" (mapconcat #'org-babel-ocaml-elisp-to-ocaml val "; ") "|]")
(format "%S" val)))
(defun org-babel-ocaml-parse-output (output)
"Parse OUTPUT.
OUTPUT is string output from an ocaml process."
(let ((regexp "[^:]+ : %s = \\(.+\\)$"))
(cond
((string-match (format regexp "string") output)
(org-babel-read (match-string 1 output)))
((or (string-match (format regexp "int") output)
(string-match (format regexp "float") output))
(string-to-number (match-string 1 output)))
((string-match (format regexp "list") output)
(org-babel-ocaml-read-list (match-string 1 output)))
((string-match (format regexp "array") output)
(org-babel-ocaml-read-array (match-string 1 output)))
(t (message "don't recognize type of %s" output) output))))
(defun org-babel-ocaml-parse-output (value type)
"Parse VALUE of type TYPE.
VALUE and TYPE are string output from an ocaml process."
(cond
((string= "string" type)
(org-babel-read value))
((or (string= "int" type)
(string= "float" type))
(string-to-number value))
((string-match "list" type)
(org-babel-ocaml-read-list value))
((string-match "array" type)
(org-babel-ocaml-read-array value))
(t (message "don't recognize type %s" type) value)))
(defun org-babel-ocaml-read-list (results)
"Convert RESULTS into an elisp table or string.
If the results look like a table, then convert them into an
Emacs-lisp table, otherwise return the results as a string."
;; XXX: This probably does not behave as expected when a semicolon
;; is in a string in a list. The same comment applies to
;; `org-babel-ocaml-read-array' below (with even more failure
;; modes).
(org-babel-script-escape (replace-regexp-in-string ";" "," results)))
(defun org-babel-ocaml-read-array (results)

82
lisp/org/ob-octave.el
View file

@ -1,4 +1,4 @@
;;; ob-octave.el --- org-babel functions for octave and matlab evaluation
;;; ob-octave.el --- Babel Functions for Octave and Matlab -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
@ -30,10 +30,10 @@
;;; Code:
(require 'ob)
(eval-when-compile (require 'cl))
(declare-function matlab-shell "ext:matlab-mode")
(declare-function matlab-shell-run-region "ext:matlab-mode")
(declare-function org-trim "org" (s &optional keep-lead))
(defvar org-babel-default-header-args:matlab '())
(defvar org-babel-default-header-args:octave '())
@ -74,33 +74,31 @@ end")
(let* ((session
(funcall (intern (format "org-babel-%s-initiate-session"
(if matlabp "matlab" "octave")))
(cdr (assoc :session params)) params))
(vars (mapcar #'cdr (org-babel-get-header params :var)))
(result-params (cdr (assoc :result-params params)))
(result-type (cdr (assoc :result-type params)))
(out-file (cdr (assoc :file params)))
(cdr (assq :session params)) params))
(result-type (cdr (assq :result-type params)))
(full-body
(org-babel-expand-body:generic
body params (org-babel-variable-assignments:octave params)))
(gfx-file (ignore-errors (org-babel-graphical-output-file params)))
(result (org-babel-octave-evaluate
session
(if (org-babel-octave-graphical-output-file params)
(if gfx-file
(mapconcat 'identity
(list
"set (0, \"defaultfigurevisible\", \"off\");"
full-body
(format "print -dpng %s" (org-babel-octave-graphical-output-file params)))
(format "print -dpng %s" gfx-file))
"\n")
full-body)
result-type matlabp)))
(if (org-babel-octave-graphical-output-file params)
(if gfx-file
nil
(org-babel-reassemble-table
result
(org-babel-pick-name
(cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
(cdr (assq :colname-names params)) (cdr (assq :colnames params)))
(org-babel-pick-name
(cdr (assoc :rowname-names params)) (cdr (assoc :rownames params)))))))
(cdr (assq :rowname-names params)) (cdr (assq :rownames params)))))))
(defun org-babel-prep-session:matlab (session params)
"Prepare SESSION according to PARAMS."
@ -113,7 +111,7 @@ end")
(format "%s=%s;"
(car pair)
(org-babel-octave-var-to-octave (cdr pair))))
(mapcar #'cdr (org-babel-get-header params :var))))
(org-babel--get-vars params)))
(defalias 'org-babel-variable-assignments:matlab
'org-babel-variable-assignments:octave)
@ -147,7 +145,7 @@ If there is not a current inferior-process-buffer in SESSION then
create. Return the initialized session."
(org-babel-octave-initiate-session session params 'matlab))
(defun org-babel-octave-initiate-session (&optional session params matlabp)
(defun org-babel-octave-initiate-session (&optional session _params matlabp)
"Create an octave inferior process buffer.
If there is not a current inferior-process-buffer in SESSION then
create. Return the initialized session."
@ -167,8 +165,8 @@ create. Return the initialized session."
(defun org-babel-octave-evaluate
(session body result-type &optional matlabp)
"Pass BODY to the octave process in SESSION.
If RESULT-TYPE equals 'output then return the outputs of the
statements in BODY, if RESULT-TYPE equals 'value then return the
If RESULT-TYPE equals `output' then return the outputs of the
statements in BODY, if RESULT-TYPE equals `value' then return the
value of the last statement in BODY, as elisp."
(if session
(org-babel-octave-evaluate-session session body result-type matlabp)
@ -179,9 +177,9 @@ value of the last statement in BODY, as elisp."
(let ((cmd (if matlabp
org-babel-matlab-shell-command
org-babel-octave-shell-command)))
(case result-type
(output (org-babel-eval cmd body))
(value (let ((tmp-file (org-babel-temp-file "octave-")))
(pcase result-type
(`output (org-babel-eval cmd body))
(`value (let ((tmp-file (org-babel-temp-file "octave-")))
(org-babel-eval
cmd
(format org-babel-octave-wrapper-method body
@ -190,17 +188,17 @@ value of the last statement in BODY, as elisp."
(org-babel-octave-import-elisp-from-file tmp-file))))))
(defun org-babel-octave-evaluate-session
(session body result-type &optional matlabp)
(session body result-type &optional matlabp)
"Evaluate BODY in SESSION."
(let* ((tmp-file (org-babel-temp-file (if matlabp "matlab-" "octave-")))
(wait-file (org-babel-temp-file "matlab-emacs-link-wait-signal-"))
(full-body
(case result-type
(output
(pcase result-type
(`output
(mapconcat
#'org-babel-chomp
(list body org-babel-octave-eoe-indicator) "\n"))
(value
(`value
(if (and matlabp org-babel-matlab-with-emacs-link)
(concat
(format org-babel-matlab-emacs-link-wrapper-method
@ -233,21 +231,20 @@ value of the last statement in BODY, as elisp."
org-babel-octave-eoe-output)
t full-body)
(insert full-body) (comint-send-input nil t)))) results)
(case result-type
(value
(pcase result-type
(`value
(org-babel-octave-import-elisp-from-file tmp-file))
(output
(progn
(setq results
(if matlabp
(cdr (reverse (delq "" (mapcar
#'org-babel-octave-read-string
(mapcar #'org-babel-trim raw)))))
(cdr (member org-babel-octave-eoe-output
(reverse (mapcar
#'org-babel-octave-read-string
(mapcar #'org-babel-trim raw)))))))
(mapconcat #'identity (reverse results) "\n"))))))
(`output
(setq results
(if matlabp
(cdr (reverse (delq "" (mapcar
#'org-babel-strip-quotes
(mapcar #'org-trim raw)))))
(cdr (member org-babel-octave-eoe-output
(reverse (mapcar
#'org-babel-strip-quotes
(mapcar #'org-trim raw)))))))
(mapconcat #'identity (reverse results) "\n")))))
(defun org-babel-octave-import-elisp-from-file (file-name)
"Import data from FILE-NAME.
@ -262,17 +259,6 @@ This removes initial blank and comment lines and then calls
(delete-region beg end)))
(org-babel-import-elisp-from-file temp-file '(16))))
(defun org-babel-octave-read-string (string)
"Strip \\\"s from around octave string."
(if (string-match "^\"\\([^\000]+\\)\"$" string)
(match-string 1 string)
string))
(defun org-babel-octave-graphical-output-file (params)
"Name of file to which maxima should send graphical output."
(and (member "graphics" (cdr (assq :result-params params)))
(cdr (assq :file params))))
(provide 'ob-octave)

8
lisp/org/ob-org.el
View file

@ -1,4 +1,4 @@
;;; ob-org.el --- org-babel functions for org code block evaluation
;;; ob-org.el --- Babel Functions for Org Code Blocks -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
@ -41,7 +41,7 @@
"Default header inserted during export of org blocks.")
(defun org-babel-expand-body:org (body params)
(dolist (var (mapcar #'cdr (org-babel-get-header params :var)))
(dolist (var (org-babel--get-vars params))
(setq body (replace-regexp-in-string
(regexp-quote (format "$%s" (car var)))
(format "%s" (cdr var))
@ -51,7 +51,7 @@
(defun org-babel-execute:org (body params)
"Execute a block of Org code with.
This function is called by `org-babel-execute-src-block'."
(let ((result-params (split-string (or (cdr (assoc :results params)) "")))
(let ((result-params (split-string (or (cdr (assq :results params)) "")))
(body (org-babel-expand-body:org
(replace-regexp-in-string "^," "" body) params)))
(cond
@ -61,7 +61,7 @@ This function is called by `org-babel-execute-src-block'."
((member "ascii" result-params) (org-export-string-as body 'ascii t))
(t body))))
(defun org-babel-prep-session:org (session params)
(defun org-babel-prep-session:org (_session _params)
"Return an error because org does not support sessions."
(error "Org does not support sessions"))

31
lisp/org/ob-perl.el
View file

@ -1,4 +1,4 @@
;;; ob-perl.el --- org-babel functions for perl evaluation
;;; ob-perl.el --- Babel Functions for Perl -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -28,7 +28,6 @@
;;; Code:
(require 'ob)
(eval-when-compile (require 'cl))
(defvar org-babel-tangle-lang-exts)
(add-to-list 'org-babel-tangle-lang-exts '("perl" . "pl"))
@ -41,20 +40,20 @@
(defun org-babel-execute:perl (body params)
"Execute a block of Perl code with Babel.
This function is called by `org-babel-execute-src-block'."
(let* ((session (cdr (assoc :session params)))
(result-params (cdr (assoc :result-params params)))
(result-type (cdr (assoc :result-type params)))
(let* ((session (cdr (assq :session params)))
(result-params (cdr (assq :result-params params)))
(result-type (cdr (assq :result-type params)))
(full-body (org-babel-expand-body:generic
body params (org-babel-variable-assignments:perl params)))
(session (org-babel-perl-initiate-session session)))
(org-babel-reassemble-table
(org-babel-perl-evaluate session full-body result-type result-params)
(org-babel-pick-name
(cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
(cdr (assq :colname-names params)) (cdr (assq :colnames params)))
(org-babel-pick-name
(cdr (assoc :rowname-names params)) (cdr (assoc :rownames params))))))
(cdr (assq :rowname-names params)) (cdr (assq :rownames params))))))
(defun org-babel-prep-session:perl (session params)
(defun org-babel-prep-session:perl (_session _params)
"Prepare SESSION according to the header arguments in PARAMS."
(error "Sessions are not supported for Perl"))
@ -63,7 +62,7 @@ This function is called by `org-babel-execute-src-block'."
(mapcar
(lambda (pair)
(org-babel-perl--var-to-perl (cdr pair) (car pair)))
(mapcar #'cdr (org-babel-get-header params :var))))
(org-babel--get-vars params)))
;; helper functions
@ -76,7 +75,7 @@ This function is called by `org-babel-execute-src-block'."
The elisp value, VAR, is converted to a string of perl source code
specifying a var of the same value."
(if varn
(let ((org-babel-perl--lvl 0) (lvar (listp var)) prefix)
(let ((org-babel-perl--lvl 0) (lvar (listp var)))
(concat "my $" (symbol-name varn) "=" (when lvar "\n")
(org-babel-perl--var-to-perl var)
";\n"))
@ -92,7 +91,7 @@ specifying a var of the same value."
(defvar org-babel-perl-buffers '(:default . nil))
(defun org-babel-perl-initiate-session (&optional session params)
(defun org-babel-perl-initiate-session (&optional _session _params)
"Return nil because sessions are not supported by perl."
nil)
@ -127,8 +126,8 @@ specifying a var of the same value."
(defun org-babel-perl-evaluate (session ibody &optional result-type result-params)
"Pass BODY to the Perl process in SESSION.
If RESULT-TYPE equals 'output then return a list of the outputs
of the statements in BODY, if RESULT-TYPE equals 'value then
If RESULT-TYPE equals `output' then return a list of the outputs
of the statements in BODY, if RESULT-TYPE equals `value' then
return the value of the last statement in BODY, as elisp."
(when session (error "Sessions are not supported for Perl"))
(let* ((body (concat org-babel-perl-preface ibody))
@ -136,13 +135,13 @@ return the value of the last statement in BODY, as elisp."
(tmp-babel-file (org-babel-process-file-name
tmp-file 'noquote)))
(let ((results
(case result-type
(output
(pcase result-type
(`output
(with-temp-file tmp-file
(insert
(org-babel-eval org-babel-perl-command body))
(buffer-string)))
(value
(`value
(org-babel-eval org-babel-perl-command
(format org-babel-perl-wrapper-method
body tmp-babel-file))))))

14
lisp/org/ob-picolisp.el
View file

@ -1,4 +1,4 @@
;;; ob-picolisp.el --- org-babel functions for picolisp evaluation
;;; ob-picolisp.el --- Babel Functions for Picolisp -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
@ -55,7 +55,6 @@
;;; Code:
(require 'ob)
(require 'comint)
(eval-when-compile (require 'cl))
(declare-function run-picolisp "ext:inferior-picolisp" (cmd))
(defvar org-babel-tangle-lang-exts) ;; Autoloaded
@ -80,9 +79,9 @@
(defun org-babel-expand-body:picolisp (body params)
"Expand BODY according to PARAMS, return the expanded body."
(let ((vars (mapcar #'cdr (org-babel-get-header params :var)))
(result-params (cdr (assoc :result-params params)))
(print-level nil) (print-length nil))
(let ((vars (org-babel--get-vars params))
(print-level nil)
(print-length nil))
(if (> (length vars) 0)
(concat "(prog (let ("
(mapconcat
@ -100,12 +99,11 @@
(message "executing Picolisp source code block")
(let* (
;; Name of the session or "none".
(session-name (cdr (assoc :session params)))
(session-name (cdr (assq :session params)))
;; Set the session if the session variable is non-nil.
(session (org-babel-picolisp-initiate-session session-name))
;; Either OUTPUT or VALUE which should behave as described above.
(result-type (cdr (assoc :result-type params)))
(result-params (cdr (assoc :result-params params)))
(result-params (cdr (assq :result-params params)))
;; Expand the body with `org-babel-expand-body:picolisp'.
(full-body (org-babel-expand-body:picolisp body params))
;; Wrap body appropriately for the type of evaluation and results.

27
lisp/org/ob-plantuml.el
View file

@ -1,4 +1,4 @@
;;; ob-plantuml.el --- org-babel functions for plantuml evaluation
;;; ob-plantuml.el --- Babel Functions for Plantuml -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
@ -49,21 +49,36 @@
(defun org-babel-execute:plantuml (body params)
"Execute a block of plantuml code with org-babel.
This function is called by `org-babel-execute-src-block'."
(let* ((result-params (split-string (or (cdr (assoc :results params)) "")))
(out-file (or (cdr (assoc :file params))
(let* ((out-file (or (cdr (assq :file params))
(error "PlantUML requires a \":file\" header argument")))
(cmdline (cdr (assoc :cmdline params)))
(cmdline (cdr (assq :cmdline params)))
(in-file (org-babel-temp-file "plantuml-"))
(java (or (cdr (assoc :java params)) ""))
(java (or (cdr (assq :java params)) ""))
(cmd (if (string= "" org-plantuml-jar-path)
(error "`org-plantuml-jar-path' is not set")
(concat "java " java " -jar "
(shell-quote-argument
(expand-file-name org-plantuml-jar-path))
(if (string= (file-name-extension out-file) "png")
" -tpng" "")
(if (string= (file-name-extension out-file) "svg")
" -tsvg" "")
(if (string= (file-name-extension out-file) "eps")
" -teps" "")
(if (string= (file-name-extension out-file) "pdf")
" -tpdf" "")
(if (string= (file-name-extension out-file) "vdx")
" -tvdx" "")
(if (string= (file-name-extension out-file) "xmi")
" -txmi" "")
(if (string= (file-name-extension out-file) "scxml")
" -tscxml" "")
(if (string= (file-name-extension out-file) "html")
" -thtml" "")
(if (string= (file-name-extension out-file) "txt")
" -ttxt" "")
(if (string= (file-name-extension out-file) "utxt")
" -utxt" "")
" -p " cmdline " < "
(org-babel-process-file-name in-file)
" > "
@ -74,7 +89,7 @@ This function is called by `org-babel-execute-src-block'."
(message "%s" cmd) (org-babel-eval cmd "")
nil)) ;; signal that output has already been written to file
(defun org-babel-prep-session:plantuml (session params)
(defun org-babel-prep-session:plantuml (_session _params)
"Return an error because plantuml does not support sessions."
(error "Plantuml does not support sessions"))

195
lisp/org/ob-processing.el Normal file
View file

@ -0,0 +1,195 @@
;;; ob-processing.el --- Babel functions for processing -*- lexical-binding: t; -*-
;; Copyright (C) 2015-2017 Free Software Foundation, Inc.
;; Author: Jarmo Hurri (adapted from ob-asymptote.el written by Eric Schulte)
;; Keywords: literate programming, reproducible research
;; Homepage: http://orgmode.org
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Babel support for evaluating processing source code.
;;
;; This differs from most standard languages in that
;;
;; 1) there is no such thing as a "session" in processing
;;
;; 2) results can only be exported as html; in this case, the
;; processing code is embedded via a file into a javascript block
;; using the processing.js module; the script then draws the
;; resulting output when the web page is viewed in a browser; note
;; that the user is responsible for making sure that processing.js
;; is available on the website
;;
;; 3) it is possible to interactively view the sketch of the
;; Processing code block via Processing 2.0 Emacs mode, using
;; `org-babel-processing-view-sketch'. You can bind this command
;; to, e.g., C-c C-v C-k with
;;
;; (define-key org-babel-map (kbd "C-k") 'org-babel-processing-view-sketch)
;;; Requirements:
;; - processing2-emacs mode :: https://github.com/ptrv/processing2-emacs
;; - Processing.js module :: http://processingjs.org/
;;; Code:
(require 'ob)
(require 'sha1)
(declare-function processing-sketch-run "ext:processing-mode" ())
(defvar org-babel-temporary-directory)
(defvar org-babel-tangle-lang-exts)
(add-to-list 'org-babel-tangle-lang-exts '("processing" . "pde"))
;; Default header tags depend on whether exporting html or not; if not
;; exporting html, then no results are produced; otherwise results are
;; HTML.
(defvar org-babel-default-header-args:processing
'((:results . "html") (:exports . "results"))
"Default arguments when evaluating a Processing source block.")
(defvar org-babel-processing-processing-js-filename "processing.js"
"Filename of the processing.js file.")
(defun org-babel-processing-view-sketch ()
"Show the sketch of the Processing block under point in an external viewer."
(interactive)
(require 'processing-mode)
(let ((info (org-babel-get-src-block-info)))
(if (string= (nth 0 info) "processing")
(let* ((body (nth 1 info))
(params (org-babel-process-params (nth 2 info)))
(sketch-code
(org-babel-expand-body:generic
body
params
(org-babel-variable-assignments:processing params))))
;; Note: sketch filename can not contain a hyphen, since it
;; has to be a valid java class name; for this reason
;; make-temp-file is repeated until no hyphen is in the
;; name; also sketch dir name must be the same as the
;; basename of the sketch file.
(let* ((temporary-file-directory org-babel-temporary-directory)
(sketch-dir
(let (sketch-dir-candidate)
(while
(progn
(setq sketch-dir-candidate
(make-temp-file "processing" t))
(when (string-match-p
"-"
(file-name-nondirectory sketch-dir-candidate))
(delete-directory sketch-dir-candidate)
t)))
sketch-dir-candidate))
(sketch-filename
(concat sketch-dir
"/"
(file-name-nondirectory sketch-dir)
".pde")))
(with-temp-file sketch-filename (insert sketch-code))
(find-file sketch-filename)
(processing-sketch-run)
(kill-buffer)))
(message "Not inside a Processing source block."))))
(defun org-babel-execute:processing (body params)
"Execute a block of Processing code.
This function is called by `org-babel-execute-src-block'."
(let ((sketch-code
(org-babel-expand-body:generic
body
params
(org-babel-variable-assignments:processing params))))
;; Results are HTML.
(let ((sketch-canvas-id (concat "ob-" (sha1 sketch-code))))
(concat "<script src=\""
org-babel-processing-processing-js-filename
"\"></script>\n <script type=\"text/processing\""
" data-processing-target=\""
sketch-canvas-id
"\">\n"
sketch-code
"\n</script> <canvas id=\""
sketch-canvas-id
"\"></canvas>"))))
(defun org-babel-prep-session:processing (_session _params)
"Return an error if the :session header argument is set.
Processing does not support sessions"
(error "Processing does not support sessions"))
(defun org-babel-variable-assignments:processing (params)
"Return list of processing statements assigning the block's variables."
(mapcar #'org-babel-processing-var-to-processing
(org-babel--get-vars params)))
(defun org-babel-processing-var-to-processing (pair)
"Convert an elisp value into a Processing variable.
The elisp value PAIR is converted into Processing code specifying
a variable of the same value."
(let ((var (car pair))
(val (let ((v (cdr pair)))
(if (symbolp v) (symbol-name v) v))))
(cond
((integerp val)
(format "int %S=%S;" var val))
((floatp val)
(format "float %S=%S;" var val))
((stringp val)
(format "String %S=\"%s\";" var val))
((and (listp val) (not (listp (car val))))
(let* ((type (org-babel-processing-define-type val))
(fmt (if (eq 'String type) "\"%s\"" "%s"))
(vect (mapconcat (lambda (e) (format fmt e)) val ", ")))
(format "%s[] %S={%s};" type var vect)))
((listp val)
(let* ((type (org-babel-processing-define-type val))
(fmt (if (eq 'String type) "\"%s\"" "%s"))
(array (mapconcat (lambda (row)
(concat "{"
(mapconcat (lambda (e) (format fmt e))
row ", ")
"}"))
val ",")))
(format "%S[][] %S={%s};" type var array))))))
(defun org-babel-processing-define-type (data)
"Determine type of DATA.
DATA is a list. Return type as a symbol.
The type is `String' if any element in DATA is a string.
Otherwise, it is either `float', if some elements are floats, or
`int'."
(letrec ((type 'int)
(find-type
(lambda (row)
(dolist (e row type)
(cond ((listp e) (setq type (funcall find-type e)))
((stringp e) (throw 'exit 'String))
((floatp e) (setq type 'float)))))))
(catch 'exit (funcall find-type data))))
(provide 'ob-processing)
;;; ob-processing.el ends here

111
lisp/org/ob-python.el
View file

@ -1,4 +1,4 @@
;;; ob-python.el --- org-babel functions for python evaluation
;;; ob-python.el --- Babel Functions for Python -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -28,9 +28,9 @@
;;; Code:
(require 'ob)
(eval-when-compile (require 'cl))
(declare-function org-remove-indentation "org" )
(declare-function org-trim "org" (s &optional keep-lead))
(declare-function py-shell "ext:python-mode" (&optional argprompt))
(declare-function py-toggle-shells "ext:python-mode" (arg))
(declare-function run-python "ext:python" (&optional cmd dedicated show))
@ -48,9 +48,9 @@
:type 'string)
(defcustom org-babel-python-mode
(if (or (featurep 'xemacs) (featurep 'python-mode)) 'python-mode 'python)
(if (featurep 'python-mode) 'python-mode 'python)
"Preferred python mode for use in running python interactively.
This will typically be either 'python or 'python-mode."
This will typically be either `python' or `python-mode'."
:group 'org-babel
:version "24.4"
:package-version '(Org . "8.0")
@ -73,13 +73,16 @@ This will typically be either 'python or 'python-mode."
(defun org-babel-execute:python (body params)
"Execute a block of Python code with Babel.
This function is called by `org-babel-execute-src-block'."
(let* ((session (org-babel-python-initiate-session
(cdr (assoc :session params))))
(result-params (cdr (assoc :result-params params)))
(result-type (cdr (assoc :result-type params)))
(let* ((org-babel-python-command
(or (cdr (assq :python params))
org-babel-python-command))
(session (org-babel-python-initiate-session
(cdr (assq :session params))))
(result-params (cdr (assq :result-params params)))
(result-type (cdr (assq :result-type params)))
(return-val (when (and (eq result-type 'value) (not session))
(cdr (assoc :return params))))
(preamble (cdr (assoc :preamble params)))
(cdr (assq :return params))))
(preamble (cdr (assq :preamble params)))
(full-body
(org-babel-expand-body:generic
(concat body (if return-val (format "\nreturn %s" return-val) ""))
@ -88,10 +91,10 @@ This function is called by `org-babel-execute-src-block'."
session full-body result-type result-params preamble)))
(org-babel-reassemble-table
result
(org-babel-pick-name (cdr (assoc :colname-names params))
(cdr (assoc :colnames params)))
(org-babel-pick-name (cdr (assoc :rowname-names params))
(cdr (assoc :rownames params))))))
(org-babel-pick-name (cdr (assq :colname-names params))
(cdr (assq :colnames params)))
(org-babel-pick-name (cdr (assq :rowname-names params))
(cdr (assq :rownames params))))))
(defun org-babel-prep-session:python (session params)
"Prepare SESSION according to the header arguments in PARAMS.
@ -123,7 +126,7 @@ VARS contains resolved variable references"
(format "%s=%s"
(car pair)
(org-babel-python-var-to-python (cdr pair))))
(mapcar #'cdr (org-babel-get-header params :var))))
(org-babel--get-vars params)))
(defun org-babel-python-var-to-python (var)
"Convert an elisp value to a python variable.
@ -131,7 +134,7 @@ Convert an elisp value, VAR, into a string of python source code
specifying a variable of the same value."
(if (listp var)
(concat "[" (mapconcat #'org-babel-python-var-to-python var ", ") "]")
(if (equal var 'hline)
(if (eq var 'hline)
org-babel-python-hline-to
(format
(if (and (stringp var) (string-match "[\n\r]" var)) "\"\"%S\"\"" "%S")
@ -143,7 +146,7 @@ If the results look like a list or tuple, then convert them into an
Emacs-lisp table, otherwise return the results as a string."
(let ((res (org-babel-script-escape results)))
(if (listp res)
(mapcar (lambda (el) (if (equal el 'None)
(mapcar (lambda (el) (if (eq el 'None)
org-babel-python-None-to el))
res)
res)))
@ -214,7 +217,7 @@ then create. Return the initialized session."
(assq-delete-all session org-babel-python-buffers)))
session)))
(defun org-babel-python-initiate-session (&optional session params)
(defun org-babel-python-initiate-session (&optional session _params)
"Create a session named SESSION according to PARAMS."
(unless (string= session "none")
(org-babel-python-session-buffer
@ -222,13 +225,13 @@ then create. Return the initialized session."
(defvar org-babel-python-eoe-indicator "'org_babel_python_eoe'"
"A string to indicate that evaluation has completed.")
(defvar org-babel-python-wrapper-method
(defconst org-babel-python-wrapper-method
"
def main():
%s
open('%s', 'w').write( str(main()) )")
(defvar org-babel-python-pp-wrapper-method
(defconst org-babel-python-pp-wrapper-method
"
import pprint
def main():
@ -246,42 +249,41 @@ open('%s', 'w').write( pprint.pformat(main()) )")
body result-type result-params preamble)))
(defun org-babel-python-evaluate-external-process
(body &optional result-type result-params preamble)
(body &optional result-type result-params preamble)
"Evaluate BODY in external python process.
If RESULT-TYPE equals 'output then return standard output as a
string. If RESULT-TYPE equals 'value then return the value of the
If RESULT-TYPE equals `output' then return standard output as a
string. If RESULT-TYPE equals `value' then return the value of the
last statement in BODY, as elisp."
(let ((raw
(case result-type
(output (org-babel-eval org-babel-python-command
(concat (if preamble (concat preamble "\n"))
body)))
(value (let ((tmp-file (org-babel-temp-file "python-")))
(org-babel-eval
org-babel-python-command
(concat
(if preamble (concat preamble "\n") "")
(format
(if (member "pp" result-params)
org-babel-python-pp-wrapper-method
org-babel-python-wrapper-method)
(mapconcat
(lambda (line) (format "\t%s" line))
(split-string
(org-remove-indentation
(org-babel-trim body))
"[\r\n]") "\n")
(org-babel-process-file-name tmp-file 'noquote))))
(org-babel-eval-read-file tmp-file))))))
(pcase result-type
(`output (org-babel-eval org-babel-python-command
(concat (if preamble (concat preamble "\n"))
body)))
(`value (let ((tmp-file (org-babel-temp-file "python-")))
(org-babel-eval
org-babel-python-command
(concat
(if preamble (concat preamble "\n") "")
(format
(if (member "pp" result-params)
org-babel-python-pp-wrapper-method
org-babel-python-wrapper-method)
(mapconcat
(lambda (line) (format "\t%s" line))
(split-string (org-remove-indentation (org-trim body))
"[\r\n]")
"\n")
(org-babel-process-file-name tmp-file 'noquote))))
(org-babel-eval-read-file tmp-file))))))
(org-babel-result-cond result-params
raw
(org-babel-python-table-or-string (org-babel-trim raw)))))
(org-babel-python-table-or-string (org-trim raw)))))
(defun org-babel-python-evaluate-session
(session body &optional result-type result-params)
"Pass BODY to the Python process in SESSION.
If RESULT-TYPE equals 'output then return standard output as a
string. If RESULT-TYPE equals 'value then return the value of the
If RESULT-TYPE equals `output' then return standard output as a
string. If RESULT-TYPE equals `value' then return the value of the
last statement in BODY, as elisp."
(let* ((send-wait (lambda () (comint-send-input nil t) (sleep-for 0 5)))
(dump-last-value
@ -302,10 +304,10 @@ last statement in BODY, as elisp."
(split-string body "[\r\n]"))
(funcall send-wait)))
(results
(case result-type
(output
(pcase result-type
(`output
(mapconcat
#'org-babel-trim
#'org-trim
(butlast
(org-babel-comint-with-output
(session org-babel-python-eoe-indicator t body)
@ -314,7 +316,7 @@ last statement in BODY, as elisp."
(insert org-babel-python-eoe-indicator)
(funcall send-wait))
2) "\n"))
(value
(`value
(let ((tmp-file (org-babel-temp-file "python-")))
(org-babel-comint-with-output
(session org-babel-python-eoe-indicator nil body)
@ -332,9 +334,10 @@ last statement in BODY, as elisp."
(org-babel-python-table-or-string results)))))
(defun org-babel-python-read-string (string)
"Strip 's from around Python string."
(if (string-match "^'\\([^\000]+\\)'$" string)
(match-string 1 string)
"Strip \\='s from around Python string."
(if (and (string-prefix-p "'" string)
(string-suffix-p "'" string))
(substring string 1 -1)
string))
(provide 'ob-python)

228
lisp/org/ob-ref.el
View file

@ -1,4 +1,4 @@
;;; ob-ref.el --- org-babel functions for referencing external data
;;; ob-ref.el --- Babel Functions for Referencing External Data -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -50,19 +50,20 @@
;;; Code:
(require 'ob-core)
(eval-when-compile
(require 'cl))
(require 'cl-lib)
(declare-function org-remove-if-not "org" (predicate seq))
(declare-function org-at-table-p "org" (&optional table-type))
(declare-function org-count "org" (CL-ITEM CL-SEQ))
(declare-function org-at-item-p "org-list" ())
(declare-function org-narrow-to-subtree "org" ())
(declare-function org-id-find-id-in-file "org-id" (id file &optional markerp))
(declare-function org-babel-lob-get-info "ob-lob" (&optional datum))
(declare-function org-element-at-point "org-element" ())
(declare-function org-element-property "org-element" (property element))
(declare-function org-element-type "org-element" (element))
(declare-function org-end-of-meta-data "org" (&optional full))
(declare-function org-find-property "org" (property &optional value))
(declare-function org-id-find-id-file "org-id" (id))
(declare-function org-id-find-id-in-file "org-id" (id file &optional markerp))
(declare-function org-in-commented-heading-p "org" (&optional no-inheritance))
(declare-function org-narrow-to-subtree "org" ())
(declare-function org-show-context "org" (&optional key))
(declare-function org-pop-to-buffer-same-window
"org-compat" (&optional buffer-or-name norecord label))
(declare-function org-trim "org" (s &optional keep-lead))
(defvar org-babel-ref-split-regexp
"[ \f\t\n\r\v]*\\(.+?\\)[ \f\t\n\r\v]*=[ \f\t\n\r\v]*\\(.+\\)[ \f\t\n\r\v]*")
@ -90,35 +91,31 @@ the variable."
org-babel-current-src-block-location)))
(org-babel-read ref))))
(if (equal out ref)
(if (string-match "^\".*\"$" ref)
(if (and (string-prefix-p "\"" ref)
(string-suffix-p "\"" ref))
(read ref)
(org-babel-ref-resolve ref))
out))))))
(defun org-babel-ref-goto-headline-id (id)
(goto-char (point-min))
(let ((rx (regexp-quote id)))
(or (re-search-forward
(concat "^[ \t]*:CUSTOM_ID:[ \t]+" rx "[ \t]*$") nil t)
(let* ((file (org-id-find-id-file id))
(m (when file (org-id-find-id-in-file id file 'marker))))
(when (and file m)
(message "file:%S" file)
(org-pop-to-buffer-same-window (marker-buffer m))
(goto-char m)
(move-marker m nil)
(org-show-context)
t)))))
(or (let ((h (org-find-property "CUSTOM_ID" id)))
(when h (goto-char h)))
(let* ((file (org-id-find-id-file id))
(m (when file (org-id-find-id-in-file id file 'marker))))
(when (and file m)
(message "file:%S" file)
(pop-to-buffer-same-window (marker-buffer m))
(goto-char m)
(move-marker m nil)
(org-show-context)
t))))
(defun org-babel-ref-headline-body ()
(save-restriction
(org-narrow-to-subtree)
(buffer-substring
(save-excursion (goto-char (point-min))
(forward-line 1)
(when (looking-at "[ \t]*:PROPERTIES:")
(re-search-forward ":END:" nil)
(forward-char))
(org-end-of-meta-data)
(point))
(point-max))))
@ -126,89 +123,82 @@ the variable."
(defun org-babel-ref-resolve (ref)
"Resolve the reference REF and return its value."
(save-window-excursion
(save-excursion
(let ((case-fold-search t)
type args new-refere new-header-args new-referent result
lob-info split-file split-ref index index-row index-col id)
;; if ref is indexed grab the indices -- beware nested indices
(when (and (string-match "\\[\\([^\\[]+\\)\\]$" ref)
(let ((str (substring ref 0 (match-beginning 0))))
(= (org-count ?\( str) (org-count ?\) str))))
(setq index (match-string 1 ref))
(setq ref (substring ref 0 (match-beginning 0))))
;; assign any arguments to pass to source block
(when (string-match
"^\\(.+?\\)\\(\\[\\(.*\\)\\]\\|\\(\\)\\)(\\(.*\\))$" ref)
(setq new-refere (match-string 1 ref))
(setq new-header-args (match-string 3 ref))
(setq new-referent (match-string 5 ref))
(when (> (length new-refere) 0)
(when (> (length new-referent) 0)
(setq args (mapcar (lambda (ref) (cons :var ref))
(org-babel-ref-split-args new-referent))))
(when (> (length new-header-args) 0)
(setq args (append (org-babel-parse-header-arguments
new-header-args) args)))
(setq ref new-refere)))
(when (string-match "^\\(.+\\):\\(.+\\)$" ref)
(setq split-file (match-string 1 ref))
(setq split-ref (match-string 2 ref))
(find-file split-file) (setq ref split-ref))
(save-restriction
(widen)
(goto-char (point-min))
(if (let ((src-rx (org-babel-named-src-block-regexp-for-name ref))
(res-rx (org-babel-named-data-regexp-for-name ref)))
;; goto ref in the current buffer
(or
;; check for code blocks
(re-search-forward src-rx nil t)
;; check for named data
(re-search-forward res-rx nil t)
;; check for local or global headlines by id
(setq id (org-babel-ref-goto-headline-id ref))
;; check the Library of Babel
(setq lob-info (cdr (assoc (intern ref)
org-babel-library-of-babel)))))
(unless (or lob-info id) (goto-char (match-beginning 0)))
;; ;; TODO: allow searching for names in other buffers
;; (setq id-loc (org-id-find ref 'marker)
;; buffer (marker-buffer id-loc)
;; loc (marker-position id-loc))
;; (move-marker id-loc nil)
(error "Reference `%s' not found in this buffer" ref))
(cond
(lob-info (setq type 'lob))
(id (setq type 'id))
((and (looking-at org-babel-src-name-regexp)
(save-excursion
(forward-line 1)
(or (looking-at org-babel-src-block-regexp)
(looking-at org-babel-multi-line-header-regexp))))
(setq type 'source-block))
(t (while (not (setq type (org-babel-ref-at-ref-p)))
(forward-line 1)
(beginning-of-line)
(if (or (= (point) (point-min)) (= (point) (point-max)))
(error "Reference not found")))))
(let ((params (append args '((:results . "silent")))))
(setq result
(case type
(results-line (org-babel-read-result))
(table (org-babel-read-table))
(list (org-babel-read-list))
(file (org-babel-read-link))
(source-block (org-babel-execute-src-block
nil nil (if org-babel-update-intermediate
nil params)))
(lob (org-babel-execute-src-block
nil lob-info params))
(id (org-babel-ref-headline-body)))))
(if (symbolp result)
(format "%S" result)
(if (and index (listp result))
(org-babel-ref-index-list index result)
result)))))))
(with-current-buffer (or org-babel-exp-reference-buffer (current-buffer))
(save-excursion
(let ((case-fold-search t)
args new-refere new-header-args new-referent split-file split-ref
index)
;; if ref is indexed grab the indices -- beware nested indices
(when (and (string-match "\\[\\([^\\[]+\\)\\]$" ref)
(let ((str (substring ref 0 (match-beginning 0))))
(= (cl-count ?\( str) (cl-count ?\) str))))
(setq index (match-string 1 ref))
(setq ref (substring ref 0 (match-beginning 0))))
;; assign any arguments to pass to source block
(when (string-match
"^\\(.+?\\)\\(\\[\\(.*\\)\\]\\|\\(\\)\\)(\\(.*\\))$" ref)
(setq new-refere (match-string 1 ref))
(setq new-header-args (match-string 3 ref))
(setq new-referent (match-string 5 ref))
(when (> (length new-refere) 0)
(when (> (length new-referent) 0)
(setq args (mapcar (lambda (ref) (cons :var ref))
(org-babel-ref-split-args new-referent))))
(when (> (length new-header-args) 0)
(setq args (append (org-babel-parse-header-arguments
new-header-args) args)))
(setq ref new-refere)))
(when (string-match "^\\(.+\\):\\(.+\\)$" ref)
(setq split-file (match-string 1 ref))
(setq split-ref (match-string 2 ref))
(find-file split-file)
(setq ref split-ref))
(org-with-wide-buffer
(goto-char (point-min))
(let* ((params (append args '((:results . "silent"))))
(regexp (org-babel-named-data-regexp-for-name ref))
(result
(catch :found
;; Check for code blocks or named data.
(while (re-search-forward regexp nil t)
;; Ignore COMMENTed headings and orphaned
;; affiliated keywords.
(unless (org-in-commented-heading-p)
(let ((e (org-element-at-point)))
(when (equal (org-element-property :name e) ref)
(goto-char
(org-element-property :post-affiliated e))
(pcase (org-element-type e)
(`babel-call
(throw :found
(org-babel-execute-src-block
nil (org-babel-lob-get-info e) params)))
(`src-block
(throw :found
(org-babel-execute-src-block
nil nil
(and
(not org-babel-update-intermediate)
params))))
((and (let v (org-babel-read-element e))
(guard v))
(throw :found v))
(_ (error "Reference not found")))))))
;; Check for local or global headlines by ID.
(when (org-babel-ref-goto-headline-id ref)
(throw :found (org-babel-ref-headline-body)))
;; Check the Library of Babel.
(let ((info (cdr (assq (intern ref)
org-babel-library-of-babel))))
(when info
(throw :found
(org-babel-execute-src-block nil info params))))
(error "Reference `%s' not found in this buffer" ref))))
(cond
((symbolp result) (format "%S" result))
((and index (listp result))
(org-babel-ref-index-list index result))
(t result)))))))))
(defun org-babel-ref-index-list (index lis)
"Return the subset of LIS indexed by INDEX.
@ -251,21 +241,9 @@ to \"0:-1\"."
(defun org-babel-ref-split-args (arg-string)
"Split ARG-STRING into top-level arguments of balanced parenthesis."
(mapcar #'org-babel-trim (org-babel-balanced-split arg-string 44)))
(mapcar #'org-trim (org-babel-balanced-split arg-string 44)))
(defvar org-bracket-link-regexp)
(defun org-babel-ref-at-ref-p ()
"Return the type of reference located at point.
Return nil if none of the supported reference types are found.
Supported reference types are tables and source blocks."
(cond ((org-at-table-p) 'table)
((org-at-item-p) 'list)
((looking-at "^[ \t]*#\\+BEGIN_SRC") 'source-block)
((looking-at org-bracket-link-regexp) 'file)
((looking-at org-babel-result-regexp) 'results-line)))
(provide 'ob-ref)
;;; ob-ref.el ends here

128
lisp/org/ob-ruby.el
View file

@ -1,4 +1,4 @@
;;; ob-ruby.el --- org-babel functions for ruby evaluation
;;; ob-ruby.el --- Babel Functions for Ruby -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -37,11 +37,14 @@
;;; Code:
(require 'ob)
(eval-when-compile (require 'cl))
(declare-function org-trim "org" (s &optional keep-lead))
(declare-function run-ruby "ext:inf-ruby" (&optional command name))
(declare-function xmp "ext:rcodetools" (&optional option))
(defvar inf-ruby-default-implementation)
(defvar inf-ruby-implementations)
(defvar org-babel-tangle-lang-exts)
(add-to-list 'org-babel-tangle-lang-exts '("ruby" . "rb"))
@ -68,16 +71,16 @@
"Execute a block of Ruby code with Babel.
This function is called by `org-babel-execute-src-block'."
(let* ((session (org-babel-ruby-initiate-session
(cdr (assoc :session params))))
(result-params (cdr (assoc :result-params params)))
(result-type (cdr (assoc :result-type params)))
(cdr (assq :session params))))
(result-params (cdr (assq :result-params params)))
(result-type (cdr (assq :result-type params)))
(full-body (org-babel-expand-body:generic
body params (org-babel-variable-assignments:ruby params)))
(result (if (member "xmp" result-params)
(with-temp-buffer
(require 'rcodetools)
(insert full-body)
(xmp (cdr (assoc :xmp-option params)))
(xmp (cdr (assq :xmp-option params)))
(buffer-string))
(org-babel-ruby-evaluate
session full-body result-type result-params))))
@ -85,10 +88,10 @@ This function is called by `org-babel-execute-src-block'."
(org-babel-result-cond result-params
result
(org-babel-ruby-table-or-string result))
(org-babel-pick-name (cdr (assoc :colname-names params))
(cdr (assoc :colnames params)))
(org-babel-pick-name (cdr (assoc :rowname-names params))
(cdr (assoc :rownames params))))))
(org-babel-pick-name (cdr (assq :colname-names params))
(cdr (assq :colnames params)))
(org-babel-pick-name (cdr (assq :rowname-names params))
(cdr (assq :rownames params))))))
(defun org-babel-prep-session:ruby (session params)
"Prepare SESSION according to the header arguments specified in PARAMS."
@ -121,7 +124,7 @@ This function is called by `org-babel-execute-src-block'."
(format "%s=%s"
(car pair)
(org-babel-ruby-var-to-ruby (cdr pair))))
(mapcar #'cdr (org-babel-get-header params :var))))
(org-babel--get-vars params)))
(defun org-babel-ruby-var-to-ruby (var)
"Convert VAR into a ruby variable.
@ -129,7 +132,7 @@ Convert an elisp value into a string of ruby source code
specifying a variable of the same value."
(if (listp var)
(concat "[" (mapconcat #'org-babel-ruby-var-to-ruby var ", ") "]")
(if (equal var 'hline)
(if (eq var 'hline)
org-babel-ruby-hline-to
(format "%S" var))))
@ -139,23 +142,27 @@ If RESULTS look like a table, then convert them into an
Emacs-lisp table, otherwise return the results as a string."
(let ((res (org-babel-script-escape results)))
(if (listp res)
(mapcar (lambda (el) (if (equal el 'nil)
org-babel-ruby-nil-to el))
(mapcar (lambda (el) (if (not el)
org-babel-ruby-nil-to el))
res)
res)))
(defun org-babel-ruby-initiate-session (&optional session params)
(defun org-babel-ruby-initiate-session (&optional session _params)
"Initiate a ruby session.
If there is not a current inferior-process-buffer in SESSION
then create one. Return the initialized session."
(unless (string= session "none")
(require 'inf-ruby)
(let ((session-buffer (save-window-excursion
(run-ruby nil session) (current-buffer))))
(let* ((cmd (cdr (assoc inf-ruby-default-implementation
inf-ruby-implementations)))
(buffer (get-buffer (format "*%s*" session)))
(session-buffer (or buffer (save-window-excursion
(run-ruby cmd session)
(current-buffer)))))
(if (org-babel-comint-buffer-livep session-buffer)
(progn (sit-for .25) session-buffer)
(sit-for .5)
(org-babel-ruby-initiate-session session)))))
(sit-for .5)
(org-babel-ruby-initiate-session session)))))
(defvar org-babel-ruby-eoe-indicator ":org_babel_ruby_eoe"
"String to indicate that evaluation has completed.")
@ -185,46 +192,53 @@ end
")
(defun org-babel-ruby-evaluate
(buffer body &optional result-type result-params)
(buffer body &optional result-type result-params)
"Pass BODY to the Ruby process in BUFFER.
If RESULT-TYPE equals 'output then return a list of the outputs
of the statements in BODY, if RESULT-TYPE equals 'value then
If RESULT-TYPE equals `output' then return a list of the outputs
of the statements in BODY, if RESULT-TYPE equals `value' then
return the value of the last statement in BODY, as elisp."
(if (not buffer)
;; external process evaluation
(case result-type
(output (org-babel-eval org-babel-ruby-command body))
(value (let ((tmp-file (org-babel-temp-file "ruby-")))
(org-babel-eval
org-babel-ruby-command
(format (if (member "pp" result-params)
org-babel-ruby-pp-wrapper-method
org-babel-ruby-wrapper-method)
body (org-babel-process-file-name tmp-file 'noquote)))
(let ((raw (org-babel-eval-read-file tmp-file)))
(if (or (member "code" result-params)
(member "pp" result-params))
raw
(org-babel-ruby-table-or-string raw))))))
(pcase result-type
(`output (org-babel-eval org-babel-ruby-command body))
(`value (let ((tmp-file (org-babel-temp-file "ruby-")))
(org-babel-eval
org-babel-ruby-command
(format (if (member "pp" result-params)
org-babel-ruby-pp-wrapper-method
org-babel-ruby-wrapper-method)
body (org-babel-process-file-name tmp-file 'noquote)))
(org-babel-eval-read-file tmp-file))))
;; comint session evaluation
(case result-type
(output
(mapconcat
#'identity
(butlast
(split-string
(mapconcat
#'org-babel-trim
(butlast
(org-babel-comint-with-output
(buffer org-babel-ruby-eoe-indicator t body)
(mapc
(lambda (line)
(insert (org-babel-chomp line)) (comint-send-input nil t))
(list body org-babel-ruby-eoe-indicator))
(comint-send-input nil t)) 2)
"\n") "[\r\n]")) "\n"))
(value
(pcase result-type
(`output
(let ((eoe-string (format "puts \"%s\"" org-babel-ruby-eoe-indicator)))
;; Force the session to be ready before the actual session
;; code is run. There is some problem in comint that will
;; sometimes show the prompt after the the input has already
;; been inserted and that throws off the extraction of the
;; result for Babel.
(org-babel-comint-with-output
(buffer org-babel-ruby-eoe-indicator t eoe-string)
(insert eoe-string) (comint-send-input nil t))
;; Now we can start the evaluation.
(mapconcat
#'identity
(butlast
(split-string
(mapconcat
#'org-trim
(org-babel-comint-with-output
(buffer org-babel-ruby-eoe-indicator t body)
(mapc
(lambda (line)
(insert (org-babel-chomp line)) (comint-send-input nil t))
(list "conf.echo=false;_org_prompt_mode=conf.prompt_mode;conf.prompt_mode=:NULL"
body
"conf.prompt_mode=_org_prompt_mode;conf.echo=true"
eoe-string)))
"\n") "[\r\n]") 4) "\n")))
(`value
(let* ((tmp-file (org-babel-temp-file "ruby-"))
(ppp (or (member "code" result-params)
(member "pp" result-params))))
@ -247,12 +261,6 @@ return the value of the last statement in BODY, as elisp."
(comint-send-input nil t))
(org-babel-eval-read-file tmp-file))))))
(defun org-babel-ruby-read-string (string)
"Strip \\\"s from around a ruby string."
(if (string-match "^\"\\([^\000]+\\)\"$" string)
(match-string 1 string)
string))
(provide 'ob-ruby)

9
lisp/org/ob-sass.el
View file

@ -1,4 +1,4 @@
;;; ob-sass.el --- org-babel functions for the sass css generation language
;;; ob-sass.el --- Babel Functions for the Sass CSS generation language -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -45,10 +45,9 @@
(defun org-babel-execute:sass (body params)
"Execute a block of Sass code with Babel.
This function is called by `org-babel-execute-src-block'."
(let* ((result-params (split-string (or (cdr (assoc :results params)) "")))
(file (cdr (assoc :file params)))
(let* ((file (cdr (assq :file params)))
(out-file (or file (org-babel-temp-file "sass-out-")))
(cmdline (cdr (assoc :cmdline params)))
(cmdline (cdr (assq :cmdline params)))
(in-file (org-babel-temp-file "sass-in-"))
(cmd (concat "sass " (or cmdline "")
" " (org-babel-process-file-name in-file)
@ -60,7 +59,7 @@ This function is called by `org-babel-execute-src-block'."
nil ;; signal that output has already been written to file
(with-temp-buffer (insert-file-contents out-file) (buffer-string)))))
(defun org-babel-prep-session:sass (session params)
(defun org-babel-prep-session:sass (_session _params)
"Raise an error because sass does not support sessions."
(error "Sass does not support sessions"))

42
lisp/org/ob-scala.el
View file

@ -1,4 +1,4 @@
;;; ob-scala.el --- org-babel functions for Scala evaluation
;;; ob-scala.el --- Babel Functions for Scala -*- lexical-binding: t; -*-
;; Copyright (C) 2012-2017 Free Software Foundation, Inc.
@ -31,7 +31,6 @@
;;; Code:
(require 'ob)
(eval-when-compile (require 'cl))
(defvar org-babel-tangle-lang-exts) ;; Autoloaded
(add-to-list 'org-babel-tangle-lang-exts '("scala" . "scala"))
@ -45,9 +44,8 @@ called by `org-babel-execute-src-block'"
(message "executing Scala source code block")
(let* ((processed-params (org-babel-process-params params))
(session (org-babel-scala-initiate-session (nth 0 processed-params)))
(vars (nth 1 processed-params))
(result-params (nth 2 processed-params))
(result-type (cdr (assoc :result-type params)))
(result-type (cdr (assq :result-type params)))
(full-body (org-babel-expand-body:generic
body params))
(result (org-babel-scala-evaluate
@ -56,17 +54,9 @@ called by `org-babel-execute-src-block'"
(org-babel-reassemble-table
result
(org-babel-pick-name
(cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
(cdr (assq :colname-names params)) (cdr (assq :colnames params)))
(org-babel-pick-name
(cdr (assoc :rowname-names params)) (cdr (assoc :rownames params))))))
(defun org-babel-scala-table-or-string (results)
"Convert RESULTS into an appropriate elisp value.
If RESULTS look like a table, then convert them into an
Emacs-lisp table, otherwise return the results as a string."
(org-babel-script-escape results))
(cdr (assq :rowname-names params)) (cdr (assq :rownames params))))))
(defvar org-babel-scala-wrapper-method
@ -84,19 +74,19 @@ print(str_result)
(defun org-babel-scala-evaluate
(session body &optional result-type result-params)
(session body &optional result-type result-params)
"Evaluate BODY in external Scala process.
If RESULT-TYPE equals 'output then return standard output as a string.
If RESULT-TYPE equals 'value then return the value of the last statement
If RESULT-TYPE equals `output' then return standard output as a string.
If RESULT-TYPE equals `value' then return the value of the last statement
in BODY as elisp."
(when session (error "Sessions are not (yet) supported for Scala"))
(case result-type
(output
(pcase result-type
(`output
(let ((src-file (org-babel-temp-file "scala-")))
(progn (with-temp-file src-file (insert body))
(org-babel-eval
(concat org-babel-scala-command " " src-file) ""))))
(value
(with-temp-file src-file (insert body))
(org-babel-eval
(concat org-babel-scala-command " " src-file) "")))
(`value
(let* ((src-file (org-babel-temp-file "scala-"))
(wrapper (format org-babel-scala-wrapper-method body)))
(with-temp-file src-file (insert wrapper))
@ -104,14 +94,14 @@ in BODY as elisp."
(concat org-babel-scala-command " " src-file) "")))
(org-babel-result-cond result-params
raw
(org-babel-scala-table-or-string raw)))))))
(org-babel-script-escape raw)))))))
(defun org-babel-prep-session:scala (session params)
(defun org-babel-prep-session:scala (_session _params)
"Prepare SESSION according to the header arguments specified in PARAMS."
(error "Sessions are not (yet) supported for Scala"))
(defun org-babel-scala-initiate-session (&optional session)
(defun org-babel-scala-initiate-session (&optional _session)
"If there is not a current inferior-process-buffer in SESSION
then create. Return the initialized session. Sessions are not
supported in Scala."

45
lisp/org/ob-scheme.el
View file

@ -1,4 +1,4 @@
;;; ob-scheme.el --- org-babel functions for Scheme
;;; ob-scheme.el --- Babel Functions for Scheme -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
@ -56,7 +56,7 @@
(defun org-babel-expand-body:scheme (body params)
"Expand BODY according to PARAMS, return the expanded body."
(let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
(let ((vars (org-babel--get-vars params)))
(if (> (length vars) 0)
(concat "(let ("
(mapconcat
@ -119,6 +119,22 @@ org-babel-scheme-execute-with-geiser will use a temporary session."
(name))))
result))
(defmacro org-babel-scheme-capture-current-message (&rest body)
"Capture current message in both interactive and noninteractive mode"
`(if noninteractive
(let ((original-message (symbol-function 'message))
(current-message nil))
(unwind-protect
(progn
(defun message (&rest args)
(setq current-message (apply original-message args)))
,@body
current-message)
(fset 'message original-message)))
(progn
,@body
(current-message))))
(defun org-babel-scheme-execute-with-geiser (code output impl repl)
"Execute code in specified REPL. If the REPL doesn't exist, create it
using the given scheme implementation.
@ -143,10 +159,11 @@ is true; otherwise returns the last value."
(current-buffer)))))
(setq geiser-repl--repl repl-buffer)
(setq geiser-impl--implementation nil)
(geiser-eval-region (point-min) (point-max))
(setq result (org-babel-scheme-capture-current-message
(geiser-eval-region (point-min) (point-max))))
(setq result
(if (equal (substring (current-message) 0 3) "=> ")
(replace-regexp-in-string "^=> " "" (current-message))
(if (and (stringp result) (equal (substring result 0 3) "=> "))
(replace-regexp-in-string "^=> " "" result)
"\"An error occurred.\""))
(when (not repl)
(save-current-buffer (set-buffer repl-buffer)
@ -156,7 +173,7 @@ is true; otherwise returns the last value."
(setq result (if (or (string= result "#<void>")
(string= result "#<unspecified>"))
nil
(read result)))))
result))))
result))
(defun org-babel-execute:scheme (body params)
@ -168,23 +185,23 @@ This function is called by `org-babel-execute-src-block'"
(buffer-name source-buffer))))
(save-excursion
(org-babel-reassemble-table
(let* ((result-type (cdr (assoc :result-type params)))
(impl (or (when (cdr (assoc :scheme params))
(intern (cdr (assoc :scheme params))))
(let* ((result-type (cdr (assq :result-type params)))
(impl (or (when (cdr (assq :scheme params))
(intern (cdr (assq :scheme params))))
geiser-default-implementation
(car geiser-active-implementations)))
(session (org-babel-scheme-make-session-name
source-buffer-name (cdr (assoc :session params)) impl))
source-buffer-name (cdr (assq :session params)) impl))
(full-body (org-babel-expand-body:scheme body params)))
(org-babel-scheme-execute-with-geiser
full-body ; code
(string= result-type "output") ; output?
impl ; implementation
(and (not (string= session "none")) session))) ; session
(org-babel-pick-name (cdr (assoc :colname-names params))
(cdr (assoc :colnames params)))
(org-babel-pick-name (cdr (assoc :rowname-names params))
(cdr (assoc :rownames params)))))))
(org-babel-pick-name (cdr (assq :colname-names params))
(cdr (assq :colnames params)))
(org-babel-pick-name (cdr (assq :rowname-names params))
(cdr (assq :rownames params)))))))
(provide 'ob-scheme)

20
lisp/org/ob-screen.el
View file

@ -1,4 +1,4 @@
;;; ob-screen.el --- org-babel support for interactive terminal
;;; ob-screen.el --- Babel Support for Interactive Terminal -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -48,18 +48,17 @@ In case you want to use a different screen than one selected by your $PATH")
\"default\" session is used when none is specified."
(message "Sending source code block to interactive terminal session...")
(save-window-excursion
(let* ((session (cdr (assoc :session params)))
(let* ((session (cdr (assq :session params)))
(socket (org-babel-screen-session-socketname session)))
(unless socket (org-babel-prep-session:screen session params))
(org-babel-screen-session-execute-string
session (org-babel-expand-body:generic body params)))))
(defun org-babel-prep-session:screen (session params)
(defun org-babel-prep-session:screen (_session params)
"Prepare SESSION according to the header arguments specified in PARAMS."
(let* ((session (cdr (assoc :session params)))
(socket (org-babel-screen-session-socketname session))
(cmd (cdr (assoc :cmd params)))
(terminal (cdr (assoc :terminal params)))
(let* ((session (cdr (assq :session params)))
(cmd (cdr (assq :cmd params)))
(terminal (cdr (assq :terminal params)))
(process-name (concat "org-babel: terminal (" session ")")))
(apply 'start-process process-name "*Messages*"
terminal `("-T" ,(concat "org-babel: " session) "-e" ,org-babel-screen-location
@ -104,7 +103,7 @@ In case you want to use a different screen than one selected by your $PATH")
sockets)))))
(when match-socket (car (split-string match-socket)))))
(defun org-babel-screen-session-write-temp-file (session body)
(defun org-babel-screen-session-write-temp-file (_session body)
"Save BODY in a temp file that is named after SESSION."
(let ((tmpfile (org-babel-temp-file "screen-")))
(with-temp-file tmpfile
@ -119,11 +118,10 @@ In case you want to use a different screen than one selected by your $PATH")
"Test if the default setup works.
The terminal should shortly flicker."
(interactive)
(let* ((session "org-babel-testing")
(random-string (format "%s" (random 99999)))
(let* ((random-string (format "%s" (random 99999)))
(tmpfile (org-babel-temp-file "ob-screen-test-"))
(body (concat "echo '" random-string "' > " tmpfile "\nexit\n"))
process tmp-string)
tmp-string)
(org-babel-execute:screen body org-babel-default-header-args:screen)
;; XXX: need to find a better way to do the following
(while (not (file-readable-p tmpfile))

107
lisp/org/ob-sed.el Normal file
View file

@ -0,0 +1,107 @@
;;; ob-sed.el --- Babel Functions for Sed Scripts -*- lexical-binding: t; -*-
;; Copyright (C) 2015-2017 Free Software Foundation, Inc.
;; Author: Bjarte Johansen
;; Keywords: literate programming, reproducible research
;; Version: 0.1.0
;; This file is part of GNU Emacs.
;;; License:
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Provides a way to evaluate sed scripts in Org mode.
;;; Usage:
;; Add to your Emacs config:
;; (org-babel-do-load-languages
;; 'org-babel-load-languages
;; '((sed . t)))
;; In addition to the normal header arguments, ob-sed also provides
;; :cmd-line and :in-file. :cmd-line allows one to pass other flags to
;; the sed command like the "--in-place" flag which makes sed edit the
;; file pass to it instead of outputting to standard out or to a
;; different file. :in-file is a header arguments that allows one to
;; tell Org Babel which file the sed script to act on.
;;; Code:
(require 'ob)
(defvar org-babel-sed-command "sed"
"Name of the sed executable command.")
(defvar org-babel-tangle-lang-exts)
(add-to-list 'org-babel-tangle-lang-exts '("sed" . "sed"))
(defconst org-babel-header-args:sed
'((:cmd-line . :any)
(:in-file . :any))
"Sed specific header arguments.")
(defvar org-babel-default-header-args:sed '()
"Default arguments for evaluating a sed source block.")
(defun org-babel-execute:sed (body params)
"Execute a block of sed code with Org Babel.
BODY is the source inside a sed source block and PARAMS is an
association list over the source block configurations. This
function is called by `org-babel-execute-src-block'."
(message "executing sed source code block")
(let* ((result-params (cdr (assq :result-params params)))
(cmd-line (cdr (assq :cmd-line params)))
(in-file (cdr (assq :in-file params)))
(code-file (let ((file (org-babel-temp-file "sed-")))
(with-temp-file file
(insert body)) file))
(stdin (let ((stdin (cdr (assq :stdin params))))
(when stdin
(let ((tmp (org-babel-temp-file "sed-stdin-"))
(res (org-babel-ref-resolve stdin)))
(with-temp-file tmp
(insert res))
tmp))))
(cmd (mapconcat #'identity
(remq nil
(list org-babel-sed-command
(format "--file=\"%s\"" code-file)
cmd-line
in-file))
" ")))
(org-babel-reassemble-table
(let ((results
(cond
(stdin (with-temp-buffer
(call-process-shell-command cmd stdin (current-buffer))
(buffer-string)))
(t (org-babel-eval cmd "")))))
(when results
(org-babel-result-cond result-params
results
(let ((tmp (org-babel-temp-file "sed-results-")))
(with-temp-file tmp (insert results))
(org-babel-import-elisp-from-file tmp)))))
(org-babel-pick-name
(cdr (assq :colname-names params)) (cdr (assq :colnames params)))
(org-babel-pick-name
(cdr (assq :rowname-names params)) (cdr (assq :rownames params))))))
(provide 'ob-sed)
;;; ob-sed.el ends here

217
lisp/org/ob-sh.el
View file

@ -1,217 +0,0 @@
;;; ob-sh.el --- org-babel functions for shell evaluation
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
;; Author: Eric Schulte
;; Keywords: literate programming, reproducible research
;; Homepage: http://orgmode.org
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Org-Babel support for evaluating shell source code.
;;; Code:
(require 'ob)
(require 'shell)
(eval-when-compile (require 'cl))
(declare-function org-babel-comint-wait-for-output "ob-comint" (buffer))
(declare-function org-babel-comint-buffer-livep "ob-comint" (buffer))
(declare-function orgtbl-to-generic "org-table"
(table params &optional backend))
(defvar org-babel-default-header-args:sh '())
(defvar org-babel-sh-command "sh"
"Command used to invoke a shell.
This will be passed to `shell-command-on-region'")
(defcustom org-babel-sh-var-quote-fmt
"$(cat <<'BABEL_TABLE'\n%s\nBABEL_TABLE\n)"
"Format string used to escape variables when passed to shell scripts."
:group 'org-babel
:type 'string)
(defun org-babel-execute:sh (body params)
"Execute a block of Shell commands with Babel.
This function is called by `org-babel-execute-src-block'."
(let* ((session (org-babel-sh-initiate-session
(cdr (assoc :session params))))
(stdin (let ((stdin (cdr (assoc :stdin params))))
(when stdin (org-babel-sh-var-to-string
(org-babel-ref-resolve stdin)))))
(full-body (org-babel-expand-body:generic
body params (org-babel-variable-assignments:sh params))))
(org-babel-reassemble-table
(org-babel-sh-evaluate session full-body params stdin)
(org-babel-pick-name
(cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
(org-babel-pick-name
(cdr (assoc :rowname-names params)) (cdr (assoc :rownames params))))))
(defun org-babel-prep-session:sh (session params)
"Prepare SESSION according to the header arguments specified in PARAMS."
(let* ((session (org-babel-sh-initiate-session session))
(var-lines (org-babel-variable-assignments:sh params)))
(org-babel-comint-in-buffer session
(mapc (lambda (var)
(insert var) (comint-send-input nil t)
(org-babel-comint-wait-for-output session)) var-lines))
session))
(defun org-babel-load-session:sh (session body params)
"Load BODY into SESSION."
(save-window-excursion
(let ((buffer (org-babel-prep-session:sh session params)))
(with-current-buffer buffer
(goto-char (process-mark (get-buffer-process (current-buffer))))
(insert (org-babel-chomp body)))
buffer)))
;; helper functions
(defun org-babel-variable-assignments:sh (params)
"Return list of shell statements assigning the block's variables."
(let ((sep (cdr (assoc :separator params))))
(mapcar
(lambda (pair)
(format "%s=%s"
(car pair)
(org-babel-sh-var-to-sh (cdr pair) sep)))
(mapcar #'cdr (org-babel-get-header params :var)))))
(defun org-babel-sh-var-to-sh (var &optional sep)
"Convert an elisp value to a shell variable.
Convert an elisp var into a string of shell commands specifying a
var of the same value."
(format org-babel-sh-var-quote-fmt (org-babel-sh-var-to-string var sep)))
(defun org-babel-sh-var-to-string (var &optional sep)
"Convert an elisp value to a string."
(let ((echo-var (lambda (v) (if (stringp v) v (format "%S" v)))))
(cond
((and (listp var) (or (listp (car var)) (equal (car var) 'hline)))
(orgtbl-to-generic var (list :sep (or sep "\t") :fmt echo-var)))
((listp var)
(mapconcat echo-var var "\n"))
(t (funcall echo-var var)))))
(defun org-babel-sh-table-or-results (results)
"Convert RESULTS to an appropriate elisp value.
If the results look like a table, then convert them into an
Emacs-lisp table, otherwise return the results as a string."
(org-babel-script-escape results))
(defun org-babel-sh-initiate-session (&optional session params)
"Initiate a session named SESSION according to PARAMS."
(when (and session (not (string= session "none")))
(save-window-excursion
(or (org-babel-comint-buffer-livep session)
(progn
(shell session)
;; Needed for Emacs 23 since the marker is initially
;; undefined and the filter functions try to use it without
;; checking.
(set-marker comint-last-output-start (point))
(get-buffer (current-buffer)))))))
(defvar org-babel-sh-eoe-indicator "echo 'org_babel_sh_eoe'"
"String to indicate that evaluation has completed.")
(defvar org-babel-sh-eoe-output "org_babel_sh_eoe"
"String to indicate that evaluation has completed.")
(defun org-babel-sh-evaluate (session body &optional params stdin)
"Pass BODY to the Shell process in BUFFER.
If RESULT-TYPE equals 'output then return a list of the outputs
of the statements in BODY, if RESULT-TYPE equals 'value then
return the value of the last statement in BODY."
(let ((results
(cond
(stdin ; external shell script w/STDIN
(let ((script-file (org-babel-temp-file "sh-script-"))
(stdin-file (org-babel-temp-file "sh-stdin-"))
(shebang (cdr (assoc :shebang params)))
(padline (not (string= "no" (cdr (assoc :padline params))))))
(with-temp-file script-file
(when shebang (insert (concat shebang "\n")))
(when padline (insert "\n"))
(insert body))
(set-file-modes script-file #o755)
(with-temp-file stdin-file (insert stdin))
(with-temp-buffer
(call-process-shell-command
(if shebang
script-file
(format "%s %s" org-babel-sh-command script-file))
stdin-file
(current-buffer))
(buffer-string))))
(session ; session evaluation
(mapconcat
#'org-babel-sh-strip-weird-long-prompt
(mapcar
#'org-babel-trim
(butlast
(org-babel-comint-with-output
(session org-babel-sh-eoe-output t body)
(mapc
(lambda (line)
(insert line)
(comint-send-input nil t)
(while (save-excursion
(goto-char comint-last-input-end)
(not (re-search-forward
comint-prompt-regexp nil t)))
(accept-process-output
(get-buffer-process (current-buffer)))))
(append
(split-string (org-babel-trim body) "\n")
(list org-babel-sh-eoe-indicator))))
2)) "\n"))
('otherwise ; external shell script
(if (and (cdr (assoc :shebang params))
(> (length (cdr (assoc :shebang params))) 0))
(let ((script-file (org-babel-temp-file "sh-script-"))
(shebang (cdr (assoc :shebang params)))
(padline (not (equal "no" (cdr (assoc :padline params))))))
(with-temp-file script-file
(when shebang (insert (concat shebang "\n")))
(when padline (insert "\n"))
(insert body))
(set-file-modes script-file #o755)
(org-babel-eval script-file ""))
(org-babel-eval org-babel-sh-command (org-babel-trim body)))))))
(when results
(let ((result-params (cdr (assoc :result-params params))))
(org-babel-result-cond result-params
results
(let ((tmp-file (org-babel-temp-file "sh-")))
(with-temp-file tmp-file (insert results))
(org-babel-import-elisp-from-file tmp-file)))))))
(defun org-babel-sh-strip-weird-long-prompt (string)
"Remove prompt cruft from a string of shell output."
(while (string-match "^% +[\r\n$]+ *" string)
(setq string (substring string (match-end 0))))
string)
(provide 'ob-sh)
;;; ob-sh.el ends here

283
lisp/org/ob-shell.el Normal file
View file

@ -0,0 +1,283 @@
;;; ob-shell.el --- Babel Functions for Shell Evaluation -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
;; Author: Eric Schulte
;; Keywords: literate programming, reproducible research
;; Homepage: http://orgmode.org
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Org-Babel support for evaluating shell source code.
;;; Code:
(require 'ob)
(require 'shell)
(require 'cl-lib)
(declare-function org-babel-comint-in-buffer "ob-comint" (buffer &rest body)
t)
(declare-function org-babel-comint-wait-for-output "ob-comint" (buffer))
(declare-function org-babel-comint-buffer-livep "ob-comint" (buffer))
(declare-function org-babel-comint-with-output "ob-comint" (meta &rest body)
t)
(declare-function org-trim "org" (s &optional keep-lead))
(declare-function orgtbl-to-generic "org-table" (table params))
(defvar org-babel-default-header-args:shell '())
(defvar org-babel-shell-names)
(defun org-babel-shell-initialize ()
"Define execution functions associated to shell names.
This function has to be called whenever `org-babel-shell-names'
is modified outside the Customize interface."
(interactive)
(dolist (name org-babel-shell-names)
(eval `(defun ,(intern (concat "org-babel-execute:" name))
(body params)
,(format "Execute a block of %s commands with Babel." name)
(let ((shell-file-name ,name))
(org-babel-execute:shell body params))))
(eval `(defalias ',(intern (concat "org-babel-variable-assignments:" name))
'org-babel-variable-assignments:shell
,(format "Return list of %s statements assigning to the block's \
variables."
name)))))
(defcustom org-babel-shell-names
'("sh" "bash" "csh" "ash" "dash" "ksh" "mksh" "posh")
"List of names of shell supported by babel shell code blocks.
Call `org-babel-shell-initialize' when modifying this variable
outside the Customize interface."
:group 'org-babel
:type '(repeat (string :tag "Shell name: "))
:set (lambda (symbol value)
(set-default symbol value)
(org-babel-shell-initialize)))
(defun org-babel-execute:shell (body params)
"Execute a block of Shell commands with Babel.
This function is called by `org-babel-execute-src-block'."
(let* ((session (org-babel-sh-initiate-session
(cdr (assq :session params))))
(stdin (let ((stdin (cdr (assq :stdin params))))
(when stdin (org-babel-sh-var-to-string
(org-babel-ref-resolve stdin)))))
(cmdline (cdr (assq :cmdline params)))
(full-body (org-babel-expand-body:generic
body params (org-babel-variable-assignments:shell params))))
(org-babel-reassemble-table
(org-babel-sh-evaluate session full-body params stdin cmdline)
(org-babel-pick-name
(cdr (assq :colname-names params)) (cdr (assq :colnames params)))
(org-babel-pick-name
(cdr (assq :rowname-names params)) (cdr (assq :rownames params))))))
(defun org-babel-prep-session:shell (session params)
"Prepare SESSION according to the header arguments specified in PARAMS."
(let* ((session (org-babel-sh-initiate-session session))
(var-lines (org-babel-variable-assignments:shell params)))
(org-babel-comint-in-buffer session
(mapc (lambda (var)
(insert var) (comint-send-input nil t)
(org-babel-comint-wait-for-output session)) var-lines))
session))
(defun org-babel-load-session:shell (session body params)
"Load BODY into SESSION."
(save-window-excursion
(let ((buffer (org-babel-prep-session:shell session params)))
(with-current-buffer buffer
(goto-char (process-mark (get-buffer-process (current-buffer))))
(insert (org-babel-chomp body)))
buffer)))
;;; Helper functions
(defun org-babel--variable-assignments:sh-generic
(varname values &optional sep hline)
"Returns a list of statements declaring the values as a generic variable."
(format "%s=%s" varname (org-babel-sh-var-to-sh values sep hline)))
(defun org-babel--variable-assignments:bash_array
(varname values &optional sep hline)
"Returns a list of statements declaring the values as a bash array."
(format "unset %s\ndeclare -a %s=( %s )"
varname varname
(mapconcat
(lambda (value) (org-babel-sh-var-to-sh value sep hline))
values
" ")))
(defun org-babel--variable-assignments:bash_assoc
(varname values &optional sep hline)
"Returns a list of statements declaring the values as bash associative array."
(format "unset %s\ndeclare -A %s\n%s"
varname varname
(mapconcat
(lambda (items)
(format "%s[%s]=%s"
varname
(org-babel-sh-var-to-sh (car items) sep hline)
(org-babel-sh-var-to-sh (cdr items) sep hline)))
values
"\n")))
(defun org-babel--variable-assignments:bash (varname values &optional sep hline)
"Represents the parameters as useful Bash shell variables."
(pcase values
(`((,_ ,_ . ,_) . ,_) ;two-dimensional array
(org-babel--variable-assignments:bash_assoc varname values sep hline))
(`(,_ . ,_) ;simple list
(org-babel--variable-assignments:bash_array varname values sep hline))
(_ ;scalar value
(org-babel--variable-assignments:sh-generic varname values sep hline))))
(defun org-babel-variable-assignments:shell (params)
"Return list of shell statements assigning the block's variables."
(let ((sep (cdr (assq :separator params)))
(hline (when (string= "yes" (cdr (assq :hlines params)))
(or (cdr (assq :hline-string params))
"hline"))))
(mapcar
(lambda (pair)
(if (string-suffix-p "bash" shell-file-name)
(org-babel--variable-assignments:bash
(car pair) (cdr pair) sep hline)
(org-babel--variable-assignments:sh-generic
(car pair) (cdr pair) sep hline)))
(org-babel--get-vars params))))
(defun org-babel-sh-var-to-sh (var &optional sep hline)
"Convert an elisp value to a shell variable.
Convert an elisp var into a string of shell commands specifying a
var of the same value."
(concat "'" (replace-regexp-in-string
"'" "'\"'\"'"
(org-babel-sh-var-to-string var sep hline))
"'"))
(defun org-babel-sh-var-to-string (var &optional sep hline)
"Convert an elisp value to a string."
(let ((echo-var (lambda (v) (if (stringp v) v (format "%S" v)))))
(cond
((and (listp var) (or (listp (car var)) (eq (car var) 'hline)))
(orgtbl-to-generic var (list :sep (or sep "\t") :fmt echo-var
:hline hline)))
((listp var)
(mapconcat echo-var var "\n"))
(t (funcall echo-var var)))))
(defun org-babel-sh-initiate-session (&optional session _params)
"Initiate a session named SESSION according to PARAMS."
(when (and session (not (string= session "none")))
(save-window-excursion
(or (org-babel-comint-buffer-livep session)
(progn
(shell session)
;; Needed for Emacs 23 since the marker is initially
;; undefined and the filter functions try to use it without
;; checking.
(set-marker comint-last-output-start (point))
(get-buffer (current-buffer)))))))
(defvar org-babel-sh-eoe-indicator "echo 'org_babel_sh_eoe'"
"String to indicate that evaluation has completed.")
(defvar org-babel-sh-eoe-output "org_babel_sh_eoe"
"String to indicate that evaluation has completed.")
(defun org-babel-sh-evaluate (session body &optional params stdin cmdline)
"Pass BODY to the Shell process in BUFFER.
If RESULT-TYPE equals `output' then return a list of the outputs
of the statements in BODY, if RESULT-TYPE equals `value' then
return the value of the last statement in BODY."
(let ((results
(cond
((or stdin cmdline) ; external shell script w/STDIN
(let ((script-file (org-babel-temp-file "sh-script-"))
(stdin-file (org-babel-temp-file "sh-stdin-"))
(shebang (cdr (assq :shebang params)))
(padline (not (string= "no" (cdr (assq :padline params))))))
(with-temp-file script-file
(when shebang (insert (concat shebang "\n")))
(when padline (insert "\n"))
(insert body))
(set-file-modes script-file #o755)
(with-temp-file stdin-file (insert (or stdin "")))
(with-temp-buffer
(call-process-shell-command
(concat (if shebang script-file
(format "%s %s" shell-file-name script-file))
(and cmdline (concat " " cmdline)))
stdin-file
(current-buffer))
(buffer-string))))
(session ; session evaluation
(mapconcat
#'org-babel-sh-strip-weird-long-prompt
(mapcar
#'org-trim
(butlast
(org-babel-comint-with-output
(session org-babel-sh-eoe-output t body)
(mapc
(lambda (line)
(insert line)
(comint-send-input nil t)
(while (save-excursion
(goto-char comint-last-input-end)
(not (re-search-forward
comint-prompt-regexp nil t)))
(accept-process-output
(get-buffer-process (current-buffer)))))
(append
(split-string (org-trim body) "\n")
(list org-babel-sh-eoe-indicator))))
2)) "\n"))
('otherwise ; external shell script
(if (and (cdr (assq :shebang params))
(> (length (cdr (assq :shebang params))) 0))
(let ((script-file (org-babel-temp-file "sh-script-"))
(shebang (cdr (assq :shebang params)))
(padline (not (equal "no" (cdr (assq :padline params))))))
(with-temp-file script-file
(when shebang (insert (concat shebang "\n")))
(when padline (insert "\n"))
(insert body))
(set-file-modes script-file #o755)
(org-babel-eval script-file ""))
(org-babel-eval shell-file-name (org-trim body)))))))
(when results
(let ((result-params (cdr (assq :result-params params))))
(org-babel-result-cond result-params
results
(let ((tmp-file (org-babel-temp-file "sh-")))
(with-temp-file tmp-file (insert results))
(org-babel-import-elisp-from-file tmp-file)))))))
(defun org-babel-sh-strip-weird-long-prompt (string)
"Remove prompt cruft from a string of shell output."
(while (string-match "^% +[\r\n$]+ *" string)
(setq string (substring string (match-end 0))))
string)
(provide 'ob-shell)
;;; ob-shell.el ends here

9
lisp/org/ob-shen.el
View file

@ -1,4 +1,4 @@
;;; ob-shen.el --- org-babel functions for Shen
;;; ob-shen.el --- Babel Functions for Shen -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
@ -43,7 +43,7 @@
(defun org-babel-expand-body:shen (body params)
"Expand BODY according to PARAMS, return the expanded body."
(let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
(let ((vars (org-babel--get-vars params)))
(if (> (length vars) 0)
(concat "(let "
(mapconcat (lambda (var)
@ -63,14 +63,13 @@
"Execute a block of Shen code with org-babel.
This function is called by `org-babel-execute-src-block'"
(require 'inf-shen)
(let* ((result-type (cdr (assoc :result-type params)))
(result-params (cdr (assoc :result-params params)))
(let* ((result-params (cdr (assq :result-params params)))
(full-body (org-babel-expand-body:shen body params)))
(let ((results
(with-temp-buffer
(insert full-body)
(call-interactively #'shen-eval-defun))))
(org-babel-result-cond result-params
(org-babel-result-cond result-params
results
(condition-case nil (org-babel-script-escape results)
(error results))))))

205
lisp/org/ob-sql.el
View file

@ -1,4 +1,4 @@
;;; ob-sql.el --- org-babel functions for sql evaluation
;;; ob-sql.el --- Babel Functions for SQL -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -36,6 +36,7 @@
;; - engine
;; - cmdline
;; - dbhost
;; - dbport
;; - dbuser
;; - dbpassword
;; - database
@ -56,11 +57,11 @@
;;; Code:
(require 'ob)
(eval-when-compile (require 'cl))
(declare-function org-table-import "org-table" (file arg))
(declare-function orgtbl-to-csv "org-table" (table params))
(declare-function org-table-to-lisp "org-table" (&optional txt))
(declare-function cygwin-convert-file-name-to-windows "cygw32.c" (file &optional absolute-p))
(defvar org-babel-default-header-args:sql '())
@ -68,6 +69,7 @@
'((engine . :any)
(out-file . :any)
(dbhost . :any)
(dbport . :any)
(dbuser . :any)
(dbpassword . :any)
(database . :any))
@ -76,98 +78,167 @@
(defun org-babel-expand-body:sql (body params)
"Expand BODY according to the values of PARAMS."
(org-babel-sql-expand-vars
body (mapcar #'cdr (org-babel-get-header params :var))))
body (org-babel--get-vars params)))
(defun dbstring-mysql (host user password database)
(defun org-babel-sql-dbstring-mysql (host port user password database)
"Make MySQL cmd line args for database connection. Pass nil to omit that arg."
(combine-and-quote-strings
(remq nil
(delq nil
(list (when host (concat "-h" host))
(when port (format "-P%d" port))
(when user (concat "-u" user))
(when password (concat "-p" password))
(when database (concat "-D" database))))))
(defun org-babel-sql-dbstring-postgresql (host port user database)
"Make PostgreSQL command line args for database connection.
Pass nil to omit that arg."
(combine-and-quote-strings
(delq nil
(list (when host (concat "-h" host))
(when port (format "-p%d" port))
(when user (concat "-U" user))
(when database (concat "-d" database))))))
(defun org-babel-sql-dbstring-oracle (host port user password database)
"Make Oracle command line args for database connection."
(format "%s/%s@%s:%s/%s" user password host port database))
(defun org-babel-sql-dbstring-mssql (host user password database)
"Make sqlcmd commmand line args for database connection.
`sqlcmd' is the preferred command line tool to access Microsoft
SQL Server on Windows and Linux platform."
(mapconcat #'identity
(delq nil
(list (when host (format "-S \"%s\"" host))
(when user (format "-U \"%s\"" user))
(when password (format "-P \"%s\"" password))
(when database (format "-d \"%s\"" database))))
" "))
(defun org-babel-sql-convert-standard-filename (file)
"Convert FILE to OS standard file name.
If in Cygwin environment, uses Cygwin specific function to
convert the file name. In a Windows-NT environment, do nothing.
Otherwise, use Emacs' standard conversion function."
(cond ((fboundp 'cygwin-convert-file-name-to-windows)
(format "%S" (cygwin-convert-file-name-to-windows file)))
((string= "windows-nt" system-type) file)
(t (format "%S" (convert-standard-filename file)))))
(defun org-babel-execute:sql (body params)
"Execute a block of Sql code with Babel.
This function is called by `org-babel-execute-src-block'."
(let* ((result-params (cdr (assoc :result-params params)))
(cmdline (cdr (assoc :cmdline params)))
(dbhost (cdr (assoc :dbhost params)))
(dbuser (cdr (assoc :dbuser params)))
(dbpassword (cdr (assoc :dbpassword params)))
(database (cdr (assoc :database params)))
(engine (cdr (assoc :engine params)))
(colnames-p (not (equal "no" (cdr (assoc :colnames params)))))
(let* ((result-params (cdr (assq :result-params params)))
(cmdline (cdr (assq :cmdline params)))
(dbhost (cdr (assq :dbhost params)))
(dbport (cdr (assq :dbport params)))
(dbuser (cdr (assq :dbuser params)))
(dbpassword (cdr (assq :dbpassword params)))
(database (cdr (assq :database params)))
(engine (cdr (assq :engine params)))
(colnames-p (not (equal "no" (cdr (assq :colnames params)))))
(in-file (org-babel-temp-file "sql-in-"))
(out-file (or (cdr (assoc :out-file params))
(out-file (or (cdr (assq :out-file params))
(org-babel-temp-file "sql-out-")))
(header-delim "")
(command (case (intern engine)
('dbi (format "dbish --batch %s < %s | sed '%s' > %s"
(command (pcase (intern engine)
(`dbi (format "dbish --batch %s < %s | sed '%s' > %s"
(or cmdline "")
(org-babel-process-file-name in-file)
"/^+/d;s/^|//;s/(NULL)/ /g;$d"
(org-babel-process-file-name out-file)))
('monetdb (format "mclient -f tab %s < %s > %s"
(or cmdline "")
(org-babel-process-file-name in-file)
(org-babel-process-file-name out-file)))
('msosql (format "osql %s -s \"\t\" -i %s -o %s"
(or cmdline "")
(org-babel-process-file-name in-file)
(org-babel-process-file-name out-file)))
('mysql (format "mysql %s %s %s < %s > %s"
(dbstring-mysql dbhost dbuser dbpassword database)
(`monetdb (format "mclient -f tab %s < %s > %s"
(or cmdline "")
(org-babel-process-file-name in-file)
(org-babel-process-file-name out-file)))
(`mssql (format "sqlcmd %s -s \"\t\" %s -i %s -o %s"
(or cmdline "")
(org-babel-sql-dbstring-mssql
dbhost dbuser dbpassword database)
(org-babel-sql-convert-standard-filename
(org-babel-process-file-name in-file))
(org-babel-sql-convert-standard-filename
(org-babel-process-file-name out-file))))
(`mysql (format "mysql %s %s %s < %s > %s"
(org-babel-sql-dbstring-mysql
dbhost dbport dbuser dbpassword database)
(if colnames-p "" "-N")
(or cmdline "")
(or cmdline "")
(org-babel-process-file-name in-file)
(org-babel-process-file-name out-file)))
('postgresql (format
"psql -A -P footer=off -F \"\t\" -f %s -o %s %s"
(`postgresql (format
"%spsql --set=\"ON_ERROR_STOP=1\" %s -A -P \
footer=off -F \"\t\" %s -f %s -o %s %s"
(if dbpassword
(format "PGPASSWORD=%s " dbpassword)
"")
(if colnames-p "" "-t")
(org-babel-sql-dbstring-postgresql
dbhost dbport dbuser database)
(org-babel-process-file-name in-file)
(org-babel-process-file-name out-file)
(or cmdline "")))
(t (error "No support for the %s SQL engine" engine)))))
(`oracle (format
"sqlplus -s %s < %s > %s"
(org-babel-sql-dbstring-oracle
dbhost dbport dbuser dbpassword database)
(org-babel-process-file-name in-file)
(org-babel-process-file-name out-file)))
(_ (error "No support for the %s SQL engine" engine)))))
(with-temp-file in-file
(insert
(case (intern engine)
('dbi "/format partbox\n")
(t ""))
(pcase (intern engine)
(`dbi "/format partbox\n")
(`oracle "SET PAGESIZE 50000
SET NEWPAGE 0
SET TAB OFF
SET SPACE 0
SET LINESIZE 9999
SET ECHO OFF
SET FEEDBACK OFF
SET VERIFY OFF
SET HEADING ON
SET MARKUP HTML OFF SPOOL OFF
SET COLSEP '|'
")
(`mssql "SET NOCOUNT ON
")
(_ ""))
(org-babel-expand-body:sql body params)))
(message command)
(org-babel-eval command "")
(org-babel-result-cond result-params
(with-temp-buffer
(progn (insert-file-contents-literally out-file) (buffer-string)))
(progn (insert-file-contents-literally out-file) (buffer-string)))
(with-temp-buffer
(cond
((or (eq (intern engine) 'mysql)
(eq (intern engine) 'dbi)
(eq (intern engine) 'postgresql))
;; Add header row delimiter after column-names header in first line
(cond
(colnames-p
(with-temp-buffer
(insert-file-contents out-file)
(goto-char (point-min))
(forward-line 1)
(insert "-\n")
(setq header-delim "-")
(write-file out-file)))))
(t
;; Need to figure out the delimiter for the header row
(with-temp-buffer
(insert-file-contents out-file)
(goto-char (point-min))
(when (re-search-forward "^\\(-+\\)[^-]" nil t)
(setq header-delim (match-string-no-properties 1)))
(goto-char (point-max))
(forward-char -1)
(while (looking-at "\n")
(delete-char 1)
(goto-char (point-max))
(forward-char -1))
(write-file out-file))))
((memq (intern engine) '(dbi mysql postgresql))
;; Add header row delimiter after column-names header in first line
(cond
(colnames-p
(with-temp-buffer
(insert-file-contents out-file)
(goto-char (point-min))
(forward-line 1)
(insert "-\n")
(setq header-delim "-")
(write-file out-file)))))
(t
;; Need to figure out the delimiter for the header row
(with-temp-buffer
(insert-file-contents out-file)
(goto-char (point-min))
(when (re-search-forward "^\\(-+\\)[^-]" nil t)
(setq header-delim (match-string-no-properties 1)))
(goto-char (point-max))
(forward-char -1)
(while (looking-at "\n")
(delete-char 1)
(goto-char (point-max))
(forward-char -1))
(write-file out-file))))
(org-table-import out-file '(16))
(org-babel-reassemble-table
(mapcar (lambda (x)
@ -175,10 +246,10 @@ This function is called by `org-babel-execute-src-block'."
'hline
x))
(org-table-to-lisp))
(org-babel-pick-name (cdr (assoc :colname-names params))
(cdr (assoc :colnames params)))
(org-babel-pick-name (cdr (assoc :rowname-names params))
(cdr (assoc :rownames params))))))))
(org-babel-pick-name (cdr (assq :colname-names params))
(cdr (assq :colnames params)))
(org-babel-pick-name (cdr (assq :rowname-names params))
(cdr (assq :rownames params))))))))
(defun org-babel-sql-expand-vars (body vars)
"Expand the variables held in VARS in BODY."
@ -201,7 +272,7 @@ This function is called by `org-babel-execute-src-block'."
vars)
body)
(defun org-babel-prep-session:sql (session params)
(defun org-babel-prep-session:sql (_session _params)
"Raise an error because Sql sessions aren't implemented."
(error "SQL sessions not yet implemented"))

23
lisp/org/ob-sqlite.el
View file

@ -1,4 +1,4 @@
;;; ob-sqlite.el --- org-babel functions for sqlite database interaction
;;; ob-sqlite.el --- Babel Functions for SQLite Databases -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
@ -53,23 +53,22 @@
(defun org-babel-expand-body:sqlite (body params)
"Expand BODY according to the values of PARAMS."
(org-babel-sqlite-expand-vars
body (mapcar #'cdr (org-babel-get-header params :var))))
body (org-babel--get-vars params)))
(defvar org-babel-sqlite3-command "sqlite3")
(defun org-babel-execute:sqlite (body params)
"Execute a block of Sqlite code with Babel.
This function is called by `org-babel-execute-src-block'."
(let ((result-params (split-string (or (cdr (assoc :results params)) "")))
(db (cdr (assoc :db params)))
(separator (cdr (assoc :separator params)))
(nullvalue (cdr (assoc :nullvalue params)))
(headers-p (equal "yes" (cdr (assoc :colnames params))))
(let ((result-params (split-string (or (cdr (assq :results params)) "")))
(db (cdr (assq :db params)))
(separator (cdr (assq :separator params)))
(nullvalue (cdr (assq :nullvalue params)))
(headers-p (equal "yes" (cdr (assq :colnames params))))
(others (delq nil (mapcar
(lambda (arg) (car (assoc arg params)))
(lambda (arg) (car (assq arg params)))
(list :header :echo :bail :column
:csv :html :line :list))))
exit-code)
:csv :html :line :list)))))
(unless db (error "ob-sqlite: can't evaluate without a database"))
(with-temp-buffer
(insert
@ -140,7 +139,7 @@ This function is called by `org-babel-execute-src-block'."
(equal 1 (length (car result))))
(org-babel-read (caar result))
(mapcar (lambda (row)
(if (equal 'hline row)
(if (eq 'hline row)
'hline
(mapcar #'org-babel-string-read row))) result)))
@ -150,7 +149,7 @@ This function is called by `org-babel-execute-src-block'."
(cons (car table) (cons 'hline (cdr table)))
table))
(defun org-babel-prep-session:sqlite (session params)
(defun org-babel-prep-session:sqlite (_session _params)
"Raise an error because support for SQLite sessions isn't implemented.
Prepare SESSION according to the header arguments specified in PARAMS."
(error "SQLite sessions not yet implemented"))

84
lisp/org/ob-stan.el Normal file
View file

@ -0,0 +1,84 @@
;;; ob-stan.el --- Babel Functions for Stan -*- lexical-binding: t; -*-
;; Copyright (C) 2015-2017 Free Software Foundation, Inc.
;; Author: Kyle Meyer
;; Keywords: literate programming, reproducible research
;; Homepage: http://orgmode.org
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Org-Babel support for evaluating Stan [1] source code.
;;
;; Evaluating a Stan block can produce two different results.
;;
;; 1) Dump the source code contents to a file.
;;
;; This file can then be used as a variable in other blocks, which
;; allows interfaces like RStan to use the model.
;;
;; 2) Compile the contents to a model file.
;;
;; This provides access to the CmdStan interface. To use this, set
;; `org-babel-stan-cmdstan-directory' and provide a :file argument
;; that does not end in ".stan".
;;
;; For more information and usage examples, visit
;; http://orgmode.org/worg/org-contrib/babel/languages/ob-doc-stan.html
;;
;; [1] http://mc-stan.org/
;;; Code:
(require 'ob)
(require 'org-compat)
(defcustom org-babel-stan-cmdstan-directory nil
"CmdStan source directory.
'make' will be called from this directory to compile the Stan
block. When nil, executing Stan blocks dumps the content to a
plain text file."
:group 'org-babel
:type 'string)
(defvar org-babel-default-header-args:stan
'((:results . "file")))
(defun org-babel-execute:stan (body params)
"Generate Stan file from BODY according to PARAMS.
A :file header argument must be given. If
`org-babel-stan-cmdstan-directory' is non-nil and the file name
does not have a \".stan\" extension, save an intermediate
\".stan\" file and compile the block to the named file.
Otherwise, write the Stan code directly to the named file."
(let ((file (expand-file-name
(or (cdr (assq :file params))
(user-error "Set :file argument to execute Stan blocks")))))
(if (or (not org-babel-stan-cmdstan-directory)
(string-match-p "\\.stan\\'" file))
(with-temp-file file (insert body))
(with-temp-file (concat file ".stan") (insert body))
(let ((default-directory org-babel-stan-cmdstan-directory))
(call-process-shell-command (concat "make " file))))
nil)) ; Signal that output has been written to file.
(defun org-babel-prep-session:stan (_session _params)
"Return an error because Stan does not support sessions."
(user-error "Stan does not support sessions"))
(provide 'ob-stan)
;;; ob-stan.el ends here

44
lisp/org/ob-table.el
View file

@ -1,4 +1,4 @@
;;; ob-table.el --- support for calling org-babel functions from tables
;;; ob-table.el --- Support for Calling Babel Functions from Tables -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -23,8 +23,8 @@
;;; Commentary:
;; Should allow calling functions from org-mode tables using the
;; function `org-sbe' as so...
;; Should allow calling functions from Org tables using the function
;; `org-sbe' as so...
;; #+begin_src emacs-lisp :results silent
;; (defun fibbd (n) (if (< n 2) 1 (+ (fibbd (- n 1)) (fibbd (- n 2)))))
@ -47,38 +47,50 @@
;; | 7 | |
;; | 8 | |
;; | 9 | |
;; #+TBLFM: $2='(org-sbe 'fibbd (n $1))
;; #+TBLFM: $2='(org-sbe "fibbd" (n $1))
;; NOTE: The quotation marks around the function name, 'fibbd' here,
;; are optional.
;;; Code:
(require 'ob-core)
(declare-function org-trim "org" (s &optional keep-lead))
(defun org-babel-table-truncate-at-newline (string)
"Replace newline character with ellipses.
If STRING ends in a newline character, then remove the newline
character and replace it with ellipses."
(if (and (stringp string) (string-match "[\n\r]\\(.\\)?" string))
(concat (substring string 0 (match-beginning 0))
(if (match-string 1 string) "...")) string))
(when (match-string 1 string) "...")) string))
(defmacro org-sbe (source-block &rest variables)
"Return the results of calling SOURCE-BLOCK with VARIABLES.
Each element of VARIABLES should be a two
element list, whose first element is the name of the variable and
second element is a string of its value. The following call to
`org-sbe' would be equivalent to the following source code block.
(org-sbe \\='source-block (n $2) (m 3))
Each element of VARIABLES should be a list of two elements: the
first element is the name of the variable and second element is a
string of its value.
#+begin_src emacs-lisp :var results=source-block(n=val_at_col_2, m=3) :results silent
results
#+end_src
So this `org-sbe' construct
NOTE: by default string variable names are interpreted as
(org-sbe \"source-block\" (n $2) (m 3))
is the equivalent of the following source code block:
#+begin_src emacs-lisp :var results=source-block(n=val_at_col_2, m=3) :results silent
results
#+end_src
NOTE: The quotation marks around the function name,
'source-block', are optional.
NOTE: By default, string variable names are interpreted as
references to source-code blocks, to force interpretation of a
cell's value as a string, prefix the identifier a \"$\" (e.g.,
\"$$2\" instead of \"$2\" or \"$@2$2\" instead of \"@2$2\").
NOTE: it is also possible to pass header arguments to the code
NOTE: It is also possible to pass header arguments to the code
block. In this case a table cell should hold the string value of
the header argument which can then be passed before all variables
as shown in the example below.
@ -132,7 +144,7 @@ as shown in the example below.
nil (list "emacs-lisp" "results" params)
'((:results . "silent"))))
"")))
(org-babel-trim (if (stringp result) result (format "%S" result)))))))
(org-trim (if (stringp result) result (format "%S" result)))))))
(provide 'ob-table)

398
lisp/org/ob-tangle.el
View file

@ -1,4 +1,4 @@
;;; ob-tangle.el --- extract source code from org-mode files
;;; ob-tangle.el --- Extract Source Code From Org Files -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -26,22 +26,35 @@
;; Extract the code from source blocks out into raw source-code files.
;;; Code:
(require 'org-src)
(eval-when-compile
(require 'cl))
(declare-function org-edit-special "org" (&optional arg))
(declare-function org-link-escape "org" (text &optional table merge))
(declare-function org-store-link "org" (arg))
(declare-function org-open-link-from-string "org" (s &optional arg reference-buffer))
(declare-function org-heading-components "org" ())
(declare-function org-back-to-heading "org" (&optional invisible-ok))
(declare-function org-fill-template "org" (template alist))
(declare-function org-babel-update-block-body "ob-core" (new-body))
(require 'cl-lib)
(require 'org-src)
(declare-function make-directory "files" (dir &optional parents))
(declare-function org-at-heading-p "org" (&optional ignored))
(declare-function org-babel-update-block-body "ob-core" (new-body))
(declare-function org-back-to-heading "org" (&optional invisible-ok))
(declare-function org-before-first-heading-p "org" ())
(declare-function org-edit-special "org" (&optional arg))
(declare-function org-element-at-point "org-element" ())
(declare-function org-element-type "org-element" (element))
(declare-function org-fill-template "org" (template alist))
(declare-function org-heading-components "org" ())
(declare-function org-in-commented-heading-p "org" (&optional no-inheritance))
(declare-function org-link-escape "org" (text &optional table merge))
(declare-function org-open-link-from-string "org" (s &optional arg reference-buffer))
(declare-function org-remove-indentation "org" (code &optional n))
(declare-function org-store-link "org" (arg))
(declare-function org-string-nw-p "org-macs" (s))
(declare-function org-trim "org" (s &optional keep-lead))
(declare-function outline-previous-heading "outline" ())
(declare-function org-id-find "org-id" (id &optional markerp))
(defvar org-link-types-re)
(defcustom org-babel-tangle-lang-exts
'(("emacs-lisp" . "el"))
'(("emacs-lisp" . "el")
("elisp" . "el"))
"Alist mapping languages to their file extensions.
The key is the language name, the value is the string that should
be inserted as the extension commonly used to identify files
@ -54,6 +67,11 @@ then the name of the language is used."
(string "Language name")
(string "File Extension"))))
(defcustom org-babel-tangle-use-relative-file-links t
"Use relative path names in links from tangled source back the Org file."
:group 'org-babel-tangle
:type 'boolean)
(defcustom org-babel-post-tangle-hook nil
"Hook run in code files tangled by `org-babel-tangle'."
:group 'org-babel
@ -78,9 +96,14 @@ The following format strings can be used to insert special
information into the output using `org-fill-template'.
%start-line --- the line number at the start of the code block
%file --------- the file from which the code block was tangled
%link --------- Org-mode style link to the code block
%link --------- Org style link to the code block
%source-name -- name of the code block
Upon insertion the formatted comment will be commented out, and
followed by a newline. To inhibit this post-insertion processing
set the `org-babel-tangle-uncomment-comments' variable to a
non-nil value.
Whether or not comments are inserted during tangling is
controlled by the :comments header argument."
:group 'org-babel
@ -93,20 +116,33 @@ The following format strings can be used to insert special
information into the output using `org-fill-template'.
%start-line --- the line number at the start of the code block
%file --------- the file from which the code block was tangled
%link --------- Org-mode style link to the code block
%link --------- Org style link to the code block
%source-name -- name of the code block
Upon insertion the formatted comment will be commented out, and
followed by a newline. To inhibit this post-insertion processing
set the `org-babel-tangle-uncomment-comments' variable to a
non-nil value.
Whether or not comments are inserted during tangling is
controlled by the :comments header argument."
:group 'org-babel
:version "24.1"
:type 'string)
(defcustom org-babel-process-comment-text #'org-babel-trim
"Function called to process raw Org-mode text collected to be
(defcustom org-babel-tangle-uncomment-comments nil
"Inhibits automatic commenting and addition of trailing newline
of tangle comments. Use `org-babel-tangle-comment-format-beg'
and `org-babel-tangle-comment-format-end' to customize the format
of tangled comments."
:group 'org-babel
:type 'boolean)
(defcustom org-babel-process-comment-text 'org-remove-indentation
"Function called to process raw Org text collected to be
inserted as comments in tangled source-code files. The function
should take a single string argument and return a string
result. The default value is `org-babel-trim'."
result. The default value is `org-remove-indentation'."
:group 'org-babel
:version "24.1"
:type 'function)
@ -153,12 +189,14 @@ Return a list whose CAR is the tangled file name."
(save-window-excursion
(find-file file)
(setq to-be-removed (current-buffer))
(org-babel-tangle nil target-file lang))
(mapcar #'expand-file-name (org-babel-tangle nil target-file lang)))
(unless visited-p
(kill-buffer to-be-removed)))))
(defun org-babel-tangle-publish (_ filename pub-dir)
"Tangle FILENAME and place the results in PUB-DIR."
(unless (file-exists-p pub-dir)
(make-directory pub-dir t))
(mapc (lambda (el) (copy-file el pub-dir t)) (org-babel-tangle-file filename)))
;;;###autoload
@ -176,12 +214,12 @@ used to limit the exported source code blocks by language."
(run-hooks 'org-babel-pre-tangle-hook)
;; Possibly Restrict the buffer to the current code block
(save-restriction
(when (equal arg '(4))
(let ((head (org-babel-where-is-src-block-head)))
(save-excursion
(when (equal arg '(4))
(let ((head (org-babel-where-is-src-block-head)))
(if head
(goto-char head)
(user-error "Point is not in a source code block"))))
(save-excursion
(let ((block-counter 0)
(org-babel-default-header-args
(if target-file
@ -190,7 +228,7 @@ used to limit the exported source code blocks by language."
org-babel-default-header-args))
(tangle-file
(when (equal arg '(16))
(or (cdr (assoc :tangle (nth 2 (org-babel-get-src-block-info 'light))))
(or (cdr (assq :tangle (nth 2 (org-babel-get-src-block-info 'light))))
(user-error "Point is not in a source code block"))))
path-collector)
(mapc ;; map over all languages
@ -216,7 +254,7 @@ used to limit the exported source code blocks by language."
(base-name (cond
((string= "yes" tangle)
(file-name-sans-extension
(buffer-file-name)))
(nth 1 spec)))
((string= "no" tangle) nil)
((> (length tangle) 0) tangle)))
(file-name (when base-name
@ -243,9 +281,13 @@ used to limit the exported source code blocks by language."
;; We avoid append-to-file as it does not work with tramp.
(let ((content (buffer-string)))
(with-temp-buffer
(if (file-exists-p file-name)
(insert-file-contents file-name))
(when (file-exists-p file-name)
(insert-file-contents file-name))
(goto-char (point-max))
;; Handle :padlines unless first line in file
(unless (or (string= "no" (cdr (assq :padline (nth 4 spec))))
(= (point) (point-min)))
(insert "\n"))
(insert content)
(write-region nil nil file-name))))
;; if files contain she-bangs, then make the executable
@ -253,10 +295,8 @@ used to limit the exported source code blocks by language."
(unless tangle-mode (setq tangle-mode #o755)))
;; update counter
(setq block-counter (+ 1 block-counter))
(add-to-list 'path-collector
(cons file-name tangle-mode)
nil
(lambda (a b) (equal (car a) (car b))))))))
(unless (assoc file-name path-collector)
(push (cons file-name tangle-mode) path-collector))))))
specs)))
(if (equal arg '(4))
(org-babel-tangle-single-block 1 t)
@ -284,7 +324,7 @@ used to limit the exported source code blocks by language."
Call this function inside of a source-code file generated by
`org-babel-tangle' to remove all comments inserted automatically
by `org-babel-tangle'. Warning, this comment removes any lines
containing constructs which resemble org-mode file links or noweb
containing constructs which resemble Org file links or noweb
references."
(interactive)
(goto-char (point-min))
@ -303,153 +343,134 @@ code file. This function uses `comment-region' which assumes
that the appropriate major-mode is set. SPEC has the form:
(start-line file link source-name params body comment)"
(let* ((start-line (nth 0 spec))
(file (nth 1 spec))
(link (nth 2 spec))
(source-name (nth 3 spec))
(body (nth 5 spec))
(comment (nth 6 spec))
(comments (cdr (assoc :comments (nth 4 spec))))
(padline (not (string= "no" (cdr (assoc :padline (nth 4 spec))))))
(link-p (or (string= comments "both") (string= comments "link")
(string= comments "yes") (string= comments "noweb")))
(link-data (mapcar (lambda (el)
(cons (symbol-name el)
(let ((le (eval el)))
(if (stringp le) le (format "%S" le)))))
'(start-line file link source-name)))
(insert-comment (lambda (text)
(when (and comments (not (string= comments "no"))
(> (length text) 0))
(when padline (insert "\n"))
(comment-region (point) (progn (insert text) (point)))
(end-of-line nil) (insert "\n")))))
(pcase-let*
((`(,start ,file ,link ,source ,info ,body ,comment) spec)
(comments (cdr (assq :comments info)))
(link? (or (string= comments "both") (string= comments "link")
(string= comments "yes") (string= comments "noweb")))
(link-data `(("start-line" . ,(number-to-string start))
("file" . ,file)
("link" . ,link)
("source-name" . ,source)))
(insert-comment (lambda (text)
(when (and comments
(not (string= comments "no"))
(org-string-nw-p text))
(if org-babel-tangle-uncomment-comments
;; Plain comments: no processing.
(insert text)
;; Ensure comments are made to be
;; comments, and add a trailing newline.
;; Also ignore invisible characters when
;; commenting.
(comment-region
(point)
(progn (insert (org-no-properties text))
(point)))
(end-of-line)
(insert "\n"))))))
(when comment (funcall insert-comment comment))
(when link-p
(funcall
insert-comment
(org-fill-template org-babel-tangle-comment-format-beg link-data)))
(when padline (insert "\n"))
(insert
(format
"%s\n"
(org-unescape-code-in-string
(org-babel-trim body (if org-src-preserve-indentation "[\f\n\r\v]")))))
(when link-p
(funcall
insert-comment
(org-fill-template org-babel-tangle-comment-format-end link-data)))))
(when link?
(funcall insert-comment
(org-fill-template
org-babel-tangle-comment-format-beg link-data)))
(insert body "\n")
(when link?
(funcall insert-comment
(org-fill-template
org-babel-tangle-comment-format-end link-data)))))
(defvar org-comment-string) ;; Defined in org.el
(defun org-babel-tangle-collect-blocks (&optional language tangle-file)
"Collect source blocks in the current Org-mode file.
"Collect source blocks in the current Org file.
Return an association list of source-code block specifications of
the form used by `org-babel-spec-to-string' grouped by language.
Optional argument LANGUAGE can be used to limit the collected
source code blocks by language. Optional argument TANGLE-FILE
can be used to limit the collected code blocks by target file."
(let ((block-counter 1) (current-heading "") blocks by-lang)
(let ((counter 0) last-heading-pos blocks)
(org-babel-map-src-blocks (buffer-file-name)
(lambda (new-heading)
(if (not (string= new-heading current-heading))
(progn
(setq block-counter 1)
(setq current-heading new-heading))
(setq block-counter (+ 1 block-counter))))
(replace-regexp-in-string "[ \t]" "-"
(condition-case nil
(or (nth 4 (org-heading-components))
"(dummy for heading without text)")
(error (buffer-file-name))))
(let* ((info (org-babel-get-src-block-info 'light))
(src-lang (nth 0 info))
(src-tfile (cdr (assoc :tangle (nth 2 info)))))
(unless (or (string-match (concat "^" org-comment-string) current-heading)
(string= (cdr (assoc :tangle (nth 2 info))) "no")
(and tangle-file (not (equal tangle-file src-tfile))))
(unless (and language (not (string= language src-lang)))
;; Add the spec for this block to blocks under it's language
(setq by-lang (cdr (assoc src-lang blocks)))
(setq blocks (delq (assoc src-lang blocks) blocks))
(setq blocks (cons
(cons src-lang
(cons
(org-babel-tangle-single-block
block-counter)
by-lang)) blocks))))))
;; Ensure blocks are in the correct order
(setq blocks
(mapcar
(lambda (by-lang) (cons (car by-lang) (reverse (cdr by-lang))))
blocks))
blocks))
(let ((current-heading-pos
(org-with-wide-buffer
(org-with-limited-levels (outline-previous-heading)))))
(if (eq last-heading-pos current-heading-pos) (cl-incf counter)
(setq counter 1)
(setq last-heading-pos current-heading-pos)))
(unless (org-in-commented-heading-p)
(let* ((info (org-babel-get-src-block-info 'light))
(src-lang (nth 0 info))
(src-tfile (cdr (assq :tangle (nth 2 info)))))
(unless (or (string= src-tfile "no")
(and tangle-file (not (equal tangle-file src-tfile)))
(and language (not (string= language src-lang))))
;; Add the spec for this block to blocks under its
;; language.
(let ((by-lang (assoc src-lang blocks))
(block (org-babel-tangle-single-block counter)))
(if by-lang (setcdr by-lang (cons block (cdr by-lang)))
(push (cons src-lang (list block)) blocks)))))))
;; Ensure blocks are in the correct order.
(mapcar (lambda (b) (cons (car b) (nreverse (cdr b)))) blocks)))
(defun org-babel-tangle-single-block
(block-counter &optional only-this-block)
(defun org-babel-tangle-single-block (block-counter &optional only-this-block)
"Collect the tangled source for current block.
Return the list of block attributes needed by
`org-babel-tangle-collect-blocks'.
When ONLY-THIS-BLOCK is non-nil, return the full association
list to be used by `org-babel-tangle' directly."
`org-babel-tangle-collect-blocks'. When ONLY-THIS-BLOCK is
non-nil, return the full association list to be used by
`org-babel-tangle' directly."
(let* ((info (org-babel-get-src-block-info))
(start-line
(save-restriction (widen)
(+ 1 (line-number-at-pos (point)))))
(file (buffer-file-name))
(file (buffer-file-name (buffer-base-buffer)))
(src-lang (nth 0 info))
(params (nth 2 info))
(extra (nth 3 info))
(cref-fmt (or (and (string-match "-l \"\\(.+\\)\"" extra)
(match-string 1 extra))
org-coderef-label-format))
(link (let ((link (org-no-properties
(org-store-link nil))))
(and (string-match org-bracket-link-regexp link)
(match-string 1 link))))
(link (let ((l (org-no-properties (org-store-link nil))))
(and (string-match org-bracket-link-regexp l)
(match-string 1 l))))
(source-name
(intern (or (nth 4 info)
(format "%s:%d"
(or (ignore-errors (nth 4 (org-heading-components)))
"No heading")
block-counter))))
(expand-cmd
(intern (concat "org-babel-expand-body:" src-lang)))
(or (nth 4 info)
(format "%s:%d"
(or (ignore-errors (nth 4 (org-heading-components)))
"No heading")
block-counter)))
(expand-cmd (intern (concat "org-babel-expand-body:" src-lang)))
(assignments-cmd
(intern (concat "org-babel-variable-assignments:" src-lang)))
(body
;; Run the tangle-body-hook.
(let* ((body ;; Expand the body in language specific manner.
(if (org-babel-noweb-p params :tangle)
(org-babel-expand-noweb-references info)
(nth 1 info)))
(body
(if (assoc :no-expand params)
body
(if (fboundp expand-cmd)
(funcall expand-cmd body params)
(org-babel-expand-body:generic
body params
(and (fboundp assignments-cmd)
(funcall assignments-cmd params)))))))
(with-temp-buffer
(insert body)
(when (string-match "-r" extra)
(goto-char (point-min))
(while (re-search-forward
(replace-regexp-in-string "%s" ".+" cref-fmt) nil t)
(replace-match "")))
(run-hooks 'org-babel-tangle-body-hook)
(buffer-string))))
(let ((body (if (org-babel-noweb-p params :tangle)
(org-babel-expand-noweb-references info)
(nth 1 info))))
(with-temp-buffer
(insert
;; Expand body in language specific manner.
(cond ((assq :no-expand params) body)
((fboundp expand-cmd) (funcall expand-cmd body params))
(t
(org-babel-expand-body:generic
body params (and (fboundp assignments-cmd)
(funcall assignments-cmd params))))))
(when (string-match "-r" extra)
(goto-char (point-min))
(while (re-search-forward
(replace-regexp-in-string "%s" ".+" cref-fmt) nil t)
(replace-match "")))
(run-hooks 'org-babel-tangle-body-hook)
(buffer-string))))
(comment
(when (or (string= "both" (cdr (assoc :comments params)))
(string= "org" (cdr (assoc :comments params))))
(when (or (string= "both" (cdr (assq :comments params)))
(string= "org" (cdr (assq :comments params))))
;; From the previous heading or code-block end
(funcall
org-babel-process-comment-text
(buffer-substring
(max (condition-case nil
(save-excursion
(org-back-to-heading t) ; Sets match data
(org-back-to-heading t) ; Sets match data
(match-end 0))
(error (point-min)))
(save-excursion
@ -459,31 +480,48 @@ list to be used by `org-babel-tangle' directly."
(point-min))))
(point)))))
(result
(list start-line file link source-name params body comment)))
(list start-line
(if org-babel-tangle-use-relative-file-links
(file-relative-name file)
file)
(if (and org-babel-tangle-use-relative-file-links
(string-match org-link-types-re link)
(string= (match-string 0 link) "file"))
(concat "file:"
(file-relative-name (match-string 1 link)
(file-name-directory
(cdr (assq :tangle params)))))
link)
source-name
params
(org-unescape-code-in-string
(if org-src-preserve-indentation
(org-trim body t)
(org-trim (org-remove-indentation body))))
comment)))
(if only-this-block
(list (cons src-lang (list result)))
result)))
(defun org-babel-tangle-comment-links ( &optional info)
(defun org-babel-tangle-comment-links (&optional info)
"Return a list of begin and end link comments for the code block at point."
(let* ((start-line (org-babel-where-is-src-block-head))
(file (buffer-file-name))
(link (org-link-escape (progn (call-interactively 'org-store-link)
(org-no-properties
(car (pop org-stored-links))))))
(source-name (nth 4 (or info (org-babel-get-src-block-info 'light))))
(link-data (mapcar (lambda (el)
(cons (symbol-name el)
(let ((le (eval el)))
(if (stringp le) le (format "%S" le)))))
'(start-line file link source-name))))
(let ((link-data
`(("start-line" . ,(number-to-string
(org-babel-where-is-src-block-head)))
("file" . ,(buffer-file-name))
("link" . ,(org-link-escape
(progn
(call-interactively #'org-store-link)
(org-no-properties (car (pop org-stored-links))))))
("source-name" .
,(nth 4 (or info (org-babel-get-src-block-info 'light)))))))
(list (org-fill-template org-babel-tangle-comment-format-beg link-data)
(org-fill-template org-babel-tangle-comment-format-end link-data))))
;; de-tangling functions
(defvar org-bracket-link-analytic-regexp)
(defun org-babel-detangle (&optional source-code-file)
"Propagate changes in source file back original to Org-mode file.
"Propagate changes in source file back original to Org file.
This requires that code blocks were tangled with link comments
which enable the original code blocks to be found."
(interactive)
@ -504,18 +542,17 @@ which enable the original code blocks to be found."
(prog1 counter (message "Detangled %d code blocks" counter)))))
(defun org-babel-tangle-jump-to-org ()
"Jump from a tangled code file to the related Org-mode file."
"Jump from a tangled code file to the related Org mode file."
(interactive)
(let ((mid (point))
start body-start end done
start body-start end
target-buffer target-char link path block-name body)
(save-window-excursion
(save-excursion
(while (and (re-search-backward org-bracket-link-analytic-regexp nil t)
(not ; ever wider searches until matching block comments
(and (setq start (point-at-eol))
(setq body-start (save-excursion
(forward-line 2) (point-at-bol)))
(and (setq start (line-beginning-position))
(setq body-start (line-beginning-position 2))
(setq link (match-string 0))
(setq path (match-string 3))
(setq block-name (match-string 5))
@ -524,32 +561,37 @@ which enable the original code blocks to be found."
(re-search-forward
(concat " " (regexp-quote block-name)
" ends here") nil t)
(setq end (point-at-bol))))))))
(setq end (line-beginning-position))))))))
(unless (and start (< start mid) (< mid end))
(error "Not in tangled code"))
(setq body (org-babel-trim (buffer-substring start end))))
(setq body (buffer-substring body-start end)))
(when (string-match "::" path)
(setq path (substring path 0 (match-beginning 0))))
(find-file path) (setq target-buffer (current-buffer))
(goto-char start) (org-open-link-from-string link)
(find-file (or (car (org-id-find path)) path))
(setq target-buffer (current-buffer))
;; Go to the beginning of the relative block in Org file.
(org-open-link-from-string link)
(if (string-match "[^ \t\n\r]:\\([[:digit:]]+\\)" block-name)
(org-babel-next-src-block
(string-to-number (match-string 1 block-name)))
(let ((n (string-to-number (match-string 1 block-name))))
(if (org-before-first-heading-p) (goto-char (point-min))
(org-back-to-heading t))
;; Do not skip the first block if it begins at point min.
(cond ((or (org-at-heading-p)
(not (eq (org-element-type (org-element-at-point))
'src-block)))
(org-babel-next-src-block n))
((= n 1))
(t (org-babel-next-src-block (1- n)))))
(org-babel-goto-named-src-block block-name))
;; position at the beginning of the code block body
(goto-char (org-babel-where-is-src-block-head))
;; Preserve location of point within the source code in tangled
;; code file.
(forward-line 1)
;; Use org-edit-special to isolate the code.
(org-edit-special)
;; Then move forward the correct number of characters in the
;; code buffer.
(forward-char (- mid body-start))
;; And return to the Org-mode buffer with the point in the right
;; place.
(org-edit-src-exit)
(setq target-char (point)))
(org-src-switch-to-buffer target-buffer t)
(prog1 body (goto-char target-char))))
(goto-char target-char)
body))
(provide 'ob-tangle)

2
lisp/org/ob.el
View file

@ -1,4 +1,4 @@
;;; ob.el --- working with code blocks in org-mode
;;; ob.el --- Working with Code Blocks in Org -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.

3091
lisp/org/org-agenda.el
View file

File diff suppressed because it is too large Load diff

421
lisp/org/org-archive.el
View file

@ -1,4 +1,4 @@
;;; org-archive.el --- Archiving for Org-mode
;;; org-archive.el --- Archiving for Org -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2017 Free Software Foundation, Inc.
@ -29,10 +29,10 @@
;;; Code:
(require 'org)
(eval-when-compile (require 'cl))
(declare-function org-inlinetask-remove-END-maybe "org-inlinetask" ())
(declare-function org-element-type "org-element" (element))
(declare-function org-datetree-find-date-create "org-datetree" (date &optional keep-restriction))
(declare-function org-inlinetask-remove-END-maybe "org-inlinetask" ())
(defcustom org-archive-default-command 'org-archive-subtree
"The default archiving command."
@ -57,7 +57,7 @@ See `org-archive-to-archive-sibling' for more information."
(defcustom org-archive-mark-done nil
"Non-nil means mark entries as DONE when they are moved to the archive file.
This can be a string to set the keyword to use. When t, Org-mode will
This can be a string to set the keyword to use. When non-nil, Org will
use the first keyword in its list that means done."
:group 'org-archive
:type '(choice
@ -120,9 +120,15 @@ information."
(const :tag "Outline path" olpath)
(const :tag "Local tags" ltags)))
(defvar org-archive-hook nil
"Hook run after successfully archiving a subtree.
Hook functions are called with point on the subtree in the
original file. At this stage, the subtree has been added to the
archive location, but not yet deleted from the original file.")
(defun org-get-local-archive-location ()
"Get the archive location applicable at point."
(let ((re "^#\\+ARCHIVE:[ \t]+\\(\\S-.*\\S-\\)[ \t]*$")
(let ((re "^[ \t]*#\\+ARCHIVE:[ \t]+\\(\\S-.*\\S-\\)[ \t]*$")
prop)
(save-excursion
(save-restriction
@ -154,21 +160,24 @@ archive file is."
(defun org-all-archive-files ()
"Get a list of all archive files used in the current buffer."
(let (file files)
(save-excursion
(save-restriction
(goto-char (point-min))
(while (re-search-forward
"^\\(#\\+\\|[ \t]*:\\)ARCHIVE:[ \t]+\\(.*\\)"
nil t)
(setq file (org-extract-archive-file
(org-match-string-no-properties 2)))
(and file (> (length file) 0) (file-exists-p file)
(pushnew file files :test #'equal)))))
(let ((case-fold-search t)
files)
(org-with-wide-buffer
(goto-char (point-min))
(while (re-search-forward
"^[ \t]*\\(#\\+\\|:\\)ARCHIVE:[ \t]+\\(.*\\)"
nil t)
(when (save-match-data
(if (eq (match-string 1) ":") (org-at-property-p)
(eq (org-element-type (org-element-at-point)) 'keyword)))
(let ((file (org-extract-archive-file
(match-string-no-properties 2))))
(when (and (org-string-nw-p file) (file-exists-p file))
(push file files))))))
(setq files (nreverse files))
(setq file (org-extract-archive-file))
(and file (> (length file) 0) (file-exists-p file)
(pushnew file files :test #'equal))
(let ((file (org-extract-archive-file)))
(when (and (org-string-nw-p file) (file-exists-p file))
(push file files)))
files))
(defun org-extract-archive-file (&optional location)
@ -195,15 +204,19 @@ if LOCATION is not given, the value of `org-archive-location' is used."
;;;###autoload
(defun org-archive-subtree (&optional find-done)
"Move the current subtree to the archive.
The archive can be a certain top-level heading in the current file, or in
a different file. The tree will be moved to that location, the subtree
heading be marked DONE, and the current time will be added.
The archive can be a certain top-level heading in the current
file, or in a different file. The tree will be moved to that
location, the subtree heading be marked DONE, and the current
time will be added.
When called with prefix argument FIND-DONE, find whole trees without any
open TODO items and archive them (after getting confirmation from the user).
If the cursor is not at a headline when this command is called, try all level
1 trees. If the cursor is on a headline, only try the direct children of
this heading."
When called with a single prefix argument FIND-DONE, find whole
trees without any open TODO items and archive them (after getting
confirmation from the user). When called with a double prefix
argument, find whole trees with timestamps before today and
archive them (after getting confirmation from the user). If the
cursor is not at a headline when these commands are called, try
all level 1 trees. If the cursor is on a headline, only try the
direct children of this heading."
(interactive "P")
(if (and (org-region-active-p) org-loop-over-headlines-in-active-region)
(let ((cl (if (eq org-loop-over-headlines-in-active-region 'start-level)
@ -213,46 +226,36 @@ this heading."
`(progn (setq org-map-continue-from (progn (org-back-to-heading) (point)))
(org-archive-subtree ,find-done))
org-loop-over-headlines-in-active-region
cl (if (outline-invisible-p) (org-end-of-subtree nil t))))
(if find-done
(org-archive-all-done)
cl (if (org-invisible-p) (org-end-of-subtree nil t))))
(cond
((equal find-done '(4)) (org-archive-all-done))
((equal find-done '(16)) (org-archive-all-old))
(t
;; Save all relevant TODO keyword-relatex variables
(let ((tr-org-todo-line-regexp org-todo-line-regexp) ; keep despite compiler
(tr-org-todo-keywords-1 org-todo-keywords-1)
(tr-org-todo-kwd-alist org-todo-kwd-alist)
(tr-org-done-keywords org-done-keywords)
(tr-org-todo-regexp org-todo-regexp)
(tr-org-todo-line-regexp org-todo-line-regexp)
(tr-org-odd-levels-only org-odd-levels-only)
(this-buffer (current-buffer))
;; start of variables that will be used for saving context
;; The compiler complains about them - keep them anyway!
(file (abbreviate-file-name
(or (buffer-file-name (buffer-base-buffer))
(error "No file associated to buffer"))))
(olpath (mapconcat 'identity (org-get-outline-path) "/"))
(time (format-time-string
(substring (cdr org-time-stamp-formats) 1 -1)))
category todo priority ltags itags atags
;; end of variables that will be used for saving context
location afile heading buffer level newfile-p infile-p visiting
datetree-date datetree-subheading-p)
;; Find the local archive location
(setq location (org-get-local-archive-location)
afile (org-extract-archive-file location)
heading (org-extract-archive-heading location)
infile-p (equal file (abbreviate-file-name (or afile ""))))
(unless afile
(error "Invalid `org-archive-location'"))
(if (> (length afile) 0)
(setq newfile-p (not (file-exists-p afile))
visiting (find-buffer-visiting afile)
buffer (or visiting (find-file-noselect afile)))
(setq buffer (current-buffer)))
(unless buffer
(error "Cannot access file \"%s\"" afile))
(let* ((tr-org-todo-keywords-1 org-todo-keywords-1)
(tr-org-todo-kwd-alist org-todo-kwd-alist)
(tr-org-done-keywords org-done-keywords)
(tr-org-todo-regexp org-todo-regexp)
(tr-org-todo-line-regexp org-todo-line-regexp)
(tr-org-odd-levels-only org-odd-levels-only)
(this-buffer (current-buffer))
(time (format-time-string
(substring (cdr org-time-stamp-formats) 1 -1)))
(file (abbreviate-file-name
(or (buffer-file-name (buffer-base-buffer))
(error "No file associated to buffer"))))
(location (org-get-local-archive-location))
(afile (or (org-extract-archive-file location)
(error "Invalid `org-archive-location'")))
(heading (org-extract-archive-heading location))
(infile-p (equal file (abbreviate-file-name (or afile ""))))
(newfile-p (and (org-string-nw-p afile)
(not (file-exists-p afile))))
(buffer (cond ((not (org-string-nw-p afile)) this-buffer)
((find-buffer-visiting afile))
((find-file-noselect afile))
(t (error "Cannot access file \"%s\"" afile))))
level datetree-date datetree-subheading-p)
(when (string-match "\\`datetree/" heading)
;; Replace with ***, to represent the 3 levels of headings the
;; datetree has.
@ -266,108 +269,120 @@ this heading."
(setq heading nil level 0))
(save-excursion
(org-back-to-heading t)
;; Get context information that will be lost by moving the tree
(setq category (org-get-category nil 'force-refresh)
todo (and (looking-at org-todo-line-regexp)
(match-string 2))
priority (org-get-priority
(if (match-end 3) (match-string 3) ""))
ltags (org-get-tags)
itags (org-delete-all ltags (org-get-tags-at))
atags (org-get-tags-at))
(setq ltags (mapconcat 'identity ltags " ")
itags (mapconcat 'identity itags " "))
;; We first only copy, in case something goes wrong
;; we need to protect `this-command', to avoid kill-region sets it,
;; which would lead to duplication of subtrees
(let (this-command) (org-copy-subtree 1 nil t))
(set-buffer buffer)
;; Enforce org-mode for the archive buffer
(if (not (derived-mode-p 'org-mode))
;; Force the mode for future visits.
(let ((org-insert-mode-line-in-empty-file t)
(org-inhibit-startup t))
(call-interactively 'org-mode)))
(when (and newfile-p org-archive-file-header-format)
(goto-char (point-max))
(insert (format org-archive-file-header-format
(buffer-file-name this-buffer))))
(when datetree-date
(require 'org-datetree)
(org-datetree-find-date-create datetree-date)
(org-narrow-to-subtree))
;; Force the TODO keywords of the original buffer
(let ((org-todo-line-regexp tr-org-todo-line-regexp)
(org-todo-keywords-1 tr-org-todo-keywords-1)
(org-todo-kwd-alist tr-org-todo-kwd-alist)
(org-done-keywords tr-org-done-keywords)
(org-todo-regexp tr-org-todo-regexp)
(org-todo-line-regexp tr-org-todo-line-regexp)
(org-odd-levels-only
(if (local-variable-p 'org-odd-levels-only (current-buffer))
org-odd-levels-only
tr-org-odd-levels-only)))
(goto-char (point-min))
(show-all)
(if (and heading (not (and datetree-date (not datetree-subheading-p))))
(progn
(if (re-search-forward
(concat "^" (regexp-quote heading)
(org-re "[ \t]*\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*\\($\\|\r\\)"))
nil t)
(goto-char (match-end 0))
;; Heading not found, just insert it at the end
(goto-char (point-max))
(or (bolp) (insert "\n"))
;; datetrees don't need too much spacing
(insert (if datetree-date "" "\n") heading "\n")
(end-of-line 0))
;; Make the subtree visible
(show-subtree)
(if org-archive-reversed-order
(progn
(org-back-to-heading t)
(outline-next-heading))
(org-end-of-subtree t))
(skip-chars-backward " \t\r\n")
(and (looking-at "[ \t\r\n]*")
;; datetree archives don't need so much spacing.
(replace-match (if datetree-date "\n" "\n\n"))))
;; No specific heading, just go to end of file.
(goto-char (point-max)) (unless datetree-date (insert "\n")))
;; Paste
(org-paste-subtree (org-get-valid-level level (and heading 1)))
;; Shall we append inherited tags?
(and itags
(or (and (eq org-archive-subtree-add-inherited-tags 'infile)
infile-p)
(eq org-archive-subtree-add-inherited-tags t))
(org-set-tags-to atags))
;; Mark the entry as done
(when (and org-archive-mark-done
(looking-at org-todo-line-regexp)
(or (not (match-end 2))
(not (member (match-string 2) org-done-keywords))))
(let (org-log-done org-todo-log-states)
(org-todo
(car (or (member org-archive-mark-done org-done-keywords)
org-done-keywords)))))
;; Get context information that will be lost by moving the
;; tree. See `org-archive-save-context-info'.
(let* ((all-tags (org-get-tags-at))
(local-tags (org-get-tags))
(inherited-tags (org-delete-all local-tags all-tags))
(context
`((category . ,(org-get-category nil 'force-refresh))
(file . ,file)
(itags . ,(mapconcat #'identity inherited-tags " "))
(ltags . ,(mapconcat #'identity local-tags " "))
(olpath . ,(mapconcat #'identity
(org-get-outline-path)
"/"))
(time . ,time)
(todo . ,(org-entry-get (point) "TODO")))))
;; We first only copy, in case something goes wrong
;; we need to protect `this-command', to avoid kill-region sets it,
;; which would lead to duplication of subtrees
(let (this-command) (org-copy-subtree 1 nil t))
(set-buffer buffer)
;; Enforce Org mode for the archive buffer
(if (not (derived-mode-p 'org-mode))
;; Force the mode for future visits.
(let ((org-insert-mode-line-in-empty-file t)
(org-inhibit-startup t))
(call-interactively 'org-mode)))
(when (and newfile-p org-archive-file-header-format)
(goto-char (point-max))
(insert (format org-archive-file-header-format
(buffer-file-name this-buffer))))
(when datetree-date
(require 'org-datetree)
(org-datetree-find-date-create datetree-date)
(org-narrow-to-subtree))
;; Force the TODO keywords of the original buffer
(let ((org-todo-line-regexp tr-org-todo-line-regexp)
(org-todo-keywords-1 tr-org-todo-keywords-1)
(org-todo-kwd-alist tr-org-todo-kwd-alist)
(org-done-keywords tr-org-done-keywords)
(org-todo-regexp tr-org-todo-regexp)
(org-todo-line-regexp tr-org-todo-line-regexp)
(org-odd-levels-only
(if (local-variable-p 'org-odd-levels-only (current-buffer))
org-odd-levels-only
tr-org-odd-levels-only)))
(goto-char (point-min))
(outline-show-all)
(if (and heading (not (and datetree-date (not datetree-subheading-p))))
(progn
(if (re-search-forward
(concat "^" (regexp-quote heading)
"[ \t]*\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*\\($\\|\r\\)")
nil t)
(goto-char (match-end 0))
;; Heading not found, just insert it at the end
(goto-char (point-max))
(or (bolp) (insert "\n"))
;; datetrees don't need too much spacing
(insert (if datetree-date "" "\n") heading "\n")
(end-of-line 0))
;; Make the subtree visible
(outline-show-subtree)
(if org-archive-reversed-order
(progn
(org-back-to-heading t)
(outline-next-heading))
(org-end-of-subtree t))
(skip-chars-backward " \t\r\n")
(and (looking-at "[ \t\r\n]*")
;; datetree archives don't need so much spacing.
(replace-match (if datetree-date "\n" "\n\n"))))
;; No specific heading, just go to end of file.
(goto-char (point-max))
;; Subtree narrowing can let the buffer end on
;; a headline. `org-paste-subtree' then deletes it.
;; To prevent this, make sure visible part of buffer
;; always terminates on a new line, while limiting
;; number of blank lines in a date tree.
(unless (and datetree-date (bolp)) (insert "\n")))
;; Paste
(org-paste-subtree (org-get-valid-level level (and heading 1)))
;; Shall we append inherited tags?
(and inherited-tags
(or (and (eq org-archive-subtree-add-inherited-tags 'infile)
infile-p)
(eq org-archive-subtree-add-inherited-tags t))
(org-set-tags-to all-tags))
;; Mark the entry as done
(when (and org-archive-mark-done
(let ((case-fold-search nil))
(looking-at org-todo-line-regexp))
(or (not (match-end 2))
(not (member (match-string 2) org-done-keywords))))
(let (org-log-done org-todo-log-states)
(org-todo
(car (or (member org-archive-mark-done org-done-keywords)
org-done-keywords)))))
;; Add the context info
(when org-archive-save-context-info
(let ((l org-archive-save-context-info) e n v)
(while (setq e (pop l))
(when (and (setq v (symbol-value e))
(stringp v) (string-match "\\S-" v))
(setq n (concat "ARCHIVE_" (upcase (symbol-name e))))
(org-entry-put (point) n v)))))
(widen)
;; Save and kill the buffer, if it is not the same buffer.
(when (not (eq this-buffer buffer))
(save-buffer))))
;; Here we are back in the original buffer. Everything seems to have
;; worked. So now cut the tree and finish up.
;; Add the context info.
(dolist (item org-archive-save-context-info)
(let ((value (cdr (assq item context))))
(when (org-string-nw-p value)
(org-entry-put
(point)
(concat "ARCHIVE_" (upcase (symbol-name item)))
value))))
(widen)
;; Save and kill the buffer, if it is not the same
;; buffer.
(unless (eq this-buffer buffer) (save-buffer)))))
;; Here we are back in the original buffer. Everything seems
;; to have worked. So now run hooks, cut the tree and finish
;; up.
(run-hooks 'org-archive-hook)
(let (this-command) (org-cut-subtree))
(when (featurep 'org-inlinetask)
(org-inlinetask-remove-END-maybe))
@ -375,7 +390,7 @@ this heading."
(message "Subtree archived %s"
(if (eq this-buffer buffer)
(concat "under heading: " heading)
(concat "in file: " (abbreviate-file-name afile))))))
(concat "in file: " (abbreviate-file-name afile)))))))
(org-reveal)
(if (looking-at "^[ \t]*$")
(outline-next-visible-heading 1))))
@ -383,9 +398,12 @@ this heading."
;;;###autoload
(defun org-archive-to-archive-sibling ()
"Archive the current heading by moving it under the archive sibling.
The archive sibling is a sibling of the heading with the heading name
`org-archive-sibling-heading' and an `org-archive-tag' tag. If this
sibling does not exist, it will be created at the end of the subtree."
sibling does not exist, it will be created at the end of the subtree.
Archiving time is retained in the ARCHIVE_TIME node property."
(interactive)
(if (and (org-region-active-p) org-loop-over-headlines-in-active-region)
(let ((cl (when (eq org-loop-over-headlines-in-active-region 'start-level)
@ -400,7 +418,7 @@ sibling does not exist, it will be created at the end of the subtree."
(when (org-at-heading-p)
(org-archive-to-archive-sibling)))
org-loop-over-headlines-in-active-region
cl (if (outline-invisible-p) (org-end-of-subtree nil t))))
cl (if (org-invisible-p) (org-end-of-subtree nil t))))
(save-restriction
(widen)
(let (b e pos leader level)
@ -443,7 +461,7 @@ sibling does not exist, it will be created at the end of the subtree."
(format-time-string
(substring (cdr org-time-stamp-formats) 1 -1)))
(outline-up-heading 1 t)
(hide-subtree)
(outline-hide-subtree)
(org-cycle-show-empty-lines 'folded)
(goto-char pos)))
(org-reveal)
@ -455,13 +473,51 @@ sibling does not exist, it will be created at the end of the subtree."
If the cursor is not on a headline, try all level 1 trees. If
it is on a headline, try all direct children.
When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
(let ((re org-not-done-heading-regexp) re1
(rea (concat ".*:" org-archive-tag ":"))
(org-archive-all-matches
(lambda (_beg end)
(let ((case-fold-search nil))
(unless (re-search-forward org-not-done-heading-regexp end t)
"no open TODO items")))
tag))
(defun org-archive-all-old (&optional tag)
"Archive sublevels of the current tree with timestamps prior to today.
If the cursor is not on a headline, try all level 1 trees. If
it is on a headline, try all direct children.
When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
(org-archive-all-matches
(lambda (_beg end)
(let (ts)
(and (re-search-forward org-ts-regexp end t)
(setq ts (match-string 0))
(< (org-time-stamp-to-now ts) 0)
(if (not (looking-at
(concat "--\\(" org-ts-regexp "\\)")))
(concat "old timestamp " ts)
(setq ts (concat "old timestamp " ts (match-string 0)))
(and (< (org-time-stamp-to-now (match-string 1)) 0)
ts)))))
tag))
(defun org-archive-all-matches (predicate &optional tag)
"Archive sublevels of the current tree that match PREDICATE.
PREDICATE is a function of two arguments, BEG and END, which
specify the beginning and end of the headline being considered.
It is called with point positioned at BEG. The headline will be
archived if PREDICATE returns non-nil. If the return value of
PREDICATE is a string, it should describe the reason for
archiving the heading.
If the cursor is not on a headline, try all level 1 trees. If it
is on a headline, try all direct children. When TAG is non-nil,
don't move trees, but mark them with the ARCHIVE tag."
(let ((rea (concat ".*:" org-archive-tag ":")) re1
(begm (make-marker))
(endm (make-marker))
(question (if tag "Set ARCHIVE tag (no open TODO items)? "
"Move subtree to archive (no open TODO items)? "))
beg end (cntarch 0))
(question (if tag "Set ARCHIVE tag? "
"Move subtree to archive? "))
reason beg end (cntarch 0))
(if (org-at-heading-p)
(progn
(setq re1 (concat "^" (regexp-quote
@ -481,11 +537,14 @@ When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
(setq beg (match-beginning 0)
end (save-excursion (org-end-of-subtree t) (point)))
(goto-char beg)
(if (re-search-forward re end t)
(if (not (setq reason (funcall predicate beg end)))
(goto-char end)
(goto-char beg)
(if (and (or (not tag) (not (looking-at rea)))
(y-or-n-p question))
(y-or-n-p
(if (stringp reason)
(concat question "(" reason ")")
question)))
(progn
(if tag
(org-toggle-tag org-archive-tag 'on)
@ -507,14 +566,14 @@ the children that do not contain any open TODO items."
(org-map-entries
`(org-toggle-archive-tag ,find-done)
org-loop-over-headlines-in-active-region
cl (if (outline-invisible-p) (org-end-of-subtree nil t))))
cl (if (org-invisible-p) (org-end-of-subtree nil t))))
(if find-done
(org-archive-all-done 'tag)
(let (set)
(save-excursion
(org-back-to-heading t)
(setq set (org-toggle-tag org-archive-tag))
(when set (hide-subtree)))
(when set (org-flag-subtree t)))
(and set (beginning-of-line 1))
(message "Subtree %s" (if set "archived" "unarchived"))))))
@ -528,7 +587,7 @@ the children that do not contain any open TODO items."
(org-map-entries
'org-archive-set-tag
org-loop-over-headlines-in-active-region
cl (if (outline-invisible-p) (org-end-of-subtree nil t))))
cl (if (org-invisible-p) (org-end-of-subtree nil t))))
(org-toggle-tag org-archive-tag 'on)))
;;;###autoload

154
lisp/org/org-attach.el
View file

@ -1,4 +1,4 @@
;;; org-attach.el --- Manage file attachments to org-mode tasks
;;; org-attach.el --- Manage file attachments to Org tasks -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2017 Free Software Foundation, Inc.
@ -22,7 +22,7 @@
;;; Commentary:
;; See the Org-mode manual for information on how to use it.
;; See the Org manual for information on how to use it.
;;
;; Attachments are managed in a special directory called "data", which
;; lives in the same directory as the org file itself. If this data
@ -37,14 +37,13 @@
;;; Code:
(eval-when-compile
(require 'cl))
(require 'org-id)
(require 'cl-lib)
(require 'org)
(require 'org-id)
(require 'vc-git)
(defgroup org-attach nil
"Options concerning entry attachments in Org-mode."
"Options concerning entry attachments in Org mode."
:tag "Org Attach"
:group 'org)
@ -55,6 +54,14 @@ where the Org file lives."
:group 'org-attach
:type 'directory)
(defcustom org-attach-commit t
"If non-nil commit attachments with git.
This is only done if the Org file is in a git repository."
:group 'org-attach
:type 'boolean
:version "26.1"
:package-version '(Org . "9.0"))
(defcustom org-attach-git-annex-cutoff (* 32 1024)
"If non-nil, files larger than this will be annexed instead of stored."
:group 'org-attach
@ -120,6 +127,28 @@ lns create a symbol link. Note that this is not supported
(const :tag "Link to origin location" t)
(const :tag "Link to the attach-dir location" attached)))
(defcustom org-attach-archive-delete nil
"Non-nil means attachments are deleted upon archiving a subtree.
When set to `query', ask the user instead."
:group 'org-attach
:version "26.1"
:package-version '(Org . "8.3")
:type '(choice
(const :tag "Never delete attachments" nil)
(const :tag "Always delete attachments" t)
(const :tag "Query the user" query)))
(defcustom org-attach-annex-auto-get 'ask
"Confirmation preference for automatically getting annex files.
If \\='ask, prompt using `y-or-n-p'. If t, always get. If nil, never get."
:group 'org-attach
:package-version '(Org . "9")
:version "26.1"
:type '(choice
(const :tag "confirm with `y-or-n-p'" ask)
(const :tag "always get from annex if necessary" t)
(const :tag "never get from annex" nil)))
;;;###autoload
(defun org-attach ()
"The dispatcher for attachment commands.
@ -197,25 +226,23 @@ using the entry ID will be invoked to access the unique directory for the
current entry.
If the directory does not exist and CREATE-IF-NOT-EXISTS-P is non-nil,
the directory and (if necessary) the corresponding ID will be created."
(let (attach-dir uuid inherit)
(let (attach-dir uuid)
(setq org-attach-inherited (org-entry-get nil "ATTACH_DIR_INHERIT"))
(cond
((setq attach-dir (org-entry-get nil "ATTACH_DIR"))
(org-attach-check-absolute-path attach-dir))
((and org-attach-allow-inheritance
(setq inherit (org-entry-get nil "ATTACH_DIR_INHERIT" t)))
(org-entry-get nil "ATTACH_DIR_INHERIT" t))
(setq attach-dir
(save-excursion
(save-restriction
(widen)
(if (marker-position org-entry-property-inherited-from)
(goto-char org-entry-property-inherited-from)
(org-back-to-heading t))
(let (org-attach-allow-inheritance)
(org-attach-dir create-if-not-exists-p)))))
(org-with-wide-buffer
(if (marker-position org-entry-property-inherited-from)
(goto-char org-entry-property-inherited-from)
(org-back-to-heading t))
(let (org-attach-allow-inheritance)
(org-attach-dir create-if-not-exists-p))))
(org-attach-check-absolute-path attach-dir)
(setq org-attach-inherited t))
(t ; use the ID
(t ; use the ID
(org-attach-check-absolute-path nil)
(setq uuid (org-id-get (point) create-if-not-exists-p))
(when (or uuid create-if-not-exists-p)
@ -261,33 +288,59 @@ the ATTACH_DIR property) their own attachment directory."
(org-entry-put nil "ATTACH_DIR_INHERIT" "t")
(message "Children will inherit attachment directory"))
(defun org-attach-use-annex ()
"Return non-nil if git annex can be used."
(let ((git-dir (vc-git-root (expand-file-name org-attach-directory))))
(and org-attach-git-annex-cutoff
(or (file-exists-p (expand-file-name "annex" git-dir))
(file-exists-p (expand-file-name ".git/annex" git-dir))))))
(defun org-attach-annex-get-maybe (path)
"Call git annex get PATH (via shell) if using git annex.
Signals an error if the file content is not available and it was not retrieved."
(let ((path-relative (file-relative-name path)))
(when (and (org-attach-use-annex)
(not
(string-equal
"found"
(shell-command-to-string
(format "git annex find --format=found --in=here %s"
(shell-quote-argument path-relative))))))
(let ((should-get
(if (eq org-attach-annex-auto-get 'ask)
(y-or-n-p (format "Run git annex get %s? " path-relative))
org-attach-annex-auto-get)))
(if should-get
(progn (message "Running git annex get \"%s\"." path-relative)
(call-process "git" nil nil nil "annex" "get" path-relative))
(error "File %s stored in git annex but it is not available, and was not retrieved"
path))))))
(defun org-attach-commit ()
"Commit changes to git if `org-attach-directory' is properly initialized.
This checks for the existence of a \".git\" directory in that directory."
(let* ((dir (expand-file-name org-attach-directory))
(git-dir (vc-git-root dir))
(use-annex (org-attach-use-annex))
(changes 0))
(when (and git-dir (executable-find "git"))
(with-temp-buffer
(cd dir)
(let ((have-annex
(and org-attach-git-annex-cutoff
(file-exists-p (expand-file-name "annex" git-dir)))))
(dolist (new-or-modified
(split-string
(shell-command-to-string
"git ls-files -zmo --exclude-standard") "\0" t))
(if (and have-annex
(>= (nth 7 (file-attributes new-or-modified))
org-attach-git-annex-cutoff))
(call-process "git" nil nil nil "annex" "add" new-or-modified)
(call-process "git" nil nil nil "add" new-or-modified))
(incf changes)))
(dolist (new-or-modified
(split-string
(shell-command-to-string
"git ls-files -zmo --exclude-standard") "\0" t))
(if (and use-annex
(>= (nth 7 (file-attributes new-or-modified))
org-attach-git-annex-cutoff))
(call-process "git" nil nil nil "annex" "add" new-or-modified)
(call-process "git" nil nil nil "add" new-or-modified))
(cl-incf changes))
(dolist (deleted
(split-string
(shell-command-to-string "git ls-files -z --deleted") "\0" t))
(call-process "git" nil nil nil "rm" deleted)
(incf changes))
(cl-incf changes))
(when (> changes 0)
(shell-command "git commit -m 'Synchronized attachments'"))))))
@ -328,7 +381,8 @@ METHOD may be `cp', `mv', `ln', or `lns' default taken from
((eq method 'cp) (copy-file file fname))
((eq method 'ln) (add-name-to-file file fname))
((eq method 'lns) (make-symbolic-link file fname)))
(org-attach-commit)
(when org-attach-commit
(org-attach-commit))
(org-attach-tag)
(cond ((eq org-attach-store-link-p 'attached)
(org-attach-store-link fname))
@ -378,7 +432,7 @@ The attachment is created as an Emacs buffer."
(let* ((attach-dir (org-attach-dir t))
(files (org-attach-file-list attach-dir))
(file (or file
(org-icompleting-read
(completing-read
"Delete attachment: "
(mapcar (lambda (f)
(list (file-name-nondirectory f)))
@ -387,7 +441,8 @@ The attachment is created as an Emacs buffer."
(unless (file-exists-p file)
(error "No such attachment: %s" file))
(delete-file file)
(org-attach-commit)))
(when org-attach-commit
(org-attach-commit))))
(defun org-attach-delete-all (&optional force)
"Delete all attachments from the current task.
@ -403,14 +458,16 @@ A safer way is to open the directory in dired and delete from there."
(y-or-n-p "Are you sure you want to remove all attachments of this entry? ")))
(shell-command (format "rm -fr %s" attach-dir))
(message "Attachment directory removed")
(org-attach-commit)
(when org-attach-commit
(org-attach-commit))
(org-attach-untag))))
(defun org-attach-sync ()
"Synchronize the current tasks with its attachments.
This can be used after files have been added externally."
(interactive)
(org-attach-commit)
(when org-attach-commit
(org-attach-commit))
(when (and org-attach-file-list-property (not org-attach-inherited))
(org-entry-delete (point) org-attach-file-list-property))
(let ((attach-dir (org-attach-dir)))
@ -419,15 +476,15 @@ This can be used after files have been added externally."
(and files (org-attach-tag))
(when org-attach-file-list-property
(dolist (file files)
(unless (string-match "^\\." file)
(unless (string-match "^\\.\\.?\\'" file)
(org-entry-add-to-multivalued-property
(point) org-attach-file-list-property file))))))))
(defun org-attach-file-list (dir)
"Return a list of files in the attachment directory.
This ignores files starting with a \".\", and files ending in \"~\"."
This ignores files ending in \"~\"."
(delq nil
(mapcar (lambda (x) (if (string-match "^\\." x) nil x))
(mapcar (lambda (x) (if (string-match "^\\.\\.?\\'" x) nil x))
(directory-files dir nil "[^~]\\'"))))
(defun org-attach-reveal (&optional if-exists)
@ -454,9 +511,11 @@ If IN-EMACS is non-nil, force opening in Emacs."
(files (org-attach-file-list attach-dir))
(file (if (= (length files) 1)
(car files)
(org-icompleting-read "Open attachment: "
(mapcar 'list files) nil t))))
(org-open-file (expand-file-name file attach-dir) in-emacs)))
(completing-read "Open attachment: "
(mapcar #'list files) nil t)))
(path (expand-file-name file attach-dir)))
(org-attach-annex-get-maybe path)
(org-open-file path in-emacs)))
(defun org-attach-open-in-emacs ()
"Open attachment, force opening in Emacs.
@ -475,6 +534,17 @@ Basically, this adds the path to the attachment directory, and a \"file:\"
prefix."
(concat "file:" (org-attach-expand file)))
(defun org-attach-archive-delete-maybe ()
"Maybe delete subtree attachments when archiving.
This function is called by `org-archive-hook'. The option
`org-attach-archive-delete' controls its behavior."
(when (if (eq org-attach-archive-delete 'query)
(yes-or-no-p "Delete all attachments? ")
org-attach-archive-delete)
(org-attach-delete-all t)))
(add-hook 'org-archive-hook 'org-attach-archive-delete-maybe)
(provide 'org-attach)
;; Local variables:

110
lisp/org/org-bbdb.el
View file

@ -1,4 +1,4 @@
;;; org-bbdb.el --- Support for links to BBDB entries from within Org-mode
;;; org-bbdb.el --- Support for links to BBDB entries -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2017 Free Software Foundation, Inc.
@ -25,12 +25,12 @@
;;
;;; Commentary:
;; This file implements links to BBDB database entries from within Org-mode.
;; Org-mode loads this module by default - if this is not what you want,
;; This file implements links to BBDB database entries from within Org.
;; Org mode loads this module by default - if this is not what you want,
;; configure the variable `org-modules'.
;; It also implements an interface (based on Ivar Rummelhoff's
;; bbdb-anniv.el) for those org-mode users, who do not use the diary
;; bbdb-anniv.el) for those Org users, who do not use the diary
;; but who do want to include the anniversaries stored in the BBDB
;; into the org-agenda. If you already include the `diary' into the
;; agenda, you might want to prefer to include the anniversaries in
@ -94,8 +94,7 @@
;;; Code:
(require 'org)
(eval-when-compile
(require 'cl))
(require 'cl-lib)
;; Declare external functions and variables
@ -106,6 +105,7 @@
(declare-function bbdb-name "ext:bbdb-com" (string elidep))
(declare-function bbdb-completing-read-record "ext:bbdb-com"
(prompt &optional omit-records))
(declare-function bbdb-record-field "ext:bbdb" (recond field))
(declare-function bbdb-record-getprop "ext:bbdb" (record property))
(declare-function bbdb-record-name "ext:bbdb" (record))
(declare-function bbdb-records "ext:bbdb"
@ -124,7 +124,7 @@
(declare-function calendar-leap-year-p "calendar" (year))
(declare-function diary-ordinal-suffix "diary-lib" (n))
(org-no-warnings (defvar date)) ;; unprefixed, from calendar.el
(with-no-warnings (defvar date)) ;; unprefixed, from calendar.el
;; Customization
@ -194,10 +194,12 @@ date year)."
:group 'org-bbdb-anniversaries
:require 'bbdb)
;; Install the link type
(org-add-link-type "bbdb" 'org-bbdb-open 'org-bbdb-export)
(add-hook 'org-store-link-functions 'org-bbdb-store-link)
(org-link-set-parameters "bbdb"
:follow #'org-bbdb-open
:export #'org-bbdb-export
:complete #'org-bbdb-complete-link
:store #'org-bbdb-store-link)
;; Implementation
(defun org-bbdb-store-link ()
@ -208,7 +210,7 @@ date year)."
(name (bbdb-record-name rec))
(company (if (fboundp 'bbdb-record-getprop)
(bbdb-record-getprop rec 'company)
(car (bbdb-record-get-field rec 'organization))))
(car (bbdb-record-field rec 'organization))))
(link (concat "bbdb:" name)))
(org-store-link-props :type "bbdb" :name name :company company
:link link :description name)
@ -230,10 +232,9 @@ italicized, in all other cases it is left unchanged."
(defun org-bbdb-open (name)
"Follow a BBDB link to NAME."
(require 'bbdb-com)
(let ((inhibit-redisplay (not debug-on-error))
(bbdb-electric-p nil))
(let ((inhibit-redisplay (not debug-on-error)))
(if (fboundp 'bbdb-name)
(org-bbdb-open-old name)
(org-bbdb-open-old name)
(org-bbdb-open-new name))))
(defun org-bbdb-open-old (name)
@ -280,14 +281,11 @@ italicized, in all other cases it is left unchanged."
"Convert YYYY-MM-DD to (month date year).
Argument TIME-STR is the value retrieved from BBDB. If YYYY- is omitted
it will be considered unknown."
(multiple-value-bind (a b c) (values-list (org-split-string time-str "-"))
(if (eq c nil)
(list (string-to-number a)
(string-to-number b)
nil)
(list (string-to-number b)
(string-to-number c)
(string-to-number a)))))
(pcase (org-split-string time-str "-")
(`(,a ,b nil) (list (string-to-number a) (string-to-number b) nil))
(`(,a ,b ,c) (list (string-to-number b)
(string-to-number c)
(string-to-number a)))))
(defun org-bbdb-anniv-split (str)
"Split multiple entries in the BBDB anniversary field.
@ -325,9 +323,9 @@ The anniversaries are assumed to be stored `org-bbdb-anniversary-field'."
(bbdb-split "\n" annivs)))
(while annivs
(setq split (org-bbdb-anniv-split (pop annivs)))
(multiple-value-bind (m d y)
(values-list (funcall org-bbdb-extract-date-fun (car split)))
(setq tmp (gethash (list m d) org-bbdb-anniv-hash))
(pcase-let ((`(,m ,d ,y) (funcall org-bbdb-extract-date-fun
(car split))))
(setq tmp (gethash (list m d) org-bbdb-anniv-hash))
(puthash (list m d) (cons (list y
(bbdb-record-name rec)
(cadr split))
@ -335,7 +333,7 @@ The anniversaries are assumed to be stored `org-bbdb-anniversary-field'."
org-bbdb-anniv-hash))))))
(setq org-bbdb-updated-p nil))
(defun org-bbdb-updated (rec)
(defun org-bbdb-updated (_rec)
"Record the fact that BBDB has been updated.
This is used by Org to re-create the anniversary hash table."
(setq org-bbdb-updated-p t))
@ -397,6 +395,66 @@ This is used by Org to re-create the anniversary hash table."
))
text))
;;; Return list of anniversaries for today and the next n-1 (default: n=7) days.
;;; This is meant to be used in an org file instead of org-bbdb-anniversaries:
;;;
;;; %%(org-bbdb-anniversaries-future)
;;;
;;; or
;;;
;;; %%(org-bbdb-anniversaries-future 3)
;;;
;;; to override the 7-day default.
(defun org-bbdb-date-list (d n)
"Return a list of dates in (m d y) format from the given date D to n-1 days hence."
(let ((abs (calendar-absolute-from-gregorian d)))
(mapcar (lambda (i) (calendar-gregorian-from-absolute (+ abs i)))
(number-sequence 0 (1- n)))))
;;;###autoload
(defun org-bbdb-anniversaries-future (&optional n)
"Return list of anniversaries for today and the next n-1 days (default n=7)."
(let ((n (or n 7)))
(when (<= n 0)
(error "The (optional) argument of `org-bbdb-anniversaries-future' \
must be positive"))
(let (
;; List of relevant dates.
(dates (org-bbdb-date-list date n))
;; Function to annotate text of each element of l with the
;; anniversary date d.
(annotate-descriptions
(lambda (d l)
(mapcar (lambda (x)
;; The assumption here is that x is a bbdb link
;; of the form [[bbdb:name][description]].
;; This function rather arbitrarily modifies
;; the description by adding the date to it in
;; a fixed format.
(string-match "]]" x)
(replace-match (format " -- %d-%02d-%02d\\&"
(nth 2 d)
(nth 0 d)
(nth 1 d))
nil nil x))
l))))
;; Map a function that generates anniversaries for each date
;; over the dates and nconc the results into a single list. When
;; it is no longer necessary to support older versions of Emacs,
;; this can be done with a cl-mapcan; for now, we use the (apply
;; #'nconc ...) method for compatibility.
(apply #'nconc
(mapcar
(lambda (d)
(let ((date d))
;; Rebind 'date' so that org-bbdb-anniversaries will
;; be fooled into giving us the list for the given
;; date and then annotate the descriptions for that
;; date.
(funcall annotate-descriptions d (org-bbdb-anniversaries))))
dates)))))
(defun org-bbdb-complete-link ()
"Read a bbdb link with name completion."
(require 'bbdb-com)

161
lisp/org/org-bibtex.el
View file

@ -1,4 +1,4 @@
;;; org-bibtex.el --- Org links to BibTeX entries
;;; org-bibtex.el --- Org links to BibTeX entries -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2007-2017 Free Software Foundation, Inc.
;;
@ -73,7 +73,7 @@
;; =====================================================================
;;
;; Additionally, the following functions are now available for storing
;; bibtex entries within Org-mode documents.
;; bibtex entries within Org documents.
;;
;; - Run `org-bibtex' to export the current file to a .bib.
;;
@ -92,27 +92,28 @@
;;
;;; History:
;;
;; The link creation part has been part of Org-mode for a long time.
;; The link creation part has been part of Org for a long time.
;;
;; Creating better capture template information was inspired by a request
;; of Austin Frank: http://article.gmane.org/gmane.emacs.orgmode/4112
;; and then implemented by Bastien Guerry.
;;
;; Eric Schulte eventually added the functions for translating between
;; Org-mode headlines and Bibtex entries, and for fleshing out the Bibtex
;; fields of existing Org-mode headlines.
;; Org headlines and Bibtex entries, and for fleshing out the Bibtex
;; fields of existing Org headlines.
;;
;; Org-mode loads this module by default - if this is not what you want,
;; Org mode loads this module by default - if this is not what you want,
;; configure the variable `org-modules'.
;;; Code:
(require 'org)
(require 'bibtex)
(eval-when-compile
(require 'cl))
(require 'cl-lib)
(require 'org-compat)
(defvar org-agenda-overriding-header)
(defvar org-agenda-search-view-always-boolean)
(defvar org-bibtex-description nil) ; dynamically scoped from org.el
(defvar org-id-locations)
@ -120,7 +121,6 @@
(declare-function bibtex-generate-autokey "bibtex" ())
(declare-function bibtex-parse-entry "bibtex" (&optional content))
(declare-function bibtex-url "bibtex" (&optional pos no-browse))
(declare-function org-babel-trim "ob-core" (string &optional regexp))
;;; Bibtex data
@ -264,26 +264,39 @@ IDs must be unique."
(defcustom org-bibtex-tags-are-keywords nil
"Convert the value of the keywords field to tags and vice versa.
If set to t, comma-separated entries in a bibtex entry's keywords
field will be converted to org tags. Note: spaces will be escaped
with underscores, and characters that are not permitted in org
When non-nil, comma-separated entries in a bibtex entry's keywords
field will be converted to Org tags. Note: spaces will be escaped
with underscores, and characters that are not permitted in Org
tags will be removed.
If t, local tags in an org entry will be exported as a
comma-separated string of keywords when exported to bibtex. Tags
defined in `org-bibtex-tags' or `org-bibtex-no-export-tags' will
not be exported."
When non-nil, local tags in an Org entry will be exported as
a comma-separated string of keywords when exported to bibtex.
If `org-bibtex-inherit-tags' is non-nil, inherited tags will also
be exported as keywords. Tags defined in `org-bibtex-tags' or
`org-bibtex-no-export-tags' will not be exported."
:group 'org-bibtex
:version "24.1"
:type 'boolean)
(defcustom org-bibtex-no-export-tags nil
"List of tag(s) that should not be converted to keywords.
This variable is relevant only if `org-bibtex-tags-are-keywords' is t."
This variable is relevant only if `org-bibtex-tags-are-keywords'
is non-nil."
:group 'org-bibtex
:version "24.1"
:type '(repeat :tag "Tag" (string)))
(defcustom org-bibtex-inherit-tags nil
"Controls whether inherited tags are converted to bibtex keywords.
It is relevant only if `org-bibtex-tags-are-keywords' is non-nil.
Tag inheritence itself is controlled by `org-use-tag-inheritence'
and `org-exclude-tags-from-inheritence'."
:group 'org-bibtex
:version "26.1"
:package-version '(Org . "8.3")
:type 'boolean)
(defcustom org-bibtex-type-property-name "btype"
"Property in which to store bibtex entry type (e.g., article)."
:group 'org-bibtex
@ -299,7 +312,7 @@ This variable is relevant only if `org-bibtex-tags-are-keywords' is t."
(org-entry-get (point) (upcase property))
(org-entry-get (point) (concat org-bibtex-prefix
(upcase property)))))))
(when it (org-babel-trim it))))
(when it (org-trim it))))
(defun org-bibtex-put (property value)
(let ((prop (upcase (if (keywordp property)
@ -312,27 +325,27 @@ This variable is relevant only if `org-bibtex-tags-are-keywords' is t."
(defun org-bibtex-headline ()
"Return a bibtex entry of the given headline as a string."
(let* ((val (lambda (key lst) (cdr (assoc key lst))))
(to (lambda (string) (intern (concat ":" string))))
(from (lambda (key) (substring (symbol-name key) 1)))
flatten ; silent compiler warning
(flatten (lambda (&rest lsts)
(apply #'append (mapcar
(lambda (e)
(if (listp e) (apply flatten e) (list e)))
lsts))))
(notes (buffer-string))
(id (org-bibtex-get org-bibtex-key-property))
(type (org-bibtex-get org-bibtex-type-property-name))
(tags (when org-bibtex-tags-are-keywords
(delq nil
(mapcar
(lambda (tag)
(unless (member tag
(append org-bibtex-tags
org-bibtex-no-export-tags))
tag))
(org-get-local-tags-at))))))
(letrec ((val (lambda (key lst) (cdr (assoc key lst))))
(to (lambda (string) (intern (concat ":" string))))
(from (lambda (key) (substring (symbol-name key) 1)))
(flatten (lambda (&rest lsts)
(apply #'append (mapcar
(lambda (e)
(if (listp e) (apply flatten e) (list e)))
lsts))))
(id (org-bibtex-get org-bibtex-key-property))
(type (org-bibtex-get org-bibtex-type-property-name))
(tags (when org-bibtex-tags-are-keywords
(delq nil
(mapcar
(lambda (tag)
(unless (member tag
(append org-bibtex-tags
org-bibtex-no-export-tags))
tag))
(if org-bibtex-inherit-tags
(org-get-tags-at)
(org-get-local-tags-at)))))))
(when type
(let ((entry (format
"@%s{%s,\n%s\n}\n" type id
@ -358,7 +371,7 @@ This variable is relevant only if `org-bibtex-tags-are-keywords' is t."
(mapcar
(lambda (field)
(let ((value (or (org-bibtex-get (funcall from field))
(and (equal :title field)
(and (eq :title field)
(nth 4 (org-heading-components))))))
(when value (cons (funcall from field) value))))
(funcall flatten
@ -421,13 +434,14 @@ With optional argument OPTIONAL, also prompt for optional fields."
(funcall val :required (funcall val type org-bibtex-types)))
(when optional (funcall val :optional (funcall val type org-bibtex-types)))))
(when (consp field) ; or'd pair of fields e.g., (:editor :author)
(let ((present (first (remove
(let ((present (nth 0 (remove
nil
(mapcar
(lambda (f) (when (org-bibtex-get (funcall name f)) f))
(lambda (f)
(when (org-bibtex-get (funcall name f)) f))
field)))))
(setf field (or present (funcall keyword
(org-icompleting-read
(completing-read
"Field: " (mapcar name field)))))))
(let ((name (funcall name field)))
(unless (org-bibtex-get name)
@ -439,8 +453,9 @@ With optional argument OPTIONAL, also prompt for optional fields."
;;; Bibtex link functions
(org-add-link-type "bibtex" 'org-bibtex-open)
(add-hook 'org-store-link-functions 'org-bibtex-store-link)
(org-link-set-parameters "bibtex"
:follow #'org-bibtex-open
:store #'org-bibtex-store-link)
(defun org-bibtex-open (path)
"Visit the bibliography entry on PATH."
@ -533,21 +548,23 @@ With optional argument OPTIONAL, also prompt for optional fields."
(add-hook 'org-execute-file-search-functions 'org-execute-file-search-in-bibtex)
;;; Bibtex <-> Org-mode headline translation functions
(defun org-bibtex (&optional filename)
;;; Bibtex <-> Org headline translation functions
(defun org-bibtex (filename)
"Export each headline in the current file to a bibtex entry.
Headlines are exported using `org-bibtex-headline'."
(interactive
(list (read-file-name
"Bibtex file: " nil nil nil
(file-name-nondirectory
(concat (file-name-sans-extension (buffer-file-name)) ".bib")))))
(let ((file (buffer-file-name (buffer-base-buffer))))
(and file
(file-name-nondirectory
(concat (file-name-sans-extension file) ".bib")))))))
(let ((error-point
(catch 'bib
(let ((bibtex-entries
(remove nil (org-map-entries
(lambda ()
(condition-case foo
(condition-case nil
(org-bibtex-headline)
(error (throw 'bib (point)))))))))
(with-temp-file filename
@ -578,7 +595,7 @@ With prefix argument OPTIONAL also prompt for optional fields."
With a prefix arg, query for optional fields as well.
If nonew is t, add data to the headline of the entry at point."
(interactive "P")
(let* ((type (org-icompleting-read
(let* ((type (completing-read
"Type: " (mapcar (lambda (type)
(substring (symbol-name (car type)) 1))
org-bibtex-types)
@ -597,7 +614,7 @@ If nonew is t, add data to the headline of the entry at point."
(org-bibtex-put org-bibtex-type-property-name
(substring (symbol-name type) 1))
(org-bibtex-fleshout type arg)
(mapc (lambda (tag) (org-toggle-tag tag 'on)) org-bibtex-tags)))
(dolist (tag org-bibtex-tags) (org-toggle-tag tag 'on))))
(defun org-bibtex-create-in-current-entry (&optional arg)
"Add bibliographical data to the current entry.
@ -611,10 +628,10 @@ This uses `bibtex-parse-entry'."
(interactive)
(let ((keyword (lambda (str) (intern (concat ":" (downcase str)))))
(clean-space (lambda (str) (replace-regexp-in-string
"[[:space:]\n\r]+" " " str)))
"[[:space:]\n\r]+" " " str)))
(strip-delim
(lambda (str) ; strip enclosing "..." and {...}
(dolist (pair '((34 . 34) (123 . 125) (123 . 125)))
(lambda (str) ; strip enclosing "..." and {...}
(dolist (pair '((34 . 34) (123 . 125)))
(when (and (> (length str) 1)
(= (aref str 0) (car pair))
(= (aref str (1- (length str))) (cdr pair)))
@ -622,10 +639,10 @@ This uses `bibtex-parse-entry'."
(push (mapcar
(lambda (pair)
(cons (let ((field (funcall keyword (car pair))))
(case field
(pcase field
(:=type= :type)
(:=key= :key)
(otherwise field)))
(_ field)))
(funcall clean-space (funcall strip-delim (cdr pair)))))
(save-excursion (bibtex-beginning-of-entry) (bibtex-parse-entry)))
org-bibtex-entries)))
@ -633,7 +650,7 @@ This uses `bibtex-parse-entry'."
(defun org-bibtex-read-buffer (buffer)
"Read all bibtex entries in BUFFER and save to `org-bibtex-entries'.
Return the number of saved entries."
(interactive "bbuffer: ")
(interactive "bBuffer: ")
(let ((start-length (length org-bibtex-entries)))
(with-current-buffer buffer
(save-excursion
@ -643,12 +660,12 @@ Return the number of saved entries."
(org-bibtex-read)
(bibtex-beginning-of-entry))))
(let ((added (- (length org-bibtex-entries) start-length)))
(message "parsed %d entries" added)
(message "Parsed %d entries" added)
added)))
(defun org-bibtex-read-file (file)
"Read FILE with `org-bibtex-read-buffer'."
(interactive "ffile: ")
(interactive "fFile: ")
(org-bibtex-read-buffer (find-file-noselect file 'nowarn 'rawfile)))
(defun org-bibtex-write ()
@ -666,25 +683,23 @@ Return the number of saved entries."
(org-bibtex-put org-bibtex-type-property-name
(downcase (funcall val :type)))
(dolist (pair entry)
(case (car pair)
(pcase (car pair)
(:title nil)
(:type nil)
(:key (org-bibtex-put org-bibtex-key-property (cdr pair)))
(:keywords (if org-bibtex-tags-are-keywords
(mapc
(lambda (kw)
(funcall
togtag
(replace-regexp-in-string
"[^[:alnum:]_@#%]" ""
(replace-regexp-in-string "[ \t]+" "_" kw))))
(split-string (cdr pair) ", *"))
(dolist (kw (split-string (cdr pair) ", *"))
(funcall
togtag
(replace-regexp-in-string
"[^[:alnum:]_@#%]" ""
(replace-regexp-in-string "[ \t]+" "_" kw))))
(org-bibtex-put (car pair) (cdr pair))))
(otherwise (org-bibtex-put (car pair) (cdr pair)))))
(_ (org-bibtex-put (car pair) (cdr pair)))))
(mapc togtag org-bibtex-tags)))
(defun org-bibtex-yank ()
"If kill ring holds a bibtex entry yank it as an Org-mode headline."
"If kill ring holds a bibtex entry yank it as an Org headline."
(interactive)
(let (entry)
(with-temp-buffer (yank 1) (setf entry (org-bibtex-read)))
@ -693,8 +708,8 @@ Return the number of saved entries."
(error "Yanked text does not appear to contain a BibTeX entry"))))
(defun org-bibtex-import-from-file (file)
"Read bibtex entries from FILE and insert as Org-mode headlines after point."
(interactive "ffile: ")
"Read bibtex entries from FILE and insert as Org headlines after point."
(interactive "fFile: ")
(dotimes (_ (org-bibtex-read-file file))
(save-excursion (org-bibtex-write))
(re-search-forward org-property-end-re)

1109
lisp/org/org-capture.el
View file

File diff suppressed because it is too large Load diff

1939
lisp/org/org-clock.el
View file

File diff suppressed because it is too large Load diff

2293
lisp/org/org-colview.el
View file

File diff suppressed because it is too large Load diff

711
lisp/org/org-compat.el
View file

@ -1,4 +1,4 @@
;;; org-compat.el --- Compatibility code for Org-mode
;;; org-compat.el --- Compatibility Code for Older Emacsen -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2017 Free Software Foundation, Inc.
@ -24,65 +24,287 @@
;;
;;; Commentary:
;; This file contains code needed for compatibility with XEmacs and older
;; This file contains code needed for compatibility with older
;; versions of GNU Emacs.
;;; Code:
(eval-when-compile
(require 'cl))
(require 'cl-lib)
(require 'org-macs)
;; The following constant is for backward compatibility. We do not use
;; it in org-mode, because the Byte compiler evaluates (featurep 'xemacs)
;; at compilation time and can therefore optimize code better.
(defconst org-xemacs-p (featurep 'xemacs))
(defconst org-format-transports-properties-p
(let ((x "a"))
(add-text-properties 0 1 '(test t) x)
(get-text-property 0 'test (format "%s" x)))
"Does format transport text properties?")
(declare-function org-at-table.el-p "org" (&optional table-type))
(declare-function org-element-at-point "org-element" ())
(declare-function org-element-type "org-element" (element))
(declare-function org-link-set-parameters "org" (type &rest rest))
(declare-function org-table-end (&optional table-type))
(declare-function table--at-cell-p "table" (position &optional object at-column))
(defvar org-table-any-border-regexp)
(defvar org-table-dataline-regexp)
(defvar org-table-tab-recognizes-table.el)
(defvar org-table1-hline-regexp)
;; As of Emacs 25.1, `outline-mode' functions are under the 'outline-'
;; prefix, `find-tag' is replaced with `xref-find-definition' and
;; `x-get-selection' with `gui-get-selection'.
(when (< emacs-major-version 25)
(defalias 'outline-hide-entry 'hide-entry)
(defalias 'outline-hide-sublevels 'hide-sublevels)
(defalias 'outline-hide-subtree 'hide-subtree)
(defalias 'outline-show-all 'show-all)
(defalias 'outline-show-branches 'show-branches)
(defalias 'outline-show-children 'show-children)
(defalias 'outline-show-entry 'show-entry)
(defalias 'outline-show-subtree 'show-subtree)
(defalias 'xref-find-definitions 'find-tag)
(defalias 'format-message 'format)
(defalias 'gui-get-selection 'x-get-selection))
;;; Obsolete aliases (remove them after the next major release).
;;;; XEmacs compatibility, now removed.
(define-obsolete-function-alias 'org-activate-mark 'activate-mark)
(define-obsolete-function-alias 'org-add-hook 'add-hook "Org 9.0")
(define-obsolete-function-alias 'org-bound-and-true-p 'bound-and-true-p "Org 9.0")
(define-obsolete-function-alias 'org-decompose-region 'decompose-region "Org 9.0")
(define-obsolete-function-alias 'org-defvaralias 'defvaralias "Org 9.0")
(define-obsolete-function-alias 'org-detach-overlay 'delete-overlay "Org 9.0")
(define-obsolete-function-alias 'org-file-equal-p 'file-equal-p "Org 9.0")
(define-obsolete-function-alias 'org-float-time 'float-time "Org 9.0")
(define-obsolete-function-alias 'org-indent-line-to 'indent-line-to "Org 9.0")
(define-obsolete-function-alias 'org-indent-to-column 'indent-to-column "Org 9.0")
(define-obsolete-function-alias 'org-looking-at-p 'looking-at-p "Org 9.0")
(define-obsolete-function-alias 'org-looking-back 'looking-back "Org 9.0")
(define-obsolete-function-alias 'org-match-string-no-properties 'match-string-no-properties "Org 9.0")
(define-obsolete-function-alias 'org-propertize 'propertize "Org 9.0")
(define-obsolete-function-alias 'org-select-frame-set-input-focus 'select-frame-set-input-focus "Org 9.0")
(defmacro org-re (s)
"Replace posix classes in regular expression S."
(declare (debug (form))
(obsolete "you can safely remove it." "Org 9.0"))
s)
;;;; Functions from cl-lib that Org used to have its own implementation of.
(define-obsolete-function-alias 'org-count 'cl-count "Org 9.0")
(define-obsolete-function-alias 'org-every 'cl-every "Org 9.0")
(define-obsolete-function-alias 'org-find-if 'cl-find-if "Org 9.0")
(define-obsolete-function-alias 'org-reduce 'cl-reduce "Org 9.0")
(define-obsolete-function-alias 'org-remove-if 'cl-remove-if "Org 9.0")
(define-obsolete-function-alias 'org-remove-if-not 'cl-remove-if-not "Org 9.0")
(define-obsolete-function-alias 'org-some 'cl-some "Org 9.0")
(define-obsolete-function-alias 'org-floor* 'cl-floor "Org 9.0")
(defun org-sublist (list start end)
"Return a section of LIST, from START to END.
Counting starts at 1."
(cl-subseq list (1- start) end))
(make-obsolete 'org-sublist
"use cl-subseq (note the 0-based counting)."
"Org 9.0")
;;;; Functions available since Emacs 24.3
(define-obsolete-function-alias 'org-buffer-narrowed-p 'buffer-narrowed-p "Org 9.0")
(define-obsolete-function-alias 'org-called-interactively-p 'called-interactively-p "Org 9.0")
(define-obsolete-function-alias 'org-char-to-string 'char-to-string "Org 9.0")
(define-obsolete-function-alias 'org-delete-directory 'delete-directory "Org 9.0")
(define-obsolete-function-alias 'org-format-seconds 'format-seconds "Org 9.0")
(define-obsolete-function-alias 'org-link-escape-browser 'url-encode-url "Org 9.0")
(define-obsolete-function-alias 'org-no-warnings 'with-no-warnings "Org 9.0")
(define-obsolete-function-alias 'org-number-sequence 'number-sequence "Org 9.0")
(define-obsolete-function-alias 'org-pop-to-buffer-same-window 'pop-to-buffer-same-window "Org 9.0")
(define-obsolete-function-alias 'org-string-match-p 'string-match-p "Org 9.0")
;;;; Functions and variables from previous releases now obsolete.
(define-obsolete-function-alias 'org-element-remove-indentation
'org-remove-indentation "Org 9.0")
(define-obsolete-variable-alias 'org-hierarchical-checkbox-statistics
'org-checkbox-hierarchical-statistics "Org 8.0")
(define-obsolete-variable-alias 'org-description-max-indent
'org-list-description-max-indent "Org 8.0")
(define-obsolete-variable-alias 'org-latex-create-formula-image-program
'org-preview-latex-default-process "Org 9.0")
(define-obsolete-variable-alias 'org-latex-preview-ltxpng-directory
'org-preview-latex-image-directory "Org 9.0")
(define-obsolete-function-alias 'org-table-p 'org-at-table-p "Org 9.0")
(define-obsolete-function-alias 'org-on-heading-p 'org-at-heading-p "Org 9.0")
(define-obsolete-function-alias 'org-at-regexp-p 'org-in-regexp "Org 8.3")
(define-obsolete-function-alias 'org-speed-command-default-hook
'org-speed-command-activate "Org 8.0")
(define-obsolete-function-alias 'org-babel-speed-command-hook
'org-babel-speed-command-activate "Org 8.0")
(define-obsolete-function-alias 'org-image-file-name-regexp
'image-file-name-regexp "Org 9.0")
(define-obsolete-function-alias 'org-get-legal-level
'org-get-valid-level "Org 7.8")
(define-obsolete-function-alias 'org-completing-read-no-i
'completing-read "Org 9.0")
(define-obsolete-function-alias 'org-icompleting-read
'completing-read "Org 9.0")
(define-obsolete-function-alias 'org-iread-file-name 'read-file-name "Org 9.0")
(define-obsolete-function-alias 'org-days-to-time
'org-time-stamp-to-now "Org 8.2")
(define-obsolete-variable-alias 'org-agenda-ignore-drawer-properties
'org-agenda-ignore-properties "Org 9.0")
(define-obsolete-function-alias 'org-preview-latex-fragment
'org-toggle-latex-fragment "Org 8.3")
(define-obsolete-function-alias 'org-display-inline-modification-hook
'org-display-inline-remove-overlay "Org 8.0")
(define-obsolete-function-alias 'org-export-get-genealogy
'org-element-lineage "Org 9.0")
(define-obsolete-variable-alias 'org-latex-with-hyperref
'org-latex-hyperref-template "Org 9.0")
(define-obsolete-variable-alias 'org-link-to-org-use-id
'org-id-link-to-org-use-id "Org 8.0")
(define-obsolete-variable-alias 'hfy-optimisations 'hfy-optimizations "Org 9.0")
(define-obsolete-variable-alias 'org-clock-modeline-total
'org-clock-mode-line-total "Org 8.0")
(define-obsolete-function-alias 'org-protocol-unhex-compound
'org-link-unescape-compound "Org 7.8")
(define-obsolete-function-alias 'org-protocol-unhex-string
'org-link-unescape "Org 7.8")
(define-obsolete-function-alias 'org-protocol-unhex-single-byte-sequence
'org-link-unescape-single-byte-sequence "Org 7.8")
(define-obsolete-variable-alias 'org-export-htmlized-org-css-url
'org-org-htmlized-css-url "Org 8.2")
(define-obsolete-variable-alias 'org-alphabetical-lists
'org-list-allow-alphabetical "Org 8.0")
(define-obsolete-function-alias 'org-list-parse-list 'org-list-to-lisp "Org 9.0")
(define-obsolete-variable-alias 'org-agenda-menu-two-column
'org-agenda-menu-two-columns "Org 8.0")
(define-obsolete-variable-alias 'org-finalize-agenda-hook
'org-agenda-finalize-hook "Org 8.0")
(make-obsolete-variable 'org-agenda-ndays 'org-agenda-span "Org 7.8")
(define-obsolete-function-alias 'org-agenda-post-command-hook
'org-agenda-update-agenda-type "Org 8.0")
(define-obsolete-function-alias 'org-agenda-todayp
'org-agenda-today-p "Org 9.0")
(define-obsolete-function-alias 'org-babel-examplize-region
'org-babel-examplify-region "Org 9.0")
(define-obsolete-function-alias 'org-babel-trim 'org-trim "Org 9.0")
(define-obsolete-variable-alias 'org-html-style-include-scripts
'org-html-head-include-scripts "Org 8.0")
(define-obsolete-variable-alias 'org-html-style-include-default
'org-html-head-include-default-style "Org 8.0")
(define-obsolete-variable-alias 'org-html-style 'org-html-head "24.4")
(define-obsolete-function-alias 'org-insert-columns-dblock
'org-columns-insert-dblock "Org 9.0")
(define-obsolete-function-alias 'org-activate-bracket-links
'org-activate-links "Org 9.0")
(define-obsolete-function-alias 'org-activate-plain-links 'ignore "Org 9.0")
(define-obsolete-function-alias 'org-activate-angle-links 'ignore "Org 9.0")
(defun org-in-fixed-width-region-p ()
"Non-nil if point in a fixed-width region."
(save-match-data
(eq 'fixed-width (org-element-type (org-element-at-point)))))
(make-obsolete 'org-in-fixed-width-region-p
"use `org-element' library"
"Org 9.0")
(defcustom org-read-date-minibuffer-setup-hook nil
"Hook to be used to set up keys for the date/time interface.
Add key definitions to `minibuffer-local-map', which will be a
temporary copy."
:group 'org-time
:type 'hook)
(make-obsolete-variable
'org-read-date-minibuffer-setup-hook
"set `org-read-date-minibuffer-local-map' instead." "Org 8.0")
(defun org-compatible-face (inherits specs)
"Make a compatible face specification.
If INHERITS is an existing face and if the Emacs version supports it,
just inherit the face. If INHERITS is set and the Emacs version does
not support it, copy the face specification from the inheritance face.
If INHERITS is not given and SPECS is, use SPECS to define the face.
XEmacs and Emacs 21 do not know about the `min-colors' attribute.
For them we convert a (min-colors 8) entry to a `tty' entry and move it
to the top of the list. The `min-colors' attribute will be removed from
any other entries, and any resulting duplicates will be removed entirely."
(when (and inherits (facep inherits) (not specs))
(setq specs (or specs
(get inherits 'saved-face)
(get inherits 'face-defface-spec))))
(cond
((and inherits (facep inherits)
(not (featurep 'xemacs))
(>= emacs-major-version 22)
;; do not inherit outline faces before Emacs 23
(or (>= emacs-major-version 23)
(not (string-match "\\`outline-[0-9]+"
(symbol-name inherits)))))
(list (list t :inherit inherits)))
((or (featurep 'xemacs) (< emacs-major-version 22))
;; These do not understand the `min-colors' attribute.
(let (r e a)
(while (setq e (pop specs))
(cond
((memq (car e) '(t default)) (push e r))
((setq a (member '(min-colors 8) (car e)))
(nconc r (list (cons (cons '(type tty) (delq (car a) (car e)))
(cdr e)))))
((setq a (assq 'min-colors (car e)))
(setq e (cons (delq a (car e)) (cdr e)))
(or (assoc (car e) r) (push e r)))
(t (or (assoc (car e) r) (push e r)))))
(nreverse r)))
(t specs)))
(put 'org-compatible-face 'lisp-indent-function 1)
If INHERITS is an existing face and if the Emacs version supports
it, just inherit the face. If INHERITS is not given and SPECS
is, use SPECS to define the face."
(declare (indent 1))
(if (facep inherits)
(list (list t :inherit inherits))
specs))
(make-obsolete 'org-compatible-face "you can remove it." "Org 9.0")
(defun org-add-link-type (type &optional follow export)
"Add a new TYPE link.
FOLLOW and EXPORT are two functions.
FOLLOW should take the link path as the single argument and do whatever
is necessary to follow the link, for example find a file or display
a mail message.
EXPORT should format the link path for export to one of the export formats.
It should be a function accepting three arguments:
path the path of the link, the text after the prefix (like \"http:\")
desc the description of the link, if any
format the export format, a symbol like `html' or `latex' or `ascii'.
The function may use the FORMAT information to return different values
depending on the format. The return value will be put literally into
the exported file. If the return value is nil, this means Org should
do what it normally does with links which do not have EXPORT defined.
Org mode has a built-in default for exporting links. If you are happy with
this default, there is no need to define an export function for the link
type. For a simple example of an export function, see `org-bbdb.el'.
If TYPE already exists, update it with the arguments.
See `org-link-parameters' for documentation on the other parameters."
(org-link-set-parameters type :follow follow :export export)
(message "Created %s link." type))
(make-obsolete 'org-add-link-type "use `org-link-set-parameters' instead." "Org 9.0")
(defun org-table-recognize-table.el ()
"If there is a table.el table nearby, recognize it and move into it."
(when (and org-table-tab-recognizes-table.el (org-at-table.el-p))
(beginning-of-line)
(unless (or (looking-at org-table-dataline-regexp)
(not (looking-at org-table1-hline-regexp)))
(forward-line)
(when (looking-at org-table-any-border-regexp)
(forward-line -2)))
(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"))))
;; Not used by Org core since commit 6d1e3082, Feb 2010.
(make-obsolete 'org-table-recognize-table.el
"please notify the org mailing list if you use this function."
"Org 9.0")
(define-obsolete-function-alias
'org-minutes-to-hh:mm-string 'org-minutes-to-clocksum-string "Org 8.0")
(defun org-remove-angle-brackets (s)
(org-unbracket-string "<" ">" s))
(make-obsolete 'org-remove-angle-brackets 'org-unbracket-string "Org 9.0")
(defun org-remove-double-quotes (s)
(org-unbracket-string "\"" "\"" s))
(make-obsolete 'org-remove-double-quotes 'org-unbracket-string "Org 9.0")
(define-obsolete-function-alias 'org-babel-number-p
'org-babel--string-to-number "Org 9.0")
;;;; Obsolete link types
(eval-after-load 'org
'(progn
(org-link-set-parameters "file+emacs") ;since Org 9.0
(org-link-set-parameters "file+sys"))) ;since Org 9.0
;;; Miscellaneous functions
(defun org-version-check (version feature level)
(let* ((v1 (mapcar 'string-to-number (split-string version "[.]")))
@ -108,110 +330,19 @@ any other entries, and any resulting duplicates will be removed entirely."
t))
t)))
;;;; Emacs/XEmacs compatibility
(eval-and-compile
(defun org-defvaralias (new-alias base-variable &optional docstring)
"Compatibility function for defvaralias.
Don't do the aliasing when `defvaralias' is not bound."
(declare (indent 1))
(when (fboundp 'defvaralias)
(defvaralias new-alias base-variable docstring)))
(when (and (not (boundp 'user-emacs-directory))
(boundp 'user-init-directory))
(org-defvaralias 'user-emacs-directory 'user-init-directory)))
(when (featurep 'xemacs)
(defadvice custom-handle-keyword
(around org-custom-handle-keyword
activate preactivate)
"Remove custom keywords not recognized to avoid producing an error."
(cond
((eq (ad-get-arg 1) :package-version))
(t ad-do-it)))
(defadvice define-obsolete-variable-alias
(around org-define-obsolete-variable-alias
(obsolete-name current-name &optional when docstring)
activate preactivate)
"Declare arguments defined in later versions of Emacs."
ad-do-it)
(defadvice define-obsolete-function-alias
(around org-define-obsolete-function-alias
(obsolete-name current-name &optional when docstring)
activate preactivate)
"Declare arguments defined in later versions of Emacs."
ad-do-it)
(defvar customize-package-emacs-version-alist nil)
(defvar temporary-file-directory (temp-directory)))
;; Keys
(defconst org-xemacs-key-equivalents
'(([mouse-1] . [button1])
([mouse-2] . [button2])
([mouse-3] . [button3])
([C-mouse-4] . [(control mouse-4)])
([C-mouse-5] . [(control mouse-5)]))
"Translation alist for a couple of keys.")
;; Overlay compatibility functions
(defun org-detach-overlay (ovl)
(if (featurep 'xemacs) (detach-extent ovl) (delete-overlay ovl)))
(defun org-overlay-display (ovl text &optional face evap)
"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))
(if evap (overlay-put ovl 'evaporate t))))
(defun org-overlay-before-string (ovl text &optional face evap)
"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 'begin-glyph gl))
(if face (org-add-props text nil 'face face))
(overlay-put ovl 'before-string text)
(if evap (overlay-put ovl 'evaporate t))))
(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 (overlays-at (or pos (point))))
ov found)
(while (setq ov (pop overlays))
(if (overlay-get ov prop)
(if delete (delete-overlay ov) (push ov found))))
found))
(defun org-get-x-clipboard (value)
"Get the value of the x or Windows clipboard, compatible with XEmacs, and GNU Emacs 21."
(cond ((eq window-system 'x)
(let ((x (org-get-x-clipboard-compat value)))
(if x (org-no-properties x))))
"Get the value of the X or Windows clipboard."
(cond ((and (eq window-system 'x)
(fboundp 'gui-get-selection)) ;Silence byte-compiler.
(org-no-properties
(ignore-errors
(or (gui-get-selection value 'UTF8_STRING)
(gui-get-selection value 'COMPOUND_TEXT)
(gui-get-selection value 'STRING)
(gui-get-selection value 'TEXT)))))
((and (eq window-system 'w32) (fboundp 'w32-get-clipboard-data))
(w32-get-clipboard-data))))
(defsubst org-decompose-region (beg end)
"Decompose from BEG to END."
(if (featurep 'xemacs)
(let ((modified-p (buffer-modified-p))
(buffer-read-only nil))
(remove-text-properties beg end '(composition nil))
(set-buffer-modified-p modified-p))
(decompose-region beg end)))
;; Miscellaneous functions
(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-add-props (string plist &rest props)
"Add text properties to entire string, from beginning to end.
PLIST may be a list of properties, PROPS are individual properties and values
@ -238,66 +369,29 @@ ignored in this case."
(shrink-window-if-larger-than-buffer window)))
(or window (selected-window)))
(defun org-number-sequence (from &optional to inc)
"Call `number-sequence' or emulate it."
(if (fboundp 'number-sequence)
(number-sequence from to inc)
(if (or (not to) (= from to))
(list from)
(or inc (setq inc 1))
(when (zerop inc) (error "The increment can not be zero"))
(let (seq (n 0) (next from))
(if (> inc 0)
(while (<= next to)
(setq seq (cons next seq)
n (1+ n)
next (+ from (* n inc))))
(while (>= next to)
(setq seq (cons next seq)
n (1+ n)
next (+ from (* n inc)))))
(nreverse seq)))))
;; `set-transient-map' is only in Emacs >= 24.4
(defalias 'org-set-transient-map
(if (fboundp 'set-transient-map)
'set-transient-map
'set-temporary-overlay-map))
;; Region compatibility
;;; Region compatibility
(defvar org-ignore-region nil
"Non-nil means 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))
(if (fboundp 'use-region-p)
(use-region-p)
(and transient-mark-mode mark-active))))) ; Emacs 22 and before
"Non-nil when the region active.
Unlike to `use-region-p', this function also checks
`org-ignore-region'."
(and (not org-ignore-region) (use-region-p)))
(defun org-cursor-to-region-beginning ()
(when (and (org-region-active-p)
(> (point) (region-beginning)))
(exchange-point-and-mark)))
;; Emacs 22 misses `activate-mark'
(if (fboundp 'activate-mark)
(defalias 'org-activate-mark 'activate-mark)
(defun org-activate-mark ()
(when (mark t)
(setq mark-active t)
(when (and (boundp 'transient-mark-mode)
(not transient-mark-mode))
(set (make-local-variable 'transient-mark-mode) 'lambda))
(when (boundp 'zmacs-regions)
(setq zmacs-regions t)))))
;; Invisibility compatibility
;;; Invisibility compatibility
(defun org-remove-from-invisibility-spec (arg)
"Remove elements from `buffer-invisibility-spec'."
@ -312,63 +406,14 @@ Works on both Emacs and XEmacs."
(if (consp buffer-invisibility-spec)
(member arg buffer-invisibility-spec)))
(defmacro org-xemacs-without-invisibility (&rest body)
"Turn off extents with invisibility while executing BODY."
`(let ((ext-inv (extent-list nil (point-at-bol) (point-at-eol)
'all-extents-closed-open 'invisible))
ext-inv-specs)
(dolist (ext ext-inv)
(when (extent-property ext 'invisible)
(add-to-list 'ext-inv-specs (list ext (extent-property
ext 'invisible)))
(set-extent-property ext 'invisible nil)))
,@body
(dolist (ext-inv-spec ext-inv-specs)
(set-extent-property (car ext-inv-spec) 'invisible
(cadr ext-inv-spec)))))
(def-edebug-spec org-xemacs-without-invisibility (body))
(defun org-indent-to-column (column &optional minimum buffer)
"Work around a bug with extents with invisibility in XEmacs."
(if (featurep 'xemacs)
(org-xemacs-without-invisibility (indent-to-column column minimum buffer))
(indent-to-column column minimum)))
(defun org-indent-line-to (column)
"Work around a bug with extents with invisibility in XEmacs."
(if (featurep 'xemacs)
(org-xemacs-without-invisibility (indent-line-to column))
(indent-line-to column)))
(defun org-move-to-column (column &optional force buffer)
(defun org-move-to-column (column &optional force _buffer)
"Move to column COLUMN.
Pass COLUMN and FORCE to `move-to-column'.
Pass BUFFER to the XEmacs version of `move-to-column'."
Pass COLUMN and FORCE to `move-to-column'."
(let ((buffer-invisibility-spec
(remove '(org-filtered) buffer-invisibility-spec)))
(if (featurep 'xemacs)
(org-xemacs-without-invisibility
(move-to-column column force buffer))
(move-to-column column force))))
(defun org-get-x-clipboard-compat (value)
"Get the clipboard value on XEmacs or Emacs 21."
(cond ((featurep 'xemacs)
(org-no-warnings (get-selection-no-error value)))
((fboundp 'x-get-selection)
(condition-case nil
(or (x-get-selection value 'UTF8_STRING)
(x-get-selection value 'COMPOUND_TEXT)
(x-get-selection value 'STRING)
(x-get-selection value 'TEXT))
(error nil)))))
(defun org-propertize (string &rest properties)
(if (featurep 'xemacs)
(progn
(add-text-properties 0 (length string) properties string)
string)
(apply 'propertize string properties)))
(if (listp buffer-invisibility-spec)
(remove '(org-filtered) buffer-invisibility-spec)
buffer-invisibility-spec)))
(move-to-column column force)))
(defmacro org-find-library-dir (library)
`(file-name-directory (or (locate-library ,library) "")))
@ -387,37 +432,20 @@ Pass BUFFER to the XEmacs version of `move-to-column'."
string)
(apply 'kill-new string args))
(defun org-select-frame-set-input-focus (frame)
"Select FRAME, raise it, and set input focus, if possible."
(cond ((featurep 'xemacs)
(if (fboundp 'select-frame-set-input-focus)
(select-frame-set-input-focus frame)
(raise-frame frame)
(select-frame frame)
(focus-frame frame)))
;; `select-frame-set-input-focus' defined in Emacs 21 will not
;; set the input focus.
((>= emacs-major-version 22)
(select-frame-set-input-focus frame))
(t
(raise-frame frame)
(select-frame frame)
(cond ((memq window-system '(x ns mac))
(x-focus-frame frame))
((eq window-system 'w32)
(w32-focus-frame frame)))
(when focus-follows-mouse
(set-mouse-position frame (1- (frame-width frame)) 0)))))
;; `font-lock-ensure' is only available from 24.4.50 on
(defalias 'org-font-lock-ensure
(if (fboundp 'font-lock-ensure)
#'font-lock-ensure
(lambda (&optional _beg _end)
(with-no-warnings (font-lock-fontify-buffer)))))
(define-obsolete-function-alias 'org-float-time 'float-time "26.1")
;; `user-error' is only available from 24.3 on
(unless (fboundp 'user-error)
(defalias 'user-error 'error))
;; ‘format-message’ is available only from 25 on
(unless (fboundp 'format-message)
(defalias 'format-message 'format))
;; `file-local-name' was added in Emacs 26.1.
(defalias 'org-babel-local-file-name
(if (fboundp 'file-local-name)
'file-local-name
(lambda (file)
"Return the local name component of FILE."
(or (file-remote-p file 'localname) file))))
(defmacro org-no-popups (&rest body)
"Suppress popup windows.
@ -429,93 +457,6 @@ effect, which variables to use depends on the Emacs version."
`(let (pop-up-frames special-display-buffer-names special-display-regexps special-display-function)
,@body)))
(if (fboundp 'string-match-p)
(defalias 'org-string-match-p 'string-match-p)
(defun org-string-match-p (regexp string &optional start)
(save-match-data
(funcall 'string-match regexp string start))))
(if (fboundp 'looking-at-p)
(defalias 'org-looking-at-p 'looking-at-p)
(defun org-looking-at-p (&rest args)
(save-match-data
(apply 'looking-at args))))
;; XEmacs does not have `looking-back'.
(if (fboundp 'looking-back)
(defalias 'org-looking-back 'looking-back)
(defun org-looking-back (regexp &optional limit greedy)
"Return non-nil if text before point matches regular expression REGEXP.
Like `looking-at' except matches before point, and is slower.
LIMIT if non-nil speeds up the search by specifying a minimum
starting position, to avoid checking matches that would start
before LIMIT.
If GREEDY is non-nil, extend the match backwards as far as
possible, stopping when a single additional previous character
cannot be part of a match for REGEXP. When the match is
extended, its starting position is allowed to occur before
LIMIT."
(let ((start (point))
(pos
(save-excursion
(and (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t)
(point)))))
(if (and greedy pos)
(save-restriction
(narrow-to-region (point-min) start)
(while (and (> pos (point-min))
(save-excursion
(goto-char pos)
(backward-char 1)
(looking-at (concat "\\(?:" regexp "\\)\\'"))))
(setq pos (1- pos)))
(save-excursion
(goto-char pos)
(looking-at (concat "\\(?:" regexp "\\)\\'")))))
(not (null pos)))))
(defalias 'org-font-lock-ensure
(if (fboundp 'font-lock-ensure)
#'font-lock-ensure
(lambda (&optional _beg _end) (font-lock-fontify-buffer))))
(defun org-floor* (x &optional y)
"Return a list of the floor of X and the fractional part of X.
With two arguments, return floor and remainder of their quotient."
(let ((q (floor x y)))
(list q (- x (if y (* y q) q)))))
;; `pop-to-buffer-same-window' has been introduced in Emacs 24.1.
(defun org-pop-to-buffer-same-window
(&optional buffer-or-name norecord label)
"Pop to buffer specified by BUFFER-OR-NAME in the selected window."
(if (fboundp 'pop-to-buffer-same-window)
(funcall
'pop-to-buffer-same-window buffer-or-name norecord)
(funcall 'switch-to-buffer buffer-or-name norecord)))
;; RECURSIVE has been introduced with Emacs 23.2.
;; This is copying and adapted from `tramp-compat-delete-directory'
(defun org-delete-directory (directory &optional recursive)
"Compatibility function for `delete-directory'."
(if (null recursive)
(delete-directory directory)
(condition-case nil
(funcall 'delete-directory directory recursive)
;; This Emacs version does not support the RECURSIVE flag. We
;; use the implementation from Emacs 23.2.
(wrong-number-of-arguments
(setq directory (directory-file-name (expand-file-name directory)))
(if (not (file-symlink-p directory))
(mapc (lambda (file)
(if (eq t (car (file-attributes file)))
(org-delete-directory file recursive)
(delete-file file)))
(directory-files
directory 'full "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")))
(delete-directory directory)))))
;;;###autoload
(defmacro org-check-version ()
"Try very hard to provide sensible version strings."
@ -534,29 +475,33 @@ With two arguments, return floor and remainder of their quotient."
(defun org-release () "N/A")
(defun org-git-version () "N/A !!check installation!!"))))))
(defun org-file-equal-p (f1 f2)
"Return t if files F1 and F2 are the same.
Implements `file-equal-p' for older emacsen and XEmacs."
(if (fboundp 'file-equal-p)
(file-equal-p f1 f2)
(let (f1-attr f2-attr)
(and (setq f1-attr (file-attributes (file-truename f1)))
(setq f2-attr (file-attributes (file-truename f2)))
(equal f1-attr f2-attr)))))
;; `buffer-narrowed-p' is available for Emacs >=24.3
(defun org-buffer-narrowed-p ()
"Compatibility function for `buffer-narrowed-p'."
(if (fboundp 'buffer-narrowed-p)
(buffer-narrowed-p)
(/= (- (point-max) (point-min)) (buffer-size))))
(defmacro org-with-silent-modifications (&rest body)
(if (fboundp 'with-silent-modifications)
`(with-silent-modifications ,@body)
`(org-unmodified ,@body)))
(def-edebug-spec org-with-silent-modifications (body))
;; Functions for Emacs < 24.4 compatibility
(defun org-define-error (name message)
"Define NAME as a new error signal.
MESSAGE is a string that will be output to the echo area if such
an error is signaled without being caught by a `condition-case'.
Implements `define-error' for older emacsen."
(if (fboundp 'define-error) (define-error name message)
(put name 'error-conditions
(copy-sequence (cons name (get 'error 'error-conditions))))))
(unless (fboundp 'string-suffix-p)
;; From Emacs subr.el.
(defun string-suffix-p (suffix string &optional ignore-case)
"Return non-nil if SUFFIX is a suffix of STRING.
If IGNORE-CASE is non-nil, the comparison is done without paying
attention to case differences."
(let ((start-pos (- (length string) (length suffix))))
(and (>= start-pos 0)
(eq t (compare-strings suffix nil nil
string start-pos nil ignore-case))))))
(provide 'org-compat)
;;; org-compat.el ends here

141
lisp/org/org-crypt.el
View file

@ -1,5 +1,4 @@
;;; org-crypt.el --- Public key encryption for org-mode entries
;;; org-crypt.el --- Public Key Encryption for Org Entries -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2017 Free Software Foundation, Inc.
;; Emacs Lisp Archive Entry
@ -7,7 +6,7 @@
;; Keywords: org-mode
;; Author: John Wiegley <johnw@gnu.org>
;; Maintainer: Peter Jones <pjones@pmade.com>
;; Description: Adds public key encryption to org-mode buffers
;; Description: Adds public key encryption to Org buffers
;; URL: http://www.newartisans.com/software/emacs.html
;; Compatibility: Emacs22
@ -104,10 +103,10 @@ t : Disable auto-save-mode for the current buffer
nil : Leave auto-save-mode enabled.
This may cause data to be written to disk unencrypted!
'ask : Ask user whether or not to disable auto-save-mode
`ask' : Ask user whether or not to disable auto-save-mode
for the current buffer.
'encrypt : Leave auto-save-mode enabled for the current buffer,
`encrypt': Leave auto-save-mode enabled for the current buffer,
but automatically re-encrypt all decrypted entries
*before* auto-saving.
NOTE: This only works for entries which have a tag
@ -142,7 +141,7 @@ See `org-crypt-disable-auto-save'."
(message "org-decrypt: Decrypting entry with auto-save-mode enabled. This may cause leakage."))
((eq org-crypt-disable-auto-save 'encrypt)
(message "org-decrypt: Enabling re-encryption on auto-save.")
(org-add-hook 'auto-save-hook
(add-hook 'auto-save-hook
(lambda ()
(message "org-crypt: Re-encrypting all decrypted entries due to auto-save.")
(org-encrypt-entries))
@ -164,96 +163,96 @@ See `org-crypt-disable-auto-save'."
(if (and (string= crypt-key (get-text-property 0 'org-crypt-key str))
(string= (sha1 str) (get-text-property 0 'org-crypt-checksum str)))
(get-text-property 0 'org-crypt-text str)
(set (make-local-variable 'epg-context) (epg-make-context nil t t))
(setq-local epg-context (epg-make-context nil t t))
(epg-encrypt-string epg-context str (epg-list-keys epg-context crypt-key))))
(defun org-encrypt-entry ()
"Encrypt the content of the current headline."
(interactive)
(require 'epg)
(save-excursion
(org-back-to-heading t)
(set (make-local-variable 'epg-context) (epg-make-context nil t t))
(let ((start-heading (point)))
(forward-line)
(when (not (looking-at "-----BEGIN PGP MESSAGE-----"))
(let ((folded (outline-invisible-p))
(crypt-key (org-crypt-key-for-heading))
(beg (point))
end encrypted-text)
(goto-char start-heading)
(org-end-of-subtree t t)
(org-back-over-empty-lines)
(setq end (point)
encrypted-text
(org-encrypt-string (buffer-substring beg end) crypt-key))
(delete-region beg end)
(insert encrypted-text)
(when folded
(goto-char start-heading)
(hide-subtree))
nil)))))
(org-with-wide-buffer
(org-back-to-heading t)
(setq-local epg-context (epg-make-context nil t t))
(let ((start-heading (point)))
(org-end-of-meta-data)
(unless (looking-at-p "-----BEGIN PGP MESSAGE-----")
(let ((folded (org-invisible-p))
(crypt-key (org-crypt-key-for-heading))
(beg (point)))
(goto-char start-heading)
(org-end-of-subtree t t)
(org-back-over-empty-lines)
(let ((contents (delete-and-extract-region beg (point))))
(condition-case err
(insert (org-encrypt-string contents crypt-key))
;; If encryption failed, make sure to insert back entry
;; contents in the buffer.
(error (insert contents) (error (nth 1 err)))))
(when folded
(goto-char start-heading)
(outline-hide-subtree))
nil)))))
(defun org-decrypt-entry ()
"Decrypt the content of the current headline."
(interactive)
(require 'epg)
(unless (org-before-first-heading-p)
(save-excursion
(org-back-to-heading t)
(let ((heading-point (point))
(heading-was-invisible-p
(save-excursion
(outline-end-of-heading)
(outline-invisible-p))))
(forward-line)
(when (looking-at "-----BEGIN PGP MESSAGE-----")
(org-crypt-check-auto-save)
(set (make-local-variable 'epg-context) (epg-make-context nil t t))
(let* ((end (save-excursion
(search-forward "-----END PGP MESSAGE-----")
(forward-line)
(point)))
(encrypted-text (buffer-substring-no-properties (point) end))
(decrypted-text
(decode-coding-string
(epg-decrypt-string
epg-context
encrypted-text)
'utf-8)))
;; Delete region starting just before point, because the
;; outline property starts at the \n of the heading.
(delete-region (1- (point)) end)
;; Store a checksum of the decrypted and the encrypted
;; text value. This allow reusing the same encrypted text
;; if the text does not change, and therefore avoid a
;; re-encryption process.
(insert "\n" (propertize decrypted-text
'org-crypt-checksum (sha1 decrypted-text)
'org-crypt-key (org-crypt-key-for-heading)
'org-crypt-text encrypted-text))
(when heading-was-invisible-p
(goto-char heading-point)
(org-flag-subtree t))
nil))))))
(org-with-wide-buffer
(org-back-to-heading t)
(let ((heading-point (point))
(heading-was-invisible-p
(save-excursion
(outline-end-of-heading)
(org-invisible-p))))
(org-end-of-meta-data)
(when (looking-at "-----BEGIN PGP MESSAGE-----")
(org-crypt-check-auto-save)
(setq-local epg-context (epg-make-context nil t t))
(let* ((end (save-excursion
(search-forward "-----END PGP MESSAGE-----")
(forward-line)
(point)))
(encrypted-text (buffer-substring-no-properties (point) end))
(decrypted-text
(decode-coding-string
(epg-decrypt-string
epg-context
encrypted-text)
'utf-8)))
;; Delete region starting just before point, because the
;; outline property starts at the \n of the heading.
(delete-region (1- (point)) end)
;; Store a checksum of the decrypted and the encrypted
;; text value. This allows reusing the same encrypted text
;; if the text does not change, and therefore avoid a
;; re-encryption process.
(insert "\n" (propertize decrypted-text
'org-crypt-checksum (sha1 decrypted-text)
'org-crypt-key (org-crypt-key-for-heading)
'org-crypt-text encrypted-text))
(when heading-was-invisible-p
(goto-char heading-point)
(org-flag-subtree t))
nil))))))
(defun org-encrypt-entries ()
"Encrypt all top-level entries in the current buffer."
(interactive)
(let (todo-only)
(let ((org--matcher-tags-todo-only nil))
(org-scan-tags
'org-encrypt-entry
(cdr (org-make-tags-matcher org-crypt-tag-matcher))
todo-only)))
org--matcher-tags-todo-only)))
(defun org-decrypt-entries ()
"Decrypt all entries in the current buffer."
(interactive)
(let (todo-only)
(let ((org--matcher-tags-todo-only nil))
(org-scan-tags
'org-decrypt-entry
(cdr (org-make-tags-matcher org-crypt-tag-matcher))
todo-only)))
org--matcher-tags-todo-only)))
(defun org-at-encrypted-entry-p ()
"Is the current entry encrypted?"
@ -267,7 +266,7 @@ See `org-crypt-disable-auto-save'."
"Add a hook to automatically encrypt entries before a file is saved to disk."
(add-hook
'org-mode-hook
(lambda () (org-add-hook 'before-save-hook 'org-encrypt-entries nil t))))
(lambda () (add-hook 'before-save-hook 'org-encrypt-entries nil t))))
(add-hook 'org-reveal-start-hook 'org-decrypt-entry)

101
lisp/org/org-ctags.el
View file

@ -1,4 +1,4 @@
;;; org-ctags.el - Integrate Emacs "tags" facility with org mode.
;;; org-ctags.el - Integrate Emacs "tags" Facility with Org -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2007-2017 Free Software Foundation, Inc.
@ -26,20 +26,21 @@
;; Synopsis
;; ========
;;
;; Allows org-mode to make use of the Emacs `etags' system. Defines tag
;; destinations in org-mode files as any text between <<double angled
;; brackets>>. This allows the tags-generation program `exuberant ctags' to
;; parse these files and create tag tables that record where these
;; destinations are found. Plain [[links]] in org mode files which do not have
;; <<matching destinations>> within the same file will then be interpreted as
;; links to these 'tagged' destinations, allowing seamless navigation between
;; multiple org-mode files. Topics can be created in any org mode file and
;; will always be found by plain links from other files. Other file types
;; recognized by ctags (source code files, latex files, etc) will also be
;; available as destinations for plain links, and similarly, org-mode links
;; will be available as tags from source files. Finally, the function
;; `org-ctags-find-tag-interactive' lets you choose any known tag, using
;; autocompletion, and quickly jump to it.
;; Allows Org mode to make use of the Emacs `etags' system. Defines
;; tag destinations in Org files as any text between <<double angled
;; brackets>>. This allows the tags-generation program `exuberant
;; ctags' to parse these files and create tag tables that record where
;; these destinations are found. Plain [[links]] in org mode files
;; which do not have <<matching destinations>> within the same file
;; will then be interpreted as links to these 'tagged' destinations,
;; allowing seamless navigation between multiple Org files. Topics
;; can be created in any org mode file and will always be found by
;; plain links from other files. Other file types recognized by ctags
;; (source code files, latex files, etc) will also be available as
;; destinations for plain links, and similarly, Org links will be
;; available as tags from source files. Finally, the function
;; `org-ctags-find-tag-interactive' lets you choose any known tag,
;; using autocompletion, and quickly jump to it.
;;
;; Installation
;; ============
@ -110,8 +111,9 @@
;; Keeping the TAGS file up to date
;; ================================
;;
;; Tags mode has no way of knowing that you have created new tags by typing in
;; your org-mode buffer. New tags make it into the TAGS file in 3 ways:
;; Tags mode has no way of knowing that you have created new tags by
;; typing in your Org buffer. New tags make it into the TAGS file in
;; 3 ways:
;;
;; 1. You re-run (org-ctags-create-tags "directory") to rebuild the file.
;; 2. You put the function `org-ctags-ask-rebuild-tags-file-then-find-tag' in
@ -135,12 +137,8 @@
;;; Code:
(eval-when-compile (require 'cl))
(require 'org)
(declare-function org-pop-to-buffer-same-window "org-compat" (&optional buffer-or-name norecord label))
(defgroup org-ctags nil
"Options concerning use of ctags within org mode."
:tag "Org-Ctags"
@ -151,7 +149,7 @@
(defvar org-ctags-tag-regexp "/<<([^>]+)>>/\\1/d,definition/"
"Regexp expression used by ctags external program.
The regexp matches tag destinations in org-mode files.
The regexp matches tag destinations in Org files.
Format is: /REGEXP/TAGNAME/FLAGS,TAGTYPE/
See the ctags documentation for more information.")
@ -210,8 +208,8 @@ The following patterns are replaced in the string:
(defadvice visit-tags-table (after org-ctags-load-tag-list activate compile)
(when (and org-ctags-enabled-p tags-file-name)
(set (make-local-variable 'org-ctags-tag-list)
(org-ctags-all-tags-in-current-tags-table))))
(setq-local org-ctags-tag-list
(org-ctags-all-tags-in-current-tags-table))))
(defun org-ctags-enable ()
@ -273,11 +271,6 @@ Return the list."
(replace-regexp-in-string (regexp-quote search) replace string t t))
(defun y-or-n-minibuffer (prompt)
(let ((use-dialog-box nil))
(y-or-n-p prompt)))
;;; Internal functions =======================================================
@ -285,29 +278,28 @@ Return the list."
"Visit or create a file called `NAME.org', and insert a new topic.
The new topic will be titled NAME (or TITLE if supplied)."
(interactive "sFile name: ")
(let ((filename (substitute-in-file-name (expand-file-name name))))
(condition-case v
(progn
(org-open-file name t)
(message "Opened file OK")
(goto-char (point-max))
(insert (org-ctags-string-search-and-replace
"%t" (capitalize (or title name))
org-ctags-new-topic-template))
(message "Inserted new file text OK")
(org-mode-restart))
(error (error "Error %S in org-ctags-open-file" v)))))
(condition-case v
(progn
(org-open-file name t)
(message "Opened file OK")
(goto-char (point-max))
(insert (org-ctags-string-search-and-replace
"%t" (capitalize (or title name))
org-ctags-new-topic-template))
(message "Inserted new file text OK")
(org-mode-restart))
(error (error "Error %S in org-ctags-open-file" v))))
;;;; Misc interoperability with etags system =================================
(defadvice find-tag (before org-ctags-set-org-mark-before-finding-tag
activate compile)
(defadvice xref-find-definitions
(before org-ctags-set-org-mark-before-finding-tag activate compile)
"Before trying to find a tag, save our current position on org mark ring."
(save-excursion
(if (and (derived-mode-p 'org-mode) org-ctags-enabled-p)
(org-mark-ring-push))))
(when (and (derived-mode-p 'org-mode) org-ctags-enabled-p)
(org-mark-ring-push))))
@ -359,7 +351,7 @@ visit the file and location where the tag is found."
(old-pnt (point-marker))
(old-mark (copy-marker (mark-marker))))
(condition-case nil
(progn (find-tag name)
(progn (xref-find-definitions name)
t)
(error
;; only restore old location if find-tag raises error
@ -386,7 +378,7 @@ the new file."
(cond
((get-buffer (concat name ".org"))
;; Buffer is already open
(org-pop-to-buffer-same-window (get-buffer (concat name ".org"))))
(pop-to-buffer-same-window (get-buffer (concat name ".org"))))
((file-exists-p filename)
;; File exists but is not open --> open it
(message "Opening existing org file `%S'..."
@ -421,7 +413,6 @@ the heading a destination for the tag `NAME'."
(insert (org-ctags-string-search-and-replace
"%t" (capitalize name) org-ctags-new-topic-template))
(backward-char 4)
(org-update-radio-target-regexp)
(end-of-line)
(forward-line 2)
(when narrowp
@ -464,10 +455,10 @@ Wrapper for org-ctags-rebuild-tags-file-then-find-tag."
nil))
(defun org-ctags-fail-silently (name)
(defun org-ctags-fail-silently (_name)
"This function is intended to be used in ORG-OPEN-LINK-FUNCTIONS.
Put as the last function in the list if you want to prevent org's default
behavior of free text search."
Put as the last function in the list if you want to prevent Org's
default behavior of free text search."
t)
@ -484,7 +475,7 @@ end up in one file, called TAGS, located in the directory. This
function may take several seconds to finish if the directory or
its subdirectories contain large numbers of taggable files."
(interactive)
(assert (buffer-file-name))
(cl-assert (buffer-file-name))
(let ((dir-name (or directory-name
(file-name-directory (buffer-file-name))))
(exitcode nil))
@ -499,8 +490,8 @@ its subdirectories contain large numbers of taggable files."
(expand-file-name (concat dir-name "/*")))))
(cond
((eql 0 exitcode)
(set (make-local-variable 'org-ctags-tag-list)
(org-ctags-all-tags-in-current-tags-table)))
(setq-local org-ctags-tag-list
(org-ctags-all-tags-in-current-tags-table)))
(t
;; This seems to behave differently on Linux, so just ignore
;; error codes for now
@ -528,7 +519,7 @@ a new topic."
((member tag org-ctags-tag-list)
;; Existing tag
(push tag org-ctags-find-tag-history)
(find-tag tag))
(xref-find-definitions tag))
(t
;; New tag
(run-hook-with-args-until-success

274
lisp/org/org-datetree.el
View file

@ -1,4 +1,4 @@
;;; org-datetree.el --- Create date entries in a tree
;;; org-datetree.el --- Create date entries in a tree -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -34,12 +34,14 @@
(defvar org-datetree-base-level 1
"The level at which years should be placed in the date tree.
This is normally one, but if the buffer has an entry with a DATE_TREE
property (any value), the date tree will become a subtree under that entry,
so the base level will be properly adjusted.")
This is normally one, but if the buffer has an entry with a
DATE_TREE (or WEEK_TREE for ISO week entries) property (any
value), the date tree will become a subtree under that entry, so
the base level will be properly adjusted.")
(defcustom org-datetree-add-timestamp nil
"When non-nil, add a time stamp when create a datetree entry."
"When non-nil, add a time stamp matching date of entry.
Added time stamp is active unless value is `inactive'."
:group 'org-capture
:version "24.3"
:type '(choice
@ -48,115 +50,129 @@ so the base level will be properly adjusted.")
(const :tag "Add an active time stamp" active)))
;;;###autoload
(defun org-datetree-find-date-create (date &optional keep-restriction)
"Find or create an entry for DATE.
(defun org-datetree-find-date-create (d &optional keep-restriction)
"Find or create an entry for date D.
If KEEP-RESTRICTION is non-nil, do not widen the buffer.
When it is nil, the buffer will be widened to make sure an existing date
tree can be found."
(let ((year (nth 2 date))
(month (car date))
(day (nth 1 date)))
(org-set-local 'org-datetree-base-level 1)
(or keep-restriction (widen))
(setq-local org-datetree-base-level 1)
(or keep-restriction (widen))
(save-restriction
(let ((prop (org-find-property "DATE_TREE")))
(when prop
(goto-char prop)
(setq-local org-datetree-base-level
(org-get-valid-level (org-current-level) 1))
(org-narrow-to-subtree)))
(goto-char (point-min))
(save-restriction
(when (re-search-forward "^[ \t]*:DATE_TREE:[ \t]+\\S-" nil t)
(org-back-to-heading t)
(org-set-local 'org-datetree-base-level
(org-get-valid-level (funcall outline-level) 1))
(org-narrow-to-subtree))
(goto-char (point-min))
(org-datetree-find-year-create year)
(org-datetree-find-month-create year month)
(org-datetree-find-day-create year month day)
(goto-char (prog1 (point) (widen))))))
(let ((year (calendar-extract-year d))
(month (calendar-extract-month d))
(day (calendar-extract-day d)))
(org-datetree--find-create
"^\\*+[ \t]+\\([12][0-9]\\{3\\}\\)\\(\\s-*?\
\\([ \t]:[[:alnum:]:_@#%%]+:\\)?\\s-*$\\)"
year)
(org-datetree--find-create
"^\\*+[ \t]+%d-\\([01][0-9]\\) \\w+$"
year month)
(org-datetree--find-create
"^\\*+[ \t]+%d-%02d-\\([0123][0-9]\\) \\w+$"
year month day))))
(defun org-datetree-find-year-create (year)
"Find the YEAR datetree or create it."
(let ((re "^\\*+[ \t]+\\([12][0-9]\\{3\\}\\)\\(\\s-*?\\([ \t]:[[:alnum:]:_@#%]+:\\)?\\s-*$\\)")
;;;###autoload
(defun org-datetree-find-iso-week-create (d &optional keep-restriction)
"Find or create an ISO week entry for date D.
Compared to `org-datetree-find-date-create' this function creates
entries ordered by week instead of months.
If KEEP-RESTRICTION is non-nil, do not widen the buffer. When it
is nil, the buffer will be widened to make sure an existing date
tree can be found."
(setq-local org-datetree-base-level 1)
(or keep-restriction (widen))
(save-restriction
(let ((prop (org-find-property "WEEK_TREE")))
(when prop
(goto-char prop)
(setq-local org-datetree-base-level
(org-get-valid-level (org-current-level) 1))
(org-narrow-to-subtree)))
(goto-char (point-min))
(require 'cal-iso)
(let* ((year (calendar-extract-year d))
(month (calendar-extract-month d))
(day (calendar-extract-day d))
(time (encode-time 0 0 0 day month year))
(iso-date (calendar-iso-from-absolute
(calendar-absolute-from-gregorian d)))
(weekyear (nth 2 iso-date))
(week (nth 0 iso-date)))
;; ISO 8601 week format is %G-W%V(-%u)
(org-datetree--find-create
"^\\*+[ \t]+\\([12][0-9]\\{3\\}\\)\\(\\s-*?\
\\([ \t]:[[:alnum:]:_@#%%]+:\\)?\\s-*$\\)"
weekyear nil nil
(format-time-string "%G" time))
(org-datetree--find-create
"^\\*+[ \t]+%d-W\\([0-5][0-9]\\)$"
weekyear week nil
(format-time-string "%G-W%V" time))
;; For the actual day we use the regular date instead of ISO week.
(org-datetree--find-create
"^\\*+[ \t]+%d-%02d-\\([0123][0-9]\\) \\w+$"
year month day))))
(defun org-datetree--find-create (regex year &optional month day insert)
"Find the datetree matched by REGEX for YEAR, MONTH, or DAY.
REGEX is passed to `format' with YEAR, MONTH, and DAY as
arguments. Match group 1 is compared against the specified date
component. If INSERT is non-nil and there is no match then it is
inserted into the buffer."
(when (or month day)
(org-narrow-to-subtree))
(let ((re (format regex year month day))
match)
(goto-char (point-min))
(while (and (setq match (re-search-forward re nil t))
(goto-char (match-beginning 1))
(< (string-to-number (match-string 1)) year)))
(< (string-to-number (match-string 1)) (or day month year))))
(cond
((not match)
(goto-char (point-max))
(or (bolp) (newline))
(org-datetree-insert-line year))
((= (string-to-number (match-string 1)) year)
(goto-char (point-at-bol)))
(unless (bolp) (insert "\n"))
(org-datetree-insert-line year month day insert))
((= (string-to-number (match-string 1)) (or day month year))
(beginning-of-line))
(t
(beginning-of-line 1)
(org-datetree-insert-line year)))))
(beginning-of-line)
(org-datetree-insert-line year month day insert)))))
(defun org-datetree-find-month-create (year month)
"Find the datetree for YEAR and MONTH or create it."
(org-narrow-to-subtree)
(let ((re (format "^\\*+[ \t]+%d-\\([01][0-9]\\) \\w+$" year))
match)
(goto-char (point-min))
(while (and (setq match (re-search-forward re nil t))
(goto-char (match-beginning 1))
(< (string-to-number (match-string 1)) month)))
(cond
((not match)
(goto-char (point-max))
(or (bolp) (newline))
(org-datetree-insert-line year month))
((= (string-to-number (match-string 1)) month)
(goto-char (point-at-bol)))
(t
(beginning-of-line 1)
(org-datetree-insert-line year month)))))
(defun org-datetree-find-day-create (year month day)
"Find the datetree for YEAR, MONTH and DAY or create it."
(org-narrow-to-subtree)
(let ((re (format "^\\*+[ \t]+%d-%02d-\\([0123][0-9]\\) \\w+$" year month))
match)
(goto-char (point-min))
(while (and (setq match (re-search-forward re nil t))
(goto-char (match-beginning 1))
(< (string-to-number (match-string 1)) day)))
(cond
((not match)
(goto-char (point-max))
(or (bolp) (newline))
(org-datetree-insert-line year month day))
((= (string-to-number (match-string 1)) day)
(goto-char (point-at-bol)))
(t
(beginning-of-line 1)
(org-datetree-insert-line year month day)))))
(defun org-datetree-insert-line (year &optional month day)
(let ((pos (point)) ts-type)
(skip-chars-backward " \t\n")
(delete-region (point) pos)
(insert "\n" (make-string org-datetree-base-level ?*) " \n")
(backward-char 1)
(if month (org-do-demote))
(if day (org-do-demote))
(defun org-datetree-insert-line (year &optional month day text)
(delete-region (save-excursion (skip-chars-backward " \t\n") (point)) (point))
(insert "\n" (make-string org-datetree-base-level ?*) " \n")
(backward-char)
(when month (org-do-demote))
(when day (org-do-demote))
(if text
(insert text)
(insert (format "%d" year))
(when month
(insert (format "-%02d" month))
(if day
(insert (format "-%02d %s"
day (format-time-string
"%A" (encode-time 0 0 0 day month year))))
(insert (format " %s"
(format-time-string
"%B" (encode-time 0 0 0 1 month year))))))
(when (and day (setq ts-type org-datetree-add-timestamp))
(insert
(if day
(format-time-string "-%m-%d %A" (encode-time 0 0 0 day month year))
(format-time-string "-%m %B" (encode-time 0 0 0 1 month year))))))
(when (and day org-datetree-add-timestamp)
(save-excursion
(insert "\n")
(org-indent-line)
(org-insert-time-stamp (encode-time 0 0 0 day month year) nil ts-type))
(beginning-of-line 1)))
(org-insert-time-stamp
(encode-time 0 0 0 day month year)
nil
(eq org-datetree-add-timestamp 'inactive))))
(beginning-of-line))
(defun org-datetree-file-entry-under (txt date)
"Insert a node TXT into the date tree under DATE."
(org-datetree-find-date-create date)
(defun org-datetree-file-entry-under (txt d)
"Insert a node TXT into the date tree under date D."
(org-datetree-find-date-create d)
(let ((level (org-get-valid-level (funcall outline-level) 1)))
(org-end-of-subtree t t)
(org-back-over-empty-lines)
@ -169,44 +185,42 @@ before running this command, even though the command tries to be smart."
(interactive)
(goto-char (point-min))
(let ((dre (concat "\\<" org-deadline-string "\\>[ \t]*\\'"))
(sre (concat "\\<" org-scheduled-string "\\>[ \t]*\\'"))
dct ts tmp date year month day pos hdl-pos)
(sre (concat "\\<" org-scheduled-string "\\>[ \t]*\\'")))
(while (re-search-forward org-ts-regexp nil t)
(catch 'next
(setq ts (match-string 0))
(setq tmp (buffer-substring
(max (point-at-bol) (- (match-beginning 0)
org-ds-keyword-length))
(match-beginning 0)))
(if (or (string-match "-\\'" tmp)
(string-match dre tmp)
(string-match sre tmp))
(let ((tmp (buffer-substring
(max (line-beginning-position)
(- (match-beginning 0) org-ds-keyword-length))
(match-beginning 0))))
(when (or (string-suffix-p "-" tmp)
(string-match dre tmp)
(string-match sre tmp))
(throw 'next nil))
(setq dct (decode-time (org-time-string-to-time (match-string 0)))
date (list (nth 4 dct) (nth 3 dct) (nth 5 dct))
year (nth 2 date)
month (car date)
day (nth 1 date)
pos (point))
(org-back-to-heading t)
(setq hdl-pos (point))
(unless (org-up-heading-safe)
;; No parent, we are not in a date tree
(goto-char pos)
(throw 'next nil))
(unless (looking-at "\\*+[ \t]+[0-9]+-[0-1][0-9]-[0-3][0-9]")
;; Parent looks wrong, we are not in a date tree
(goto-char pos)
(throw 'next nil))
(when (looking-at (format "\\*+[ \t]+%d-%02d-%02d" year month day))
;; At correct date already, do nothing
(progn (goto-char pos) (throw 'next nil)))
;; OK, we need to refile this entry
(goto-char hdl-pos)
(org-cut-subtree)
(save-excursion
(save-restriction
(org-datetree-file-entry-under (current-kill 0) date)))))))
(let* ((dct (decode-time (org-time-string-to-time (match-string 0))))
(date (list (nth 4 dct) (nth 3 dct) (nth 5 dct)))
(year (nth 2 date))
(month (car date))
(day (nth 1 date))
(pos (point))
(hdl-pos (progn (org-back-to-heading t) (point))))
(unless (org-up-heading-safe)
;; No parent, we are not in a date tree.
(goto-char pos)
(throw 'next nil))
(unless (looking-at "\\*+[ \t]+[0-9]+-[0-1][0-9]-[0-3][0-9]")
;; Parent looks wrong, we are not in a date tree.
(goto-char pos)
(throw 'next nil))
(when (looking-at (format "\\*+[ \t]+%d-%02d-%02d" year month day))
;; At correct date already, do nothing.
(goto-char pos)
(throw 'next nil))
;; OK, we need to refile this entry.
(goto-char hdl-pos)
(org-cut-subtree)
(save-excursion
(save-restriction
(org-datetree-file-entry-under (current-kill 0) date)))))))))
(provide 'org-datetree)

32
lisp/org/org-docview.el
View file

@ -1,4 +1,4 @@
;;; org-docview.el --- support for links to doc-view-mode buffers
;;; org-docview.el --- Support for links to doc-view-mode buffers -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -25,7 +25,7 @@
;;; Commentary:
;; This file implements links to open files in doc-view-mode.
;; Org-mode loads this module by default - if this is not what you want,
;; Org mode loads this module by default - if this is not what you want,
;; configure the variable `org-modules'.
;; The links take the form
@ -49,13 +49,15 @@
(declare-function doc-view-goto-page "doc-view" (page))
(declare-function image-mode-window-get "image-mode" (prop &optional winprops))
(org-add-link-type "docview" 'org-docview-open 'org-docview-export)
(add-hook 'org-store-link-functions 'org-docview-store-link)
(org-link-set-parameters "docview"
:follow #'org-docview-open
:export #'org-docview-export
:store #'org-docview-store-link)
(defun org-docview-export (link description format)
"Export a docview link from Org files."
(let* ((path (when (string-match "\\(.+\\)::.+" link)
(match-string 1 link)))
(let* ((path (if (string-match "\\(.+\\)::.+" link) (match-string 1 link)
link))
(desc (or description link)))
(when (stringp path)
(setq path (org-link-escape (expand-file-name path)))
@ -66,13 +68,14 @@
(t path)))))
(defun org-docview-open (link)
(when (string-match "\\(.*\\)::\\([0-9]+\\)$" link)
(let* ((path (match-string 1 link))
(page (string-to-number (match-string 2 link))))
(org-open-file path 1) ;; let org-mode open the file (in-emacs = 1)
;; to ensure org-link-frame-setup is respected
(doc-view-goto-page page)
)))
(string-match "\\(.*?\\)\\(?:::\\([0-9]+\\)\\)?$" link)
(let ((path (match-string 1 link))
(page (and (match-beginning 2)
(string-to-number (match-string 2 link)))))
;; Let Org mode open the file (in-emacs = 1) to ensure
;; org-link-frame-setup is respected.
(org-open-file path 1)
(when page (doc-view-goto-page page))))
(defun org-docview-store-link ()
"Store a link to a docview buffer."
@ -80,8 +83,7 @@
;; This buffer is in doc-view-mode
(let* ((path buffer-file-name)
(page (image-mode-window-get 'page))
(link (concat "docview:" path "::" (number-to-string page)))
(description ""))
(link (concat "docview:" path "::" (number-to-string page))))
(org-store-link-props
:type "docview"
:link link

5817
lisp/org/org-element.el
View file

File diff suppressed because it is too large Load diff

968
lisp/org/org-entities.el
View file

File diff suppressed because it is too large Load diff

9
lisp/org/org-eshell.el
View file

@ -1,4 +1,4 @@
;;; org-eshell.el - Support for links to working directories in eshell
;;; org-eshell.el - Support for Links to Working Directories in Eshell -*- lexical-binding: t; -*-
;; Copyright (C) 2011-2017 Free Software Foundation, Inc.
@ -27,8 +27,9 @@
(require 'eshell)
(require 'esh-mode)
(org-add-link-type "eshell" 'org-eshell-open)
(add-hook 'org-store-link-functions 'org-eshell-store-link)
(org-link-set-parameters "eshell"
:follow #'org-eshell-open
:store #'org-eshell-store-link)
(defun org-eshell-open (link)
"Switch to am eshell buffer and execute a command line.
@ -43,7 +44,7 @@
(eshell-buffer-name (car buffer-and-command))
(command (cadr buffer-and-command)))
(if (get-buffer eshell-buffer-name)
(org-pop-to-buffer-same-window eshell-buffer-name)
(pop-to-buffer-same-window eshell-buffer-name)
(eshell))
(goto-char (point-max))
(eshell-kill-input)

175
lisp/org/org-eww.el Normal file
View file

@ -0,0 +1,175 @@
;;; org-eww.el --- Store url and kill from Eww mode for Org -*- lexical-binding: t -*-
;; Copyright (C) 2014-2017 Free Software Foundation, Inc.
;; Author: Marco Wahl <marcowahlsoft>a<gmailcom>
;; Keywords: link, eww
;; Homepage: http://orgmode.org
;;
;; This file is part of GNU Emacs.
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; When this module is active `org-store-link' (often on key C-c l) in
;; a eww buffer stores a link to the current url of the eww buffer.
;; In an eww buffer function `org-eww-copy-for-org-mode' kills either
;; a region or the whole buffer if no region is set and transforms the
;; text on the fly so that it can be pasted into an Org buffer with
;; hot links.
;; C-c C-x C-w (and also C-c C-x M-w) trigger
;; `org-eww-copy-for-org-mode'.
;; Hint: A lot of code of this module comes from module org-w3m which
;; has been written by Andy Steward based on the idea of Richard
;; Riley. Thanks!
;; Potential: Since the code for w3m and eww is so similar one could
;; try to refactor.
;;; Code:
(require 'org)
(require 'cl-lib)
(defvar eww-current-title)
(defvar eww-current-url)
(defvar eww-data)
(defvar eww-mode-map)
(declare-function eww-current-url "eww")
;; Store Org-link in eww-mode buffer
(org-link-set-parameters "eww" :follow #'eww :store #'org-eww-store-link)
(defun org-eww-store-link ()
"Store a link to the url of a Eww buffer."
(when (eq major-mode 'eww-mode)
(org-store-link-props
:type "eww"
:link (if (< emacs-major-version 25)
eww-current-url
(eww-current-url))
:url (url-view-url t)
:description (if (< emacs-major-version 25)
(or eww-current-title eww-current-url)
(or (plist-get eww-data :title)
(eww-current-url))))))
;; Some auxiliary functions concerning links in eww buffers
(defun org-eww-goto-next-url-property-change ()
"Move to the start of next link if exists.
Otherwise point is not moved. Return point."
(goto-char
(or (next-single-property-change (point) 'shr-url)
(point))))
(defun org-eww-has-further-url-property-change-p ()
"Non-nil if there is a next url property change."
(save-excursion
(not (eq (point) (org-eww-goto-next-url-property-change)))))
(defun org-eww-url-below-point ()
"Return the url below point if there is an url; otherwise, return nil."
(get-text-property (point) 'shr-url))
(defun org-eww-copy-for-org-mode ()
"Copy current buffer content or active region with `org-mode' style links.
This will encode `link-title' and `link-location' with
`org-make-link-string', and insert the transformed test into the kill ring,
so that it can be yanked into an Org mode buffer with links working correctly.
Further lines starting with a star get quoted with a comma to keep
the structure of the Org file."
(interactive)
(let* ((regionp (org-region-active-p))
(transform-start (point-min))
(transform-end (point-max))
return-content
link-location link-title
temp-position out-bound)
(when regionp
(setq transform-start (region-beginning))
(setq transform-end (region-end))
;; Deactivate mark if current mark is activate.
(when (fboundp 'deactivate-mark) (deactivate-mark)))
(message "Transforming links...")
(save-excursion
(goto-char transform-start)
(while (and (not out-bound) ; still inside region to copy
(org-eww-has-further-url-property-change-p)) ; there is a next link
;; Store current point before jump next anchor.
(setq temp-position (point))
;; Move to next anchor when current point is not at anchor.
(or (org-eww-url-below-point)
(org-eww-goto-next-url-property-change))
(cl-assert
(org-eww-url-below-point) t
"program logic error: point must have an url below but it hasn't")
(if (<= (point) transform-end) ; if point is inside transform bound
(progn
;; Get content between two links.
(when (< temp-position (point))
(setq return-content (concat return-content
(buffer-substring
temp-position (point)))))
;; Get link location at current point.
(setq link-location (org-eww-url-below-point))
;; Get link title at current point.
(setq link-title
(buffer-substring
(point)
(org-eww-goto-next-url-property-change)))
;; concat `org-mode' style url to `return-content'.
(setq return-content
(concat return-content
(if (stringp link-location)
;; hint: link-location is different for form-elements.
(org-make-link-string link-location link-title)
link-title))))
(goto-char temp-position) ; reset point before jump next anchor
(setq out-bound t) ; for break out `while' loop
))
;; Add the rest until end of the region to be copied.
(when (< (point) transform-end)
(setq return-content
(concat return-content
(buffer-substring (point) transform-end))))
;; Quote lines starting with *.
(org-kill-new (replace-regexp-in-string "^\\*" ",*" return-content))
(message "Transforming links...done, use C-y to insert text into Org mode file"))))
;; Additional keys for eww-mode
(defun org-eww-extend-eww-keymap ()
(define-key eww-mode-map "\C-c\C-x\M-w" 'org-eww-copy-for-org-mode)
(define-key eww-mode-map "\C-c\C-x\C-w" 'org-eww-copy-for-org-mode))
(when (and (boundp 'eww-mode-map)
(keymapp eww-mode-map)) ; eww is already up.
(org-eww-extend-eww-keymap))
(add-hook 'eww-mode-hook #'org-eww-extend-eww-keymap)
(provide 'org-eww)
;;; org-eww.el ends here

555
lisp/org/org-faces.el
View file

@ -1,4 +1,4 @@
;;; org-faces.el --- Face definitions for Org-mode.
;;; org-faces.el --- Face definitions -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2017 Free Software Foundation, Inc.
@ -28,32 +28,12 @@
;;; Code:
(require 'org-macs)
(require 'org-compat)
(defun org-copy-face (old-face new-face docstring &rest attributes)
(unless (facep new-face)
(if (fboundp 'set-face-attribute)
(progn
(make-face new-face)
(set-face-attribute new-face nil :inherit old-face)
(apply 'set-face-attribute new-face nil attributes)
(set-face-doc-string new-face docstring))
(copy-face old-face new-face)
(if (fboundp 'set-face-doc-string)
(set-face-doc-string new-face docstring)))))
(put 'org-copy-face 'lisp-indent-function 2)
(when (featurep 'xemacs)
(put 'mode-line 'face-alias 'modeline))
(defgroup org-faces nil
"Faces in Org-mode."
"Faces in Org mode."
:tag "Org Faces"
:group 'org-appearance)
(defface org-default
(org-compatible-face 'default nil)
(defface org-default '((t :inherit default))
"Face used for default text."
:group 'org-faces)
@ -65,99 +45,49 @@ The foreground color of this face should be equal to the background
color of the frame."
:group 'org-faces)
(defface org-level-1 ;; originally copied from font-lock-function-name-face
(org-compatible-face 'outline-1
'((((class color) (min-colors 88) (background light)) (:foreground "Blue1"))
(((class color) (min-colors 88) (background dark)) (:foreground "LightSkyBlue"))
(((class color) (min-colors 16) (background light)) (:foreground "Blue"))
(((class color) (min-colors 16) (background dark)) (:foreground "LightSkyBlue"))
(((class color) (min-colors 8)) (:foreground "blue" :bold t))
(t (:bold t))))
(defface org-level-1 '((t :inherit outline-1))
"Face used for level 1 headlines."
:group 'org-faces)
(defface org-level-2 ;; originally copied from font-lock-variable-name-face
(org-compatible-face 'outline-2
'((((class color) (min-colors 16) (background light)) (:foreground "DarkGoldenrod"))
(((class color) (min-colors 16) (background dark)) (:foreground "LightGoldenrod"))
(((class color) (min-colors 8) (background light)) (:foreground "yellow"))
(((class color) (min-colors 8) (background dark)) (:foreground "yellow" :bold t))
(t (:bold t))))
(defface org-level-2 '((t :inherit outline-2))
"Face used for level 2 headlines."
:group 'org-faces)
(defface org-level-3 ;; originally copied from font-lock-keyword-face
(org-compatible-face 'outline-3
'((((class color) (min-colors 88) (background light)) (:foreground "Purple"))
(((class color) (min-colors 88) (background dark)) (:foreground "Cyan1"))
(((class color) (min-colors 16) (background light)) (:foreground "Purple"))
(((class color) (min-colors 16) (background dark)) (:foreground "Cyan"))
(((class color) (min-colors 8) (background light)) (:foreground "purple" :bold t))
(((class color) (min-colors 8) (background dark)) (:foreground "cyan" :bold t))
(t (:bold t))))
(defface org-level-3 '((t :inherit outline-3))
"Face used for level 3 headlines."
:group 'org-faces)
(defface org-level-4 ;; originally copied from font-lock-comment-face
(org-compatible-face 'outline-4
'((((class color) (min-colors 88) (background light)) (:foreground "Firebrick"))
(((class color) (min-colors 88) (background dark)) (:foreground "chocolate1"))
(((class color) (min-colors 16) (background light)) (:foreground "red"))
(((class color) (min-colors 16) (background dark)) (:foreground "red1"))
(((class color) (min-colors 8) (background light)) (:foreground "red" :bold t))
(((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t))
(t (:bold t))))
(defface org-level-4 '((t :inherit outline-4))
"Face used for level 4 headlines."
:group 'org-faces)
(defface org-level-5 ;; originally copied from font-lock-type-face
(org-compatible-face 'outline-5
'((((class color) (min-colors 16) (background light)) (:foreground "ForestGreen"))
(((class color) (min-colors 16) (background dark)) (:foreground "PaleGreen"))
(((class color) (min-colors 8)) (:foreground "green"))))
(defface org-level-5 '((t :inherit outline-5))
"Face used for level 5 headlines."
:group 'org-faces)
(defface org-level-6 ;; originally copied from font-lock-constant-face
(org-compatible-face 'outline-6
'((((class color) (min-colors 16) (background light)) (:foreground "CadetBlue"))
(((class color) (min-colors 16) (background dark)) (:foreground "Aquamarine"))
(((class color) (min-colors 8)) (:foreground "magenta"))))
(defface org-level-6 '((t :inherit outline-6))
"Face used for level 6 headlines."
:group 'org-faces)
(defface org-level-7 ;; originally copied from font-lock-builtin-face
(org-compatible-face 'outline-7
'((((class color) (min-colors 16) (background light)) (:foreground "Orchid"))
(((class color) (min-colors 16) (background dark)) (:foreground "LightSteelBlue"))
(((class color) (min-colors 8)) (:foreground "blue"))))
(defface org-level-7 '((t :inherit outline-7))
"Face used for level 7 headlines."
:group 'org-faces)
(defface org-level-8 ;; originally copied from font-lock-string-face
(org-compatible-face 'outline-8
'((((class color) (min-colors 16) (background light)) (:foreground "RosyBrown"))
(((class color) (min-colors 16) (background dark)) (:foreground "LightSalmon"))
(((class color) (min-colors 8)) (:foreground "green"))))
(defface org-level-8 '((t :inherit outline-8))
"Face used for level 8 headlines."
:group 'org-faces)
(defface org-special-keyword ;; originally copied from font-lock-string-face
(org-compatible-face 'font-lock-keyword-face
'((((class color) (min-colors 16) (background light)) (:foreground "RosyBrown"))
(((class color) (min-colors 16) (background dark)) (:foreground "LightSalmon"))
(t (:italic t))))
(defface org-special-keyword '((t :inherit font-lock-keyword-face))
"Face used for special keywords."
:group 'org-faces)
(defface org-drawer ;; originally copied from font-lock-function-name-face
(org-compatible-face nil
'((((class color) (min-colors 88) (background light)) (:foreground "Blue1"))
(((class color) (min-colors 88) (background dark)) (:foreground "LightSkyBlue"))
(((class color) (min-colors 16) (background light)) (:foreground "Blue"))
(((class color) (min-colors 16) (background dark)) (:foreground "LightSkyBlue"))
(((class color) (min-colors 8)) (:foreground "blue" :bold t))
(t (:bold t))))
(defface org-drawer ;Copied from `font-lock-function-name-face'
'((((class color) (min-colors 88) (background light)) (:foreground "Blue1"))
(((class color) (min-colors 88) (background dark)) (:foreground "LightSkyBlue"))
(((class color) (min-colors 16) (background light)) (:foreground "Blue"))
(((class color) (min-colors 16) (background dark)) (:foreground "LightSkyBlue"))
(((class color) (min-colors 8)) (:foreground "blue" :bold t))
(t (:bold t)))
"Face used for drawers."
:group 'org-faces)
@ -166,18 +96,17 @@ color of the frame."
:group 'org-faces)
(defface org-column
(org-compatible-face nil
'((((class color) (min-colors 16) (background light))
(:background "grey90" :weight normal :slant normal :strike-through nil
:underline nil))
(((class color) (min-colors 16) (background dark))
(:background "grey30" :weight normal :slant normal :strike-through nil
:underline nil))
(((class color) (min-colors 8))
(:background "cyan" :foreground "black"
:weight normal :slant normal :strike-through nil
:underline nil))
(t (:inverse-video t))))
'((((class color) (min-colors 16) (background light))
(:background "grey90" :weight normal :slant normal :strike-through nil
:underline nil))
(((class color) (min-colors 16) (background dark))
(:background "grey30" :weight normal :slant normal :strike-through nil
:underline nil))
(((class color) (min-colors 8))
(:background "cyan" :foreground "black"
:weight normal :slant normal :strike-through nil
:underline nil))
(t (:inverse-video t)))
"Face for column display of entry properties.
This is actually only part of the face definition for the text in column view.
The following faces apply, with this priority.
@ -198,59 +127,33 @@ character (this might for example be the a TODO keyword) might still
shine through in some properties. So when your column view looks
funny, with \"random\" colors, weight, strike-through, try to explicitly
set the properties in the `org-column' face. For example, set
:underline to nil, or the :slant to `normal'.
Under XEmacs, the rules are simpler, because the XEmacs version of
column view defines special faces for each outline level. See the file
`org-colview-xemacs.el' in Org's contrib/ directory for details."
:underline to nil, or the :slant to `normal'."
:group 'org-faces)
(defface org-column-title
(org-compatible-face nil
'((((class color) (min-colors 16) (background light))
(:background "grey90" :underline t :weight bold))
(((class color) (min-colors 16) (background dark))
(:background "grey30" :underline t :weight bold))
(((class color) (min-colors 8))
(:background "cyan" :foreground "black" :underline t :weight bold))
(t (:inverse-video t))))
'((((class color) (min-colors 16) (background light))
(:background "grey90" :underline t :weight bold))
(((class color) (min-colors 16) (background dark))
(:background "grey30" :underline t :weight bold))
(((class color) (min-colors 8))
(:background "cyan" :foreground "black" :underline t :weight bold))
(t (:inverse-video t)))
"Face for column display of entry properties."
:group 'org-faces)
(defface org-agenda-column-dateline
(org-compatible-face 'org-column
'((t nil)))
(defface org-agenda-column-dateline '((t :inherit org-column))
"Face used in agenda column view for datelines with summaries."
:group 'org-faces)
(defface org-warning
(org-compatible-face 'font-lock-warning-face
'((((class color) (min-colors 16) (background light)) (:foreground "Red1" :bold t))
(((class color) (min-colors 16) (background dark)) (:foreground "Pink" :bold t))
(((class color) (min-colors 8) (background light)) (:foreground "red" :bold t))
(((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t))
(t (:bold t))))
(defface org-warning '((t :inherit font-lock-warning-face))
"Face for deadlines and TODO keywords."
:group 'org-faces)
(defface org-archived ; similar to shadow
(org-compatible-face 'shadow
'((((class color grayscale) (min-colors 88) (background light))
(:foreground "grey50"))
(((class color grayscale) (min-colors 88) (background dark))
(:foreground "grey70"))
(((class color) (min-colors 8) (background light))
(:foreground "green"))
(((class color) (min-colors 8) (background dark))
(:foreground "yellow"))))
(defface org-archived '((t :inherit shadow))
"Face for headline with the ARCHIVE tag."
:group 'org-faces)
(defface org-link
(org-compatible-face 'link
'((((class color) (background light)) (:foreground "Purple" :underline t))
(((class color) (background dark)) (:foreground "Cyan" :underline t))
(t (:underline t))))
(defface org-link '((t :inherit link))
"Face for links."
:group 'org-faces)
@ -283,12 +186,11 @@ column view defines special faces for each outline level. See the file
:group 'org-faces)
(defface org-date-selected
(org-compatible-face nil
'((((class color) (min-colors 16) (background light)) (:foreground "Red1" :inverse-video t))
(((class color) (min-colors 16) (background dark)) (:foreground "Pink" :inverse-video t))
(((class color) (min-colors 8) (background light)) (:foreground "red" :inverse-video t))
(((class color) (min-colors 8) (background dark)) (:foreground "red" :inverse-video t))
(t (:inverse-video t))))
'((((class color) (min-colors 16) (background light)) (:foreground "Red1" :inverse-video t))
(((class color) (min-colors 16) (background dark)) (:foreground "Pink" :inverse-video t))
(((class color) (min-colors 8) (background light)) (:foreground "red" :inverse-video t))
(((class color) (min-colors 8) (background dark)) (:foreground "red" :inverse-video t))
(t (:inverse-video t)))
"Face for highlighting the calendar day when using `org-read-date'.
Using a bold face here might cause discrepancies while displaying the
calendar."
@ -301,43 +203,38 @@ calendar."
"Face for diary-like sexp date specifications."
:group 'org-faces)
(defface org-tag
'((t (:bold t)))
(defface org-tag '((t (:bold t)))
"Default face for tags.
Note that the variable `org-tag-faces' can be used to overrule this face for
specific tags."
:group 'org-faces)
(defface org-list-dt
'((t (:bold t)))
(defface org-list-dt '((t (:bold t)))
"Default face for definition terms in lists."
:group 'org-faces)
(defface org-todo ; font-lock-warning-face
(org-compatible-face nil
'((((class color) (min-colors 16) (background light)) (:foreground "Red1" :bold t))
(((class color) (min-colors 16) (background dark)) (:foreground "Pink" :bold t))
(((class color) (min-colors 8) (background light)) (:foreground "red" :bold t))
(((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t))
(t (:inverse-video t :bold t))))
(defface org-todo ;Copied from `font-lock-warning-face'
'((((class color) (min-colors 16) (background light)) (:foreground "Red1" :bold t))
(((class color) (min-colors 16) (background dark)) (:foreground "Pink" :bold t))
(((class color) (min-colors 8) (background light)) (:foreground "red" :bold t))
(((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t))
(t (:inverse-video t :bold t)))
"Face for TODO keywords."
:group 'org-faces)
(defface org-done ;; originally copied from font-lock-type-face
(org-compatible-face nil
'((((class color) (min-colors 16) (background light)) (:foreground "ForestGreen" :bold t))
(((class color) (min-colors 16) (background dark)) (:foreground "PaleGreen" :bold t))
(((class color) (min-colors 8)) (:foreground "green"))
(t (:bold t))))
(defface org-done ;Copied from `font-lock-type-face'
'((((class color) (min-colors 16) (background light)) (:foreground "ForestGreen" :bold t))
(((class color) (min-colors 16) (background dark)) (:foreground "PaleGreen" :bold t))
(((class color) (min-colors 8)) (:foreground "green"))
(t (:bold t)))
"Face used for todo keywords that indicate DONE items."
:group 'org-faces)
(defface org-agenda-done ;; originally copied from font-lock-type-face
(org-compatible-face nil
'((((class color) (min-colors 16) (background light)) (:foreground "ForestGreen"))
(((class color) (min-colors 16) (background dark)) (:foreground "PaleGreen"))
(((class color) (min-colors 8)) (:foreground "green"))
(t (:bold nil))))
(defface org-agenda-done ;Copied from `font-lock-type-face'
'((((class color) (min-colors 16) (background light)) (:foreground "ForestGreen"))
(((class color) (min-colors 16) (background dark)) (:foreground "PaleGreen"))
(((class color) (min-colors 8)) (:foreground "green"))
(t (:bold nil)))
"Face used in agenda, to indicate lines switched to DONE.
This face is used to de-emphasize items that where brightly colored in the
agenda because they were things to do, or overdue. The DONE state itself
@ -346,11 +243,10 @@ is of course immediately visible, but for example a passed deadline is
of the frame, for example."
:group 'org-faces)
(defface org-headline-done ;; originally copied from font-lock-string-face
(org-compatible-face nil
'((((class color) (min-colors 16) (background light)) (:foreground "RosyBrown"))
(((class color) (min-colors 16) (background dark)) (:foreground "LightSalmon"))
(((class color) (min-colors 8) (background light)) (:bold nil))))
(defface org-headline-done ;Copied from `font-lock-string-face'
'((((class color) (min-colors 16) (background light)) (:foreground "RosyBrown"))
(((class color) (min-colors 16) (background dark)) (:foreground "LightSalmon"))
(((class color) (min-colors 8) (background light)) (:bold nil)))
"Face used to indicate that a headline is DONE.
This face is only used if `org-fontify-done-headline' is set. If applies
to the part of the headline after the DONE keyword."
@ -388,11 +284,7 @@ determines if it is a foreground or a background color."
(string :tag "Color")
(sexp :tag "Face")))))
(defface org-priority ;; originally copied from font-lock-string-face
(org-compatible-face 'font-lock-keyword-face
'((((class color) (min-colors 16) (background light)) (:foreground "RosyBrown"))
(((class color) (min-colors 16) (background dark)) (:foreground "LightSalmon"))
(t (:italic t))))
(defface org-priority '((t :inherit font-lock-keyword-face))
"Face used for priority cookies."
:group 'org-faces)
@ -421,18 +313,17 @@ determines if it is a foreground or a background color."
(setq org-tags-special-faces-re
(concat ":\\(" (mapconcat 'car value "\\|") "\\):"))))
(defface org-checkbox
(org-compatible-face 'bold
'((t (:bold t))))
(defface org-checkbox '((t :inherit bold))
"Face for checkboxes."
:group 'org-faces)
(defface org-checkbox-statistics-todo '((t (:inherit org-todo)))
"Face used for unfinished checkbox statistics."
:group 'org-faces)
(org-copy-face 'org-todo 'org-checkbox-statistics-todo
"Face used for unfinished checkbox statistics.")
(org-copy-face 'org-done 'org-checkbox-statistics-done
"Face used for finished checkbox statistics.")
(defface org-checkbox-statistics-done '((t (:inherit org-done)))
"Face used for finished checkbox statistics."
:group 'org-faces)
(defcustom org-tag-faces nil
"Faces for specific tags.
@ -454,44 +345,32 @@ changes."
(string :tag "Foreground color")
(sexp :tag "Face")))))
(defface org-table ;; originally copied from font-lock-function-name-face
(org-compatible-face nil
'((((class color) (min-colors 88) (background light)) (:foreground "Blue1"))
(((class color) (min-colors 88) (background dark)) (:foreground "LightSkyBlue"))
(((class color) (min-colors 16) (background light)) (:foreground "Blue"))
(((class color) (min-colors 16) (background dark)) (:foreground "LightSkyBlue"))
(((class color) (min-colors 8) (background light)) (:foreground "blue"))
(((class color) (min-colors 8) (background dark)))))
(defface org-table ;Copied from `font-lock-function-name-face'
'((((class color) (min-colors 88) (background light)) (:foreground "Blue1"))
(((class color) (min-colors 88) (background dark)) (:foreground "LightSkyBlue"))
(((class color) (min-colors 16) (background light)) (:foreground "Blue"))
(((class color) (min-colors 16) (background dark)) (:foreground "LightSkyBlue"))
(((class color) (min-colors 8) (background light)) (:foreground "blue"))
(((class color) (min-colors 8) (background dark))))
"Face used for tables."
:group 'org-faces)
(defface org-formula
(org-compatible-face nil
'((((class color) (min-colors 88) (background light)) (:foreground "Firebrick"))
(((class color) (min-colors 88) (background dark)) (:foreground "chocolate1"))
(((class color) (min-colors 8) (background light)) (:foreground "red"))
(((class color) (min-colors 8) (background dark)) (:foreground "red"))
(t (:bold t :italic t))))
'((((class color) (min-colors 88) (background light)) (:foreground "Firebrick"))
(((class color) (min-colors 88) (background dark)) (:foreground "chocolate1"))
(((class color) (min-colors 8) (background light)) (:foreground "red"))
(((class color) (min-colors 8) (background dark)) (:foreground "red"))
(t (:bold t :italic t)))
"Face for formulas."
:group 'org-faces)
(defface org-code
(org-compatible-face 'shadow
'((((class color grayscale) (min-colors 88) (background light))
(:foreground "grey50"))
(((class color grayscale) (min-colors 88) (background dark))
(:foreground "grey70"))
(((class color) (min-colors 8) (background light))
(:foreground "green"))
(((class color) (min-colors 8) (background dark))
(:foreground "yellow"))))
(defface org-code '((t :inherit shadow))
"Face for fixed-width text like code snippets."
:group 'org-faces
:version "22.1")
(defface org-meta-line
(org-compatible-face 'font-lock-comment-face nil)
"Face for meta lines startin with \"#+\"."
(defface org-meta-line '((t :inherit font-lock-comment-face))
"Face for meta lines starting with \"#+\"."
:group 'org-faces
:version "22.1")
@ -510,60 +389,37 @@ changes."
follows a #+DATE:, #+AUTHOR: or #+EMAIL: keyword."
:group 'org-faces)
(defface org-document-info-keyword
(org-compatible-face 'shadow
'((((class color grayscale) (min-colors 88) (background light))
(:foreground "grey50"))
(((class color grayscale) (min-colors 88) (background dark))
(:foreground "grey70"))
(((class color) (min-colors 8) (background light))
(:foreground "green"))
(((class color) (min-colors 8) (background dark))
(:foreground "yellow"))))
(defface org-document-info-keyword '((t :inherit shadow))
"Face for #+TITLE:, #+AUTHOR:, #+EMAIL: and #+DATE: keywords."
:group 'org-faces)
(defface org-block
(org-compatible-face 'shadow
'((((class color grayscale) (min-colors 88) (background light))
(:foreground "grey50"))
(((class color grayscale) (min-colors 88) (background dark))
(:foreground "grey70"))
(((class color) (min-colors 8) (background light))
(:foreground "green"))
(((class color) (min-colors 8) (background dark))
(:foreground "yellow"))))
"Face text in #+begin ... #+end blocks."
(defface org-block '((t :inherit shadow))
"Face text in #+begin ... #+end blocks.
For source-blocks `org-src-block-faces' takes precedence.
See also `org-fontify-quote-and-verse-blocks'."
:group 'org-faces
:version "26.1")
(defface org-block-begin-line '((t (:inherit org-meta-line)))
"Face used for the line delimiting the begin of source blocks."
:group 'org-faces)
(defface org-block-end-line '((t (:inherit org-block-begin-line)))
"Face used for the line delimiting the end of source blocks."
:group 'org-faces)
(defface org-verbatim '((t (:inherit shadow)))
"Face for fixed-with text like code snippets"
:group 'org-faces
:version "22.1")
(defface org-block-background '((t ()))
"Face used for the source block background.")
(defface org-quote '((t (:inherit org-block)))
"Face for #+BEGIN_QUOTE ... #+END_QUOTE blocks."
:group 'org-faces)
(org-copy-face 'org-meta-line 'org-block-begin-line
"Face used for the line delimiting the begin of source blocks.")
(org-copy-face 'org-meta-line 'org-block-end-line
"Face used for the line delimiting the end of source blocks.")
(defface org-verbatim
(org-compatible-face 'shadow
'((((class color grayscale) (min-colors 88) (background light))
(:foreground "grey50" :underline t))
(((class color grayscale) (min-colors 88) (background dark))
(:foreground "grey70" :underline t))
(((class color) (min-colors 8) (background light))
(:foreground "green" :underline t))
(((class color) (min-colors 8) (background dark))
(:foreground "yellow" :underline t))))
"Face for fixed-with text like code snippets."
:group 'org-faces
:version "22.1")
(org-copy-face 'org-block 'org-quote
"Face for #+BEGIN_QUOTE ... #+END_QUOTE blocks.")
(org-copy-face 'org-block 'org-verse
"Face for #+BEGIN_VERSE ... #+END_VERSE blocks.")
(defface org-verse '((t (:inherit org-block)))
"Face for #+BEGIN_VERSE ... #+END_VERSE blocks."
:group 'org-faces)
(defcustom org-fontify-quote-and-verse-blocks nil
"Non-nil means, add a special face to #+begin_quote and #+begin_verse block.
@ -573,64 +429,64 @@ content of these blocks will still be treated as Org syntax."
:version "24.1"
:type 'boolean)
(defface org-clock-overlay ;; copied from secondary-selection
(org-compatible-face nil
'((((class color) (min-colors 88) (background light))
(:background "yellow1"))
(((class color) (min-colors 88) (background dark))
(:background "SkyBlue4"))
(((class color) (min-colors 16) (background light))
(:background "yellow"))
(((class color) (min-colors 16) (background dark))
(:background "SkyBlue4"))
(((class color) (min-colors 8))
(:background "cyan" :foreground "black"))
(t (:inverse-video t))))
(defface org-clock-overlay ;Copied from `secondary-selection'
'((((class color) (min-colors 88) (background light))
(:background "LightGray" :foreground "black"))
(((class color) (min-colors 88) (background dark))
(:background "SkyBlue4" :foreground "white"))
(((class color) (min-colors 16) (background light))
(:background "gray" :foreground "black"))
(((class color) (min-colors 16) (background dark))
(:background "SkyBlue4" :foreground "white"))
(((class color) (min-colors 8))
(:background "cyan" :foreground "black"))
(t (:inverse-video t)))
"Basic face for displaying the secondary selection."
:group 'org-faces)
(defface org-agenda-structure ;; originally copied from font-lock-function-name-face
(org-compatible-face nil
'((((class color) (min-colors 88) (background light)) (:foreground "Blue1"))
(((class color) (min-colors 88) (background dark)) (:foreground "LightSkyBlue"))
(((class color) (min-colors 16) (background light)) (:foreground "Blue"))
(((class color) (min-colors 16) (background dark)) (:foreground "LightSkyBlue"))
(((class color) (min-colors 8)) (:foreground "blue" :bold t))
(t (:bold t))))
(defface org-agenda-structure ;Copied from `font-lock-function-name-face'
'((((class color) (min-colors 88) (background light)) (:foreground "Blue1"))
(((class color) (min-colors 88) (background dark)) (:foreground "LightSkyBlue"))
(((class color) (min-colors 16) (background light)) (:foreground "Blue"))
(((class color) (min-colors 16) (background dark)) (:foreground "LightSkyBlue"))
(((class color) (min-colors 8)) (:foreground "blue" :bold t))
(t (:bold t)))
"Face used in agenda for captions and dates."
:group 'org-faces)
(org-copy-face 'org-agenda-structure 'org-agenda-date
"Face used in agenda for normal days.")
(defface org-agenda-date '((t (:inherit org-agenda-structure)))
"Face used in agenda for normal days."
:group 'org-faces)
(org-copy-face 'org-agenda-date 'org-agenda-date-today
(defface org-agenda-date-today
'((t (:inherit org-agenda-date :weight bold :italic t)))
"Face used in agenda for today."
:weight 'bold :italic 't)
:group 'org-faces)
(org-copy-face 'secondary-selection 'org-agenda-clocking
"Face marking the current clock item in the agenda.")
(defface org-agenda-clocking '((t (:inherit secondary-selection)))
"Face marking the current clock item in the agenda."
:group 'org-faces)
(org-copy-face 'org-agenda-date 'org-agenda-date-weekend
(defface org-agenda-date-weekend '((t (:inherit org-agenda-date :weight bold)))
"Face used in agenda for weekend days.
See the variable `org-agenda-weekend-days' for a definition of which days
belong to the weekend."
:weight 'bold)
See the variable `org-agenda-weekend-days' for a definition of
which days belong to the weekend."
:group 'org-faces)
(defface org-scheduled
(org-compatible-face nil
'((((class color) (min-colors 88) (background light)) (:foreground "DarkGreen"))
(((class color) (min-colors 88) (background dark)) (:foreground "PaleGreen"))
(((class color) (min-colors 8)) (:foreground "green"))
(t (:bold t :italic t))))
'((((class color) (min-colors 88) (background light)) (:foreground "DarkGreen"))
(((class color) (min-colors 88) (background dark)) (:foreground "PaleGreen"))
(((class color) (min-colors 8)) (:foreground "green"))
(t (:bold t :italic t)))
"Face for items scheduled for a certain day."
:group 'org-faces)
(defface org-scheduled-today
(org-compatible-face nil
'((((class color) (min-colors 88) (background light)) (:foreground "DarkGreen"))
(((class color) (min-colors 88) (background dark)) (:foreground "PaleGreen"))
(((class color) (min-colors 8)) (:foreground "green"))
(t (:bold t :italic t))))
'((((class color) (min-colors 88) (background light)) (:foreground "DarkGreen"))
(((class color) (min-colors 88) (background dark)) (:foreground "PaleGreen"))
(((class color) (min-colors 8)) (:foreground "green"))
(t (:bold t :italic t)))
"Face for items scheduled for a certain day."
:group 'org-faces)
@ -641,22 +497,20 @@ belong to the weekend."
:group 'org-faces)
(defface org-scheduled-previously
(org-compatible-face nil
'((((class color) (min-colors 88) (background light)) (:foreground "Firebrick"))
(((class color) (min-colors 88) (background dark)) (:foreground "chocolate1"))
(((class color) (min-colors 8) (background light)) (:foreground "red"))
(((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t))
(t (:bold t))))
'((((class color) (min-colors 88) (background light)) (:foreground "Firebrick"))
(((class color) (min-colors 88) (background dark)) (:foreground "chocolate1"))
(((class color) (min-colors 8) (background light)) (:foreground "red"))
(((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t))
(t (:bold t)))
"Face for items scheduled previously, and not yet done."
:group 'org-faces)
(defface org-upcoming-deadline
(org-compatible-face nil
'((((class color) (min-colors 88) (background light)) (:foreground "Firebrick"))
(((class color) (min-colors 88) (background dark)) (:foreground "chocolate1"))
(((class color) (min-colors 8) (background light)) (:foreground "red"))
(((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t))
(t (:bold t))))
'((((class color) (min-colors 88) (background light)) (:foreground "Firebrick"))
(((class color) (min-colors 88) (background dark)) (:foreground "chocolate1"))
(((class color) (min-colors 8) (background light)) (:foreground "red"))
(((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t))
(t (:bold t)))
"Face for items scheduled previously, and not yet done."
:group 'org-faces)
@ -666,7 +520,7 @@ belong to the weekend."
(0.0 . default))
"Faces for showing deadlines in the agenda.
This is a list of cons cells. The cdr of each cell is a face to be used,
and it can also just be like (:foreground \"yellow\").
and it can also just be like \\='(:foreground \"yellow\").
Each car is a fraction of the head-warning time that must have passed for
this the face in the cdr to be used for display. The numbers must be
given in descending order. The head-warning time is normally taken
@ -686,65 +540,61 @@ month and 365.24 days for a year)."
(sexp :tag "Face"))))
(defface org-agenda-restriction-lock
(org-compatible-face nil
'((((class color) (min-colors 88) (background light)) (:background "#eeeeee"))
(((class color) (min-colors 88) (background dark)) (:background "#1C1C1C"))
(((class color) (min-colors 16) (background light)) (:background "#eeeeee"))
(((class color) (min-colors 16) (background dark)) (:background "#1C1C1C"))
(((class color) (min-colors 8)) (:background "cyan" :foreground "black"))
(t (:inverse-video t))))
'((((class color) (min-colors 88) (background light)) (:background "#eeeeee"))
(((class color) (min-colors 88) (background dark)) (:background "#1C1C1C"))
(((class color) (min-colors 16) (background light)) (:background "#eeeeee"))
(((class color) (min-colors 16) (background dark)) (:background "#1C1C1C"))
(((class color) (min-colors 8)) (:background "cyan" :foreground "black"))
(t (:inverse-video t)))
"Face for showing the agenda restriction lock."
:group 'org-faces)
(defface org-agenda-filter-tags
(org-compatible-face 'mode-line nil)
(defface org-agenda-filter-tags '((t :inherit mode-line))
"Face for tag(s) in the mode-line when filtering the agenda."
:group 'org-faces)
(defface org-agenda-filter-regexp
(org-compatible-face 'mode-line nil)
(defface org-agenda-filter-regexp '((t :inherit mode-line))
"Face for regexp(s) in the mode-line when filtering the agenda."
:group 'org-faces)
(defface org-agenda-filter-category
(org-compatible-face 'mode-line nil)
"Face for categories(s) in the mode-line when filtering the agenda."
(defface org-agenda-filter-category '((t :inherit mode-line))
"Face for categories in the mode-line when filtering the agenda."
:group 'org-faces)
(defface org-time-grid ;; originally copied from font-lock-variable-name-face
(org-compatible-face nil
'((((class color) (min-colors 16) (background light)) (:foreground "DarkGoldenrod"))
(((class color) (min-colors 16) (background dark)) (:foreground "LightGoldenrod"))
(((class color) (min-colors 8)) (:foreground "yellow" :weight light))))
(defface org-agenda-filter-effort '((t :inherit mode-line))
"Face for effort in the mode-line when filtering the agenda."
:group 'org-faces)
(defface org-time-grid ;Copied from `font-lock-variable-name-face'
'((((class color) (min-colors 16) (background light)) (:foreground "DarkGoldenrod"))
(((class color) (min-colors 16) (background dark)) (:foreground "LightGoldenrod"))
(((class color) (min-colors 8)) (:foreground "yellow" :weight light)))
"Face used for time grids."
:group 'org-faces)
(org-copy-face 'org-time-grid 'org-agenda-current-time
"Face used to show the current time in the time grid.")
(defface org-agenda-current-time '((t (:inherit org-time-grid)))
"Face used to show the current time in the time grid."
:group 'org-faces)
(defface org-agenda-diary
(org-compatible-face 'default nil)
(defface org-agenda-diary '((t :inherit default))
"Face used for agenda entries that come from the Emacs diary."
:group 'org-faces)
(defface org-agenda-calendar-event
(org-compatible-face 'default nil)
(defface org-agenda-calendar-event '((t :inherit default))
"Face used to show events and appointments in the agenda."
:group 'org-faces)
(defface org-agenda-calendar-sexp
(org-compatible-face 'default nil)
(defface org-agenda-calendar-sexp '((t :inherit default))
"Face used to show events computed from a S-expression."
:group 'org-faces)
(defconst org-level-faces
'(org-level-1 org-level-2 org-level-3 org-level-4
org-level-5 org-level-6 org-level-7 org-level-8
))
org-level-5 org-level-6 org-level-7 org-level-8))
(defcustom org-n-level-faces (length org-level-faces)
"The number of different faces to be used for headlines.
Org-mode defines 8 different headline faces, so this can be at most 8.
Org mode defines 8 different headline faces, so this can be at most 8.
If it is less than 8, the level-1 face gets re-used for level N+1 etc."
:type 'integer
:group 'org-faces)
@ -777,25 +627,26 @@ level org-n-level-faces"
:version "24.4"
:package-version '(Org . "8.0"))
(defface org-macro
(org-compatible-face 'org-latex-and-related nil)
(defface org-macro '((t :inherit org-latex-and-related))
"Face for macros."
:group 'org-faces
:version "24.4"
:package-version '(Org . "8.0"))
(defface org-tag-group
(org-compatible-face 'org-tag nil)
(defface org-tag-group '((t :inherit org-tag))
"Face for group tags."
:group 'org-faces
:version "24.4"
:package-version '(Org . "8.0"))
(org-copy-face 'mode-line 'org-mode-line-clock
"Face used for clock display in mode line.")
(org-copy-face 'mode-line 'org-mode-line-clock-overrun
(defface org-mode-line-clock '((t (:inherit mode-line)))
"Face used for clock display in mode line."
:group 'org-faces)
(defface org-mode-line-clock-overrun
'((t (:inherit mode-line :background "red")))
"Face used for clock display for overrun tasks in mode line."
:background "red")
:group 'org-faces)
(provide 'org-faces)

155
lisp/org/org-feed.el
View file

@ -1,4 +1,4 @@
;;; org-feed.el --- Add RSS feed items to Org files
;;; org-feed.el --- Add RSS feed items to Org files -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
;;
@ -24,11 +24,11 @@
;;
;;; Commentary:
;;
;; This module allows entries to be created and changed in an Org-mode
;; file triggered by items in an RSS feed. The basic functionality is
;; geared toward simply adding new items found in a feed as outline nodes
;; to an Org file. Using hooks, arbitrary actions can be triggered for
;; new or changed items.
;; This module allows entries to be created and changed in an Org mode
;; file triggered by items in an RSS feed. The basic functionality
;; is geared toward simply adding new items found in a feed as
;; outline nodes to an Org file. Using hooks, arbitrary actions can
;; be triggered for new or changed items.
;;
;; Selecting feeds and target locations
;; ------------------------------------
@ -77,10 +77,8 @@
;; org-feed.el needs to keep track of which feed items have been handled
;; before, so that they will not be handled again. For this, org-feed.el
;; stores information in a special drawer, FEEDSTATUS, under the heading
;; that received the input of the feed. You should add FEEDSTATUS
;; to your list of drawers in the files that receive feed input:
;; that received the input of the feed.
;;
;; #+DRAWERS: PROPERTIES CLOCK LOGBOOK RESULTS FEEDSTATUS
;;
;; Acknowledgments
;; ---------------
@ -102,8 +100,8 @@
(declare-function xml-substitute-special "xml" (string))
(declare-function org-capture-escaped-% "org-capture" ())
(declare-function org-capture-expand-embedded-elisp "org-capture" (&optional mark))
(declare-function org-capture-inside-embedded-elisp-p "org-capture" ())
(declare-function org-capture-expand-embedded-elisp "org-capture" ())
(defgroup org-feed nil
"Options concerning RSS feeds as inputs for Org files."
@ -117,7 +115,9 @@ to create inbox items in Org. Each entry is a list with the following items:
name a custom name for this feed
URL the Feed URL
file the target Org file where entries should be listed
file the target Org file where entries should be listed, when
nil the target becomes the current buffer (may be an
indirect buffer) each time the feed update is invoked
headline the headline under which entries should be listed
Additional arguments can be given using keyword-value pairs. Many of these
@ -216,10 +216,7 @@ Here are the keyword-value pair allows in `org-feed-alist'.
(defcustom org-feed-drawer "FEEDSTATUS"
"The name of the drawer for feed status information.
Each feed may also specify its own drawer name using the `:drawer'
parameter in `org-feed-alist'.
Note that in order to make these drawers behave like drawers, they must
be added to the variable `org-drawers' or configured with a #+DRAWERS
line."
parameter in `org-feed-alist'."
:group 'org-feed
:type '(string :tag "Drawer Name"))
@ -300,7 +297,8 @@ it can be a list structured like an entry in `org-feed-alist'."
(catch 'exit
(let ((name (car feed))
(url (nth 1 feed))
(file (nth 2 feed))
(file (or (nth 2 feed) (buffer-file-name (or (buffer-base-buffer)
(current-buffer)))))
(headline (nth 3 feed))
(filter (nth 1 (memq :filter feed)))
(formatter (nth 1 (memq :formatter feed)))
@ -315,7 +313,7 @@ it can be a list structured like an entry in `org-feed-alist'."
(parse-entry (or (nth 1 (memq :parse-entry feed))
'org-feed-parse-rss-entry))
feed-buffer inbox-pos new-formatted
entries old-status status new changed guid-alist e guid olds)
entries old-status status new changed guid-alist guid olds)
(setq feed-buffer (org-feed-get-feed url))
(unless (and feed-buffer (bufferp (get-buffer feed-buffer)))
(error "Cannot get feed %s" name))
@ -407,8 +405,8 @@ it can be a list structured like an entry in `org-feed-alist'."
;; Normalize the visibility of the inbox tree
(goto-char inbox-pos)
(hide-subtree)
(show-children)
(outline-hide-subtree)
(org-show-children)
(org-cycle-hide-drawers 'children)
;; Hooks and messages
@ -442,7 +440,7 @@ it can be a list structured like an entry in `org-feed-alist'."
(if (stringp feed) (setq feed (assoc feed org-feed-alist)))
(unless feed
(error "No such feed in `org-feed-alist"))
(org-pop-to-buffer-same-window
(pop-to-buffer-same-window
(org-feed-update feed 'retrieve-only))
(goto-char (point-min)))
@ -477,8 +475,7 @@ This will find DRAWER and extract the alist."
"Write the feed STATUS to DRAWER in entry at POS."
(save-excursion
(goto-char pos)
(let ((end (save-excursion (org-end-of-subtree t t)))
guid)
(let ((end (save-excursion (org-end-of-subtree t t))))
(if (re-search-forward (concat "^[ \t]*:" drawer ":[ \t]*\n")
end t)
(progn
@ -514,66 +511,77 @@ ENTRY is a property list. This function adds a `:formatted-for-org' property
and returns the full property list.
If that property is already present, nothing changes."
(require 'org-capture)
(if formatter
(funcall formatter entry)
(let (dlines time escape name tmp
v-h v-t v-T v-u v-U v-a)
(setq dlines (org-split-string (or (plist-get entry :description) "???")
"\n")
v-h (or (plist-get entry :title) (car dlines) "???")
time (or (if (plist-get entry :pubDate)
(org-read-date t t (plist-get entry :pubDate)))
(current-time))
v-t (format-time-string (org-time-stamp-format nil nil) time)
v-T (format-time-string (org-time-stamp-format t nil) time)
v-u (format-time-string (org-time-stamp-format nil t) time)
v-U (format-time-string (org-time-stamp-format t t) time)
v-a (if (setq tmp (or (and (plist-get entry :guid-permalink)
(plist-get entry :guid))
(plist-get entry :link)))
(concat "[[" tmp "]]\n")
""))
(if formatter (funcall formatter entry)
(let* ((dlines
(org-split-string (or (plist-get entry :description) "???")
"\n"))
(time (or (if (plist-get entry :pubDate)
(org-read-date t t (plist-get entry :pubDate)))
(current-time)))
(v-h (or (plist-get entry :title) (car dlines) "???"))
(v-t (format-time-string (org-time-stamp-format nil nil) time))
(v-T (format-time-string (org-time-stamp-format t nil) time))
(v-u (format-time-string (org-time-stamp-format nil t) time))
(v-U (format-time-string (org-time-stamp-format t t) time))
(v-a (let ((tmp (or (and (plist-get entry :guid-permalink)
(plist-get entry :guid))
(plist-get entry :link))))
(if tmp (format "[[%s]]\n" tmp ) ""))))
(with-temp-buffer
(insert template)
(insert template)
(goto-char (point-min))
;; Simple %-escapes
;; before embedded elisp to support simple %-escapes as
;; arguments for embedded elisp
(goto-char (point-min))
(while (re-search-forward "%\\([a-zA-Z]+\\)" nil t)
(unless (org-capture-escaped-%)
(setq name (match-string 1)
escape (org-capture-inside-embedded-elisp-p))
(cond
((member name '("h" "t" "T" "u" "U" "a"))
(setq tmp (symbol-value (intern (concat "v-" name)))))
((setq tmp (plist-get entry (intern (concat ":" name))))
(save-excursion
(save-match-data
(beginning-of-line 1)
(when (looking-at
(concat "^\\([ \t]*\\)%" name "[ \t]*$"))
(setq tmp (org-feed-make-indented-block
tmp (org-get-indentation))))))))
(when tmp
;; escape string delimiters `"' when inside %() embedded lisp
(when escape
(setq tmp (replace-regexp-in-string "\"" "\\\\\"" tmp)))
(replace-match tmp t t))))
;; Mark %() embedded elisp for later evaluation.
(org-capture-expand-embedded-elisp 'mark)
;; %() embedded elisp
(org-capture-expand-embedded-elisp)
;; Simple %-escapes. `org-capture-escaped-%' may modify
;; buffer and cripple match-data. Use markers instead.
(while (re-search-forward "%\\([a-zA-Z]+\\)" nil t)
(let ((key (match-string 1))
(beg (copy-marker (match-beginning 0)))
(end (copy-marker (match-end 0))))
(unless (org-capture-escaped-%)
(delete-region beg end)
(set-marker beg nil)
(set-marker end nil)
(let ((replacement
(pcase key
("h" v-h)
("t" v-t)
("T" v-T)
("u" v-u)
("U" v-U)
("a" v-a)
(name
(let ((v (plist-get entry (intern (concat ":" name)))))
(save-excursion
(save-match-data
(beginning-of-line)
(if (looking-at
(concat "^\\([ \t]*\\)%" name "[ \t]*$"))
(org-feed-make-indented-block
v (org-get-indentation))
v))))))))
(when replacement
(insert
;; Escape string delimiters within embedded lisp.
(if (org-capture-inside-embedded-elisp-p)
(replace-regexp-in-string "\"" "\\\\\"" replacement)
replacement)))))))
(decode-coding-string
(buffer-string) (detect-coding-region (point-min) (point-max) t))))))
;; %() embedded elisp
(org-capture-expand-embedded-elisp)
(decode-coding-string
(buffer-string) (detect-coding-region (point-min) (point-max) t))))))
(defun org-feed-make-indented-block (s n)
"Add indentation of N spaces to a multiline string S."
(if (not (string-match "\n" s))
s
(mapconcat 'identity
(org-split-string s "\n")
(concat "\n" (make-string n ?\ )))))
(org-split-string s "\n")
(concat "\n" (make-string n ?\ )))))
(defun org-feed-skip-http-headers (buffer)
"Remove HTTP headers from BUFFER, and return it.
@ -605,6 +613,7 @@ Assumes headers are indeed present!"
"Parse BUFFER for RSS feed entries.
Returns a list of entries, with each entry a property list,
containing the properties `:guid' and `:item-full-text'."
(require 'xml)
(let ((case-fold-search t)
entries beg end item guid entry)
(with-current-buffer buffer
@ -616,7 +625,7 @@ containing the properties `:guid' and `:item-full-text'."
(match-beginning 0)))
(setq item (buffer-substring beg end)
guid (if (string-match "<guid\\>.*?>\\(.*?\\)</guid>" item)
(org-match-string-no-properties 1 item)))
(xml-substitute-special (match-string-no-properties 1 item))))
(setq entry (list :guid guid :item-full-text item))
(push entry entries)
(widen)

1196
lisp/org/org-footnote.el
View file

File diff suppressed because it is too large Load diff

62
lisp/org/org-gnus.el
View file

@ -1,4 +1,4 @@
;;; org-gnus.el --- Support for links to Gnus groups and messages from within Org-mode
;;; org-gnus.el --- Support for Links to Gnus Groups and Messages -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2017 Free Software Foundation, Inc.
@ -25,8 +25,8 @@
;;
;;; Commentary:
;; This file implements links to Gnus groups and messages from within Org-mode.
;; Org-mode loads this module by default - if this is not what you want,
;; This file implements links to Gnus groups and messages from within Org.
;; Org mode loads this module by default - if this is not what you want,
;; configure the variable `org-modules'.
;;; Code:
@ -36,18 +36,20 @@
(eval-when-compile (require 'gnus-sum))
;; Declare external functions and variables
(declare-function message-fetch-field "message" (header &optional not-all))
(declare-function message-narrow-to-head-1 "message" nil)
;; The following line suppresses a compiler warning stemming from gnus-sum.el
(declare-function gnus-summary-last-subject "gnus-sum" nil)
(declare-function nnvirtual-map-article "nnvirtual" (article))
;; Customization variables
(org-defvaralias 'org-usenet-links-prefer-google 'org-gnus-prefer-web-links)
(defvaralias 'org-usenet-links-prefer-google 'org-gnus-prefer-web-links)
(defcustom org-gnus-prefer-web-links nil
"If non-nil, `org-store-link' creates web links to Google groups or Gmane.
When nil, Gnus will be used for such links.
Using a prefix arg to the command \\[org-store-link] (`org-store-link')
\\<org-mode-map>When nil, Gnus will be used for such links.
Using a prefix argument to the command `\\[org-store-link]' (`org-store-link')
negates this setting for the duration of the command."
:group 'org-link-store
:type 'boolean)
@ -72,20 +74,21 @@ this variable to t."
:type 'boolean)
;; Install the link type
(org-add-link-type "gnus" 'org-gnus-open)
(add-hook 'org-store-link-functions 'org-gnus-store-link)
(org-link-set-parameters "gnus" :follow #'org-gnus-open :store #'org-gnus-store-link)
;; Implementation
;; FIXME: nnimap-group-overview-filename was removed from Gnus in
;; September 2010. Perhaps remove this function?
(defun org-gnus-nnimap-cached-article-number (group server message-id)
"Return cached article number (uid) of message in GROUP on SERVER.
MESSAGE-ID is the message-id header field that identifies the
message. If the uid is not cached, return nil."
(with-temp-buffer
(let ((nov (nnimap-group-overview-filename group server)))
(when (file-exists-p nov)
(let ((nov (and (fboundp 'nnimap-group-overview-filename)
;; nnimap-group-overview-filename was removed from
;; Gnus in September 2010, and therefore should
;; only be present in Emacs 23.1.
(nnimap-group-overview-filename group server))))
(when (and nov (file-exists-p nov))
(mm-insert-file-contents nov)
(set-buffer-modified-p nil)
(goto-char (point-min))
@ -104,7 +107,7 @@ Otherwise create a link to the group inside Gnus.
If `org-store-link' was called with a prefix arg the meaning of
`org-gnus-prefer-web-links' is reversed."
(let ((unprefixed-group (replace-regexp-in-string "^[^:]+:" "" group)))
(if (and (string-match "^nntp" group) ;; Only for nntp groups
(if (and (string-prefix-p "nntp" group) ;; Only for nntp groups
(org-xor current-prefix-arg
org-gnus-prefer-web-links))
(concat (if (string-match "gmane" unprefixed-group)
@ -156,21 +159,17 @@ If `org-store-link' was called with a prefix arg the meaning of
(header (with-current-buffer gnus-summary-buffer
(gnus-summary-article-header)))
(from (mail-header-from header))
(message-id (org-remove-angle-brackets (mail-header-id header)))
(message-id (org-unbracket-string "<" ">" (mail-header-id header)))
(date (org-trim (mail-header-date header)))
(date-ts (and date
(ignore-errors
(format-time-string
(org-time-stamp-format t)
(date-to-time date)))))
(date-ts-ia (and date
(ignore-errors
(format-time-string
(org-time-stamp-format t t)
(date-to-time date)))))
(subject (copy-sequence (mail-header-subject header)))
(to (cdr (assq 'To (mail-header-extra header))))
newsgroups x-no-archive desc link)
(cl-case (car (gnus-find-method-for-group gnus-newsgroup-name))
(nnvirtual
(setq group (car (nnvirtual-map-article
(gnus-summary-article-number)))))
(nnir
(setq group (nnir-article-group (gnus-summary-article-number)))))
;; Remove text properties of subject string to avoid Emacs bug
;; #3506
(set-text-properties 0 (length subject) nil subject)
@ -183,11 +182,8 @@ If `org-store-link' was called with a prefix arg the meaning of
(setq to (or to (gnus-fetch-original-field "To"))
newsgroups (gnus-fetch-original-field "Newsgroups")
x-no-archive (gnus-fetch-original-field "x-no-archive")))
(org-store-link-props :type "gnus" :from from :subject subject
(org-store-link-props :type "gnus" :from from :date date :subject subject
:message-id message-id :group group :to to)
(when date
(org-add-link-props :date date :date-timestamp date-ts
:date-timestamp-inactive date-ts-ia))
(setq desc (org-email-link-description)
link (org-gnus-article-link
group newsgroups message-id x-no-archive))
@ -206,7 +202,7 @@ If `org-store-link' was called with a prefix arg the meaning of
(let ((gcc (car (last
(message-unquote-tokens
(message-tokenize-header (mail-fetch-field "gcc" nil t) " ,")))))
(id (org-remove-angle-brackets (mail-fetch-field "Message-ID")))
(id (org-unbracket-string "<" ">" (mail-fetch-field "Message-ID")))
(to (mail-fetch-field "To"))
(from (mail-fetch-field "From"))
(subject (mail-fetch-field "Subject"))
@ -250,10 +246,8 @@ If `org-store-link' was called with a prefix arg the meaning of
(require 'gnus)
(funcall (cdr (assq 'gnus org-link-frame-setup)))
(if gnus-other-frame-object (select-frame gnus-other-frame-object))
(when group
(setq group (org-no-properties group)))
(when article
(setq article (org-no-properties article)))
(setq group (org-no-properties group))
(setq article (org-no-properties article))
(cond ((and group article)
(gnus-activate-group group)
(condition-case nil

120
lisp/org/org-habit.el
View file

@ -1,4 +1,4 @@
;;; org-habit.el --- The habit tracking code for Org-mode
;;; org-habit.el --- The habit tracking code for Org -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
@ -24,18 +24,16 @@
;;
;;; Commentary:
;; This file contains the habit tracking code for Org-mode
;; This file contains the habit tracking code for Org mode
;;; Code:
(require 'cl-lib)
(require 'org)
(require 'org-agenda)
(eval-when-compile
(require 'cl))
(defgroup org-habit nil
"Options concerning habit tracking in Org-mode."
"Options concerning habit tracking in Org mode."
:tag "Org Habit"
:group 'org-progress)
@ -165,16 +163,17 @@ Returns a list with the following elements:
2: Optional deadline (nil if not present)
3: If deadline, the repeater for the deadline, otherwise nil
4: A list of all the past dates this todo was mark closed
5: Repeater type as a string
This list represents a \"habit\" for the rest of this module."
(save-excursion
(if pom (goto-char pom))
(assert (org-is-habit-p (point)))
(cl-assert (org-is-habit-p (point)))
(let* ((scheduled (org-get-scheduled-time (point)))
(scheduled-repeat (org-get-repeat org-scheduled-string))
(end (org-entry-end-position))
(habit-entry (org-no-properties (nth 4 (org-heading-components))))
closed-dates deadline dr-days sr-days)
closed-dates deadline dr-days sr-days sr-type)
(if scheduled
(setq scheduled (time-to-days scheduled))
(error "Habit %s has no scheduled date" habit-entry))
@ -182,7 +181,9 @@ This list represents a \"habit\" for the rest of this module."
(error
"Habit `%s' has no scheduled repeat period or has an incorrect one"
habit-entry))
(setq sr-days (org-habit-duration-to-days scheduled-repeat))
(setq sr-days (org-habit-duration-to-days scheduled-repeat)
sr-type (progn (string-match "[\\.+]?\\+" scheduled-repeat)
(match-string-no-properties 0 scheduled-repeat)))
(unless (> sr-days 0)
(error "Habit %s scheduled repeat period is less than 1d" habit-entry))
(when (string-match "/\\([0-9]+[dwmy]\\)" scheduled-repeat)
@ -197,17 +198,33 @@ This list represents a \"habit\" for the rest of this module."
(reversed org-log-states-order-reversed)
(search (if reversed 're-search-forward 're-search-backward))
(limit (if reversed end (point)))
(count 0))
(count 0)
(re (format
"^[ \t]*-[ \t]+\\(?:State \"%s\".*%s%s\\)"
(regexp-opt org-done-keywords)
org-ts-regexp-inactive
(let ((value (cdr (assq 'done org-log-note-headings))))
(if (not value) ""
(concat "\\|"
(org-replace-escapes
(regexp-quote value)
`(("%d" . ,org-ts-regexp-inactive)
("%D" . ,org-ts-regexp)
("%s" . "\"\\S-+\"")
("%S" . "\"\\S-+\"")
("%t" . ,org-ts-regexp-inactive)
("%T" . ,org-ts-regexp)
("%u" . ".*?")
("%U" . ".*?")))))))))
(unless reversed (goto-char end))
(while (and (< count maxdays)
(funcall search (format "- State \"%s\".*\\[\\([^]]+\\)\\]"
(regexp-opt org-done-keywords))
limit t))
(while (and (< count maxdays) (funcall search re limit t))
(push (time-to-days
(org-time-string-to-time (match-string-no-properties 1)))
(org-time-string-to-time
(or (match-string-no-properties 1)
(match-string-no-properties 2))))
closed-dates)
(setq count (1+ count))))
(list scheduled sr-days deadline dr-days closed-dates))))
(list scheduled sr-days deadline dr-days closed-dates sr-type))))
(defsubst org-habit-scheduled (habit)
(nth 0 habit))
@ -225,6 +242,8 @@ This list represents a \"habit\" for the rest of this module."
(org-habit-scheduled-repeat habit)))
(defsubst org-habit-done-dates (habit)
(nth 4 habit))
(defsubst org-habit-repeat-type (habit)
(nth 5 habit))
(defsubst org-habit-get-priority (habit &optional moment)
"Determine the relative priority of a habit.
@ -265,7 +284,6 @@ Habits are assigned colors on the following basis:
schedule's repeat period."
(let* ((scheduled (or scheduled-days (org-habit-scheduled habit)))
(s-repeat (org-habit-scheduled-repeat habit))
(scheduled-end (+ scheduled (1- s-repeat)))
(d-repeat (org-habit-deadline-repeat habit))
(deadline (if scheduled-days
(+ scheduled-days (- d-repeat s-repeat))
@ -289,13 +307,14 @@ Habits are assigned colors on the following basis:
CURRENT gives the current time between STARTING and ENDING, for
the purpose of drawing the graph. It need not be the actual
current time."
(let* ((done-dates (sort (org-habit-done-dates habit) '<))
(let* ((all-done-dates (sort (org-habit-done-dates habit) #'<))
(done-dates all-done-dates)
(scheduled (org-habit-scheduled habit))
(s-repeat (org-habit-scheduled-repeat habit))
(start (time-to-days starting))
(now (time-to-days current))
(end (time-to-days ending))
(graph (make-string (1+ (- end start)) ?\ ))
(graph (make-string (1+ (- end start)) ?\s))
(index 0)
last-done-date)
(while (and done-dates (< (car done-dates) start))
@ -304,18 +323,55 @@ current time."
(while (< start end)
(let* ((in-the-past-p (< start now))
(todayp (= start now))
(donep (and done-dates
(= start (car done-dates))))
(faces (if (and in-the-past-p
(not last-done-date)
(not (< scheduled now)))
'(org-habit-clear-face . org-habit-clear-future-face)
(org-habit-get-faces
habit start (and in-the-past-p
(if last-done-date
(+ last-done-date s-repeat)
scheduled))
donep)))
(donep (and done-dates (= start (car done-dates))))
(faces
(if (and in-the-past-p
(not last-done-date)
(not (< scheduled now)))
'(org-habit-clear-face . org-habit-clear-future-face)
(org-habit-get-faces
habit start
(and in-the-past-p
last-done-date
;; Compute scheduled time for habit at the time
;; START was current.
(let ((type (org-habit-repeat-type habit)))
(cond
;; At the last done date, use current
;; scheduling in all cases.
((null done-dates) scheduled)
((equal type ".+") (+ last-done-date s-repeat))
((equal type "+")
;; Since LAST-DONE-DATE, each done mark
;; shifted scheduled date by S-REPEAT.
(- scheduled (* (length done-dates) s-repeat)))
(t
;; Compute the scheduled time after the
;; first repeat. This is the closest time
;; past FIRST-DONE which can reach SCHEDULED
;; by a number of S-REPEAT hops.
;;
;; Then, play TODO state change history from
;; the beginning in order to find current
;; scheduled time.
(let* ((first-done (car all-done-dates))
(s (let ((shift (mod (- scheduled first-done)
s-repeat)))
(+ (if (= shift 0) s-repeat shift)
first-done))))
(if (= first-done last-done-date) s
(catch :exit
(dolist (done (cdr all-done-dates) s)
;; Each repeat shifts S by any
;; number of S-REPEAT hops it takes
;; to get past DONE, with a minimum
;; of one hop.
(cl-incf s (* (1+ (/ (max (- done s) 0)
s-repeat))
s-repeat))
(when (= done last-done-date)
(throw :exit s))))))))))
donep)))
markedp face)
(if donep
(let ((done-time (time-add
@ -348,7 +404,7 @@ current time."
(defun org-habit-insert-consistency-graphs (&optional line)
"Insert consistency graph for any habitual tasks."
(let ((inhibit-read-only t) l c
(let ((inhibit-read-only t)
(buffer-invisibility-spec '(org-link))
(moment (time-subtract (current-time)
(list 0 (* 3600 org-extend-today-until) 0))))

28
lisp/org/org-id.el
View file

@ -1,4 +1,4 @@
;;; org-id.el --- Global identifiers for Org-mode entries
;;; org-id.el --- Global identifiers for Org entries -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2008-2017 Free Software Foundation, Inc.
;;
@ -24,7 +24,7 @@
;;
;;; Commentary:
;; This file implements globally unique identifiers for Org-mode entries.
;; This file implements globally unique identifiers for Org entries.
;; Identifiers are stored in the entry as an :ID: property. Functions
;; are provided that create and retrieve such identifiers, and that find
;; entries based on the identifier.
@ -73,20 +73,17 @@
(require 'org)
(declare-function message-make-fqdn "message" ())
(declare-function org-pop-to-buffer-same-window
"org-compat" (&optional buffer-or-name norecord label))
;;; Customization
(defgroup org-id nil
"Options concerning global entry identifiers in Org-mode."
"Options concerning global entry identifiers in Org mode."
:tag "Org ID"
:group 'org)
(define-obsolete-variable-alias
'org-link-to-org-use-id 'org-id-link-to-org-use-id "24.3")
(defcustom org-id-link-to-org-use-id nil
"Non-nil means storing a link to an Org file will use entry IDs.
\\<org-mode-map>\
The variable can have the following values:
@ -101,7 +98,7 @@ create-if-interactive
call `org-capture' that automatically and preemptively creates a
link. If you do want to get an ID link in a capture template to
an entry not having an ID, create it first by explicitly creating
a link to it, using `C-c C-l' first.
a link to it, using `\\[org-store-link]' first.
create-if-interactive-and-no-custom-id
Like create-if-interactive, but do not create an ID if there is
@ -203,7 +200,7 @@ This variable is only relevant when `org-id-track-globally' is set."
When Org reparses files to remake the list of files and IDs it is tracking,
it will normally scan the agenda files, the archives related to agenda files,
any files that are listed as ID containing in the current register, and
any Org-mode files currently visited by Emacs.
any Org file currently visited by Emacs.
You can list additional files here.
This variable is only relevant when `org-id-track-globally' is set."
:group 'org-id
@ -277,7 +274,7 @@ If necessary, the ID is created."
(move-marker pom nil))))
;;;###autoload
(defun org-id-get-with-outline-drilling (&optional targets)
(defun org-id-get-with-outline-drilling ()
"Use an outline-cycling interface to retrieve the ID of an entry.
This only finds entries in the current buffer, using `org-get-location'.
It returns the ID of the entry. If necessary, the ID is created."
@ -294,7 +291,7 @@ Move the cursor to that entry in that buffer."
(let ((m (org-id-find id 'marker)))
(unless m
(error "Cannot find entry with ID \"%s\"" id))
(org-pop-to-buffer-same-window (marker-buffer m))
(pop-to-buffer-same-window (marker-buffer m))
(goto-char m)
(move-marker m nil)
(org-show-context)))
@ -447,8 +444,7 @@ and time is the usual three-integer representation of time."
Store the relation between files and corresponding IDs.
This will scan all agenda files, all associated archives, and all
files currently mentioned in `org-id-locations'.
When FILES is given, scan these files instead.
When CHECK is given, prepare detailed information about duplicate IDs."
When FILES is given, scan these files instead."
(interactive)
(if (not org-id-track-globally)
(error "Please turn on `org-id-track-globally' if you want to track IDs")
@ -466,7 +462,7 @@ When CHECK is given, prepare detailed information about duplicate IDs."
(if (symbolp org-id-extra-files)
(symbol-value org-id-extra-files)
org-id-extra-files)
;; Files associated with live org-mode buffers
;; Files associated with live Org buffers
(delq nil
(mapcar (lambda (b)
(with-current-buffer b
@ -494,7 +490,7 @@ When CHECK is given, prepare detailed information about duplicate IDs."
(goto-char (point-min))
(while (re-search-forward "^[ \t]*:ID:[ \t]+\\(\\S-+\\)[ \t]*$"
nil t)
(setq id (org-match-string-no-properties 1))
(setq id (match-string-no-properties 1))
(if (member id found)
(progn
(message "Duplicate ID \"%s\", also in file %s"
@ -678,7 +674,7 @@ optional argument MARKERP, return the position as a new marker."
(move-marker m nil)
(org-show-context)))
(org-add-link-type "id" 'org-id-open)
(org-link-set-parameters "id" :follow #'org-id-open)
(provide 'org-id)

289
lisp/org/org-indent.el
View file

@ -1,4 +1,5 @@
;;; org-indent.el --- Dynamic indentation for Org-mode
;;; org-indent.el --- Dynamic indentation for Org -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten at orgmode dot org>
@ -39,8 +40,7 @@
(require 'org-compat)
(require 'org)
(eval-when-compile
(require 'cl))
(require 'cl-lib)
(declare-function org-inlinetask-get-task-level "org-inlinetask" ())
(declare-function org-inlinetask-in-task-p "org-inlinetask" ())
@ -52,20 +52,6 @@
:tag "Org Indent"
:group 'org)
(defconst org-indent-max 40
"Maximum indentation in characters.")
(defconst org-indent-max-levels 20
"Maximum added level through virtual indentation, in characters.
It is computed by multiplying `org-indent-indentation-per-level'
minus one by actual level of the headline minus one.")
(defvar org-indent-strings nil
"Vector with all indentation strings.
It will be set in `org-indent-initialize'.")
(defvar org-indent-stars nil
"Vector with all indentation star strings.
It will be set in `org-indent-initialize'.")
(defvar org-indent-inlinetask-first-star (org-add-props "*" '(face org-warning))
"First star of inline tasks, with correct face.")
(defvar org-indent-agent-timer nil
@ -82,7 +68,7 @@ Delay used when the buffer to initialize is current.")
Delay used when the buffer to initialize isn't current.")
(defvar org-indent-agent-resume-delay '(0 0 100000)
"Minimal time for other idle processes before switching back to agent.")
(defvar org-indent-initial-marker nil
(defvar org-indent--initial-marker nil
"Position of initialization before interrupt.
This is used locally in each buffer being initialized.")
(defvar org-hide-leading-stars-before-indent-mode nil
@ -92,15 +78,12 @@ This is used locally in each buffer being initialized.")
It is modified by `org-indent-notify-modified-headline'.")
(defcustom org-indent-boundary-char ?\ ; comment to protect space char
(defcustom org-indent-boundary-char ?\s
"The end of the virtual indentation strings, a single-character string.
The default is just a space, but if you wish, you can use \"|\" or so.
This can be useful on a terminal window - under a windowing system,
it may be prettier to customize the org-indent face."
it may be prettier to customize the `org-indent' face."
:group 'org-indent
:set (lambda (var val)
(set var val)
(and org-indent-strings (org-indent-initialize)))
:type 'character)
(defcustom org-indent-mode-turns-off-org-adapt-indentation t
@ -121,29 +104,56 @@ turn on `org-hide-leading-stars'."
:group 'org-indent
:type 'integer)
(defface org-indent
(org-compatible-face nil nil)
(defface org-indent '((t (:inherit org-hide)))
"Face for outline indentation.
The default is to make it look like whitespace. But you may find it
useful to make it ever so slightly different."
:group 'org-faces)
(defun org-indent-initialize ()
"Initialize the indentation strings."
(setq org-indent-strings (make-vector (1+ org-indent-max) nil))
(setq org-indent-stars (make-vector (1+ org-indent-max) nil))
(aset org-indent-strings 0 nil)
(aset org-indent-stars 0 nil)
(loop for i from 1 to org-indent-max do
(aset org-indent-strings i
(org-add-props
(concat (make-string (1- i) ?\ )
(char-to-string org-indent-boundary-char))
(defvar org-indent--text-line-prefixes nil
"Vector containing line prefixes strings for regular text.")
(defvar org-indent--heading-line-prefixes nil
"Vector containing line prefix strings for headlines.")
(defvar org-indent--inlinetask-line-prefixes nil
"Vector containing line prefix strings for inline tasks.")
(defconst org-indent--deepest-level 50
"Maximum theoretical headline depth.")
(defun org-indent--compute-prefixes ()
"Compute prefix strings for regular text and headlines."
(setq org-indent--heading-line-prefixes
(make-vector org-indent--deepest-level nil))
(setq org-indent--inlinetask-line-prefixes
(make-vector org-indent--deepest-level nil))
(setq org-indent--text-line-prefixes
(make-vector org-indent--deepest-level nil))
(dotimes (n org-indent--deepest-level)
(let ((indentation (if (<= n 1) 0
(* (1- org-indent-indentation-per-level)
(1- n)))))
;; Headlines line prefixes.
(let ((heading-prefix (make-string indentation ?*)))
(aset org-indent--heading-line-prefixes
n
(org-add-props heading-prefix nil 'face 'org-indent))
;; Inline tasks line prefixes
(aset org-indent--inlinetask-line-prefixes
n
(org-add-props (if (bound-and-true-p org-inlinetask-show-first-star)
(concat org-indent-inlinetask-first-star
(substring heading-prefix 1))
heading-prefix)
nil 'face 'org-indent)))
(loop for i from 1 to org-indent-max-levels do
(aset org-indent-stars i
(org-add-props (make-string i ?*)
nil 'face 'org-hide))))
;; Text line prefixes.
(aset org-indent--text-line-prefixes
n
(concat (org-add-props (make-string (+ n indentation) ?\s)
nil 'face 'org-indent)
(and (> n 0)
(char-to-string org-indent-boundary-char)))))))
(defsubst org-indent-remove-properties (beg end)
"Remove indentations between BEG and END."
@ -162,34 +172,25 @@ buffer, which can take a few seconds on large buffers, is done
during idle time."
nil " Ind" nil
(cond
((and org-indent-mode (featurep 'xemacs))
(message "org-indent-mode does not work in XEmacs - refusing to turn it on")
(setq org-indent-mode nil))
((and org-indent-mode
(not (org-version-check "23.1.50" "Org Indent mode" :predicate)))
(message "org-indent-mode can crash Emacs 23.1 - refusing to turn it on!")
(ding)
(sit-for 1)
(setq org-indent-mode nil))
(org-indent-mode
;; mode was turned on.
(org-set-local 'indent-tabs-mode nil)
(or org-indent-strings (org-indent-initialize))
(org-set-local 'org-indent-initial-marker (copy-marker 1))
(setq-local indent-tabs-mode nil)
(setq-local org-indent--initial-marker (copy-marker 1))
(when org-indent-mode-turns-off-org-adapt-indentation
(org-set-local 'org-adapt-indentation nil))
(setq-local org-adapt-indentation nil))
(when org-indent-mode-turns-on-hiding-stars
(org-set-local 'org-hide-leading-stars-before-indent-mode
org-hide-leading-stars)
(org-set-local 'org-hide-leading-stars t))
(org-add-hook 'filter-buffer-substring-functions
(lambda (fun start end delete)
(org-indent-remove-properties-from-string
(funcall fun start end delete)))
nil t)
(org-add-hook 'after-change-functions 'org-indent-refresh-maybe nil 'local)
(org-add-hook 'before-change-functions
'org-indent-notify-modified-headline nil 'local)
(setq-local org-hide-leading-stars-before-indent-mode
org-hide-leading-stars)
(setq-local org-hide-leading-stars t))
(org-indent--compute-prefixes)
(add-hook 'filter-buffer-substring-functions
(lambda (fun start end delete)
(org-indent-remove-properties-from-string
(funcall fun start end delete)))
nil t)
(add-hook 'after-change-functions 'org-indent-refresh-maybe nil 'local)
(add-hook 'before-change-functions
'org-indent-notify-modified-headline nil 'local)
(and font-lock-mode (org-restart-font-lock))
(org-indent-remove-properties (point-min) (point-max))
;; Submit current buffer to initialize agent. If it's the first
@ -205,11 +206,11 @@ during idle time."
(kill-local-variable 'org-adapt-indentation)
(setq org-indent-agentized-buffers
(delq (current-buffer) org-indent-agentized-buffers))
(when (markerp org-indent-initial-marker)
(set-marker org-indent-initial-marker nil))
(when (markerp org-indent--initial-marker)
(set-marker org-indent--initial-marker nil))
(when (boundp 'org-hide-leading-stars-before-indent-mode)
(org-set-local 'org-hide-leading-stars
org-hide-leading-stars-before-indent-mode))
(setq-local org-hide-leading-stars
org-hide-leading-stars-before-indent-mode))
(remove-hook 'filter-buffer-substring-functions
(lambda (fun start end delete)
(org-indent-remove-properties-from-string
@ -245,7 +246,7 @@ When no more buffer is being watched, the agent suppress itself."
(when org-indent-agent-resume-timer
(cancel-timer org-indent-agent-resume-timer))
(setq org-indent-agentized-buffers
(org-remove-if-not #'buffer-live-p org-indent-agentized-buffers))
(cl-remove-if-not #'buffer-live-p org-indent-agentized-buffers))
(cond
;; Job done: kill agent.
((not org-indent-agentized-buffers) (cancel-timer org-indent-agent-timer))
@ -269,46 +270,44 @@ a time value."
(let ((interruptp
;; Always nil unless interrupted.
(catch 'interrupt
(and org-indent-initial-marker
(marker-position org-indent-initial-marker)
(org-indent-add-properties org-indent-initial-marker
(and org-indent--initial-marker
(marker-position org-indent--initial-marker)
(equal (marker-buffer org-indent--initial-marker)
buffer)
(org-indent-add-properties org-indent--initial-marker
(point-max)
delay)
nil))))
(move-marker org-indent-initial-marker interruptp)
(move-marker org-indent--initial-marker interruptp)
;; Job is complete: un-agentize buffer.
(unless interruptp
(setq org-indent-agentized-buffers
(delq buffer org-indent-agentized-buffers))))))))
(defsubst org-indent-set-line-properties (l w h)
(defun org-indent-set-line-properties (level indentation &optional heading)
"Set prefix properties on current line an move to next one.
Prefix properties `line-prefix' and `wrap-prefix' in current line
are set to, respectively, length L and W.
LEVEL is the current level of heading. INDENTATION is the
expected indentation when wrapping line.
If H is non-nil, `line-prefix' will be starred. If H is
`inline', the first star will have `org-warning' face.
Assume point is at beginning of line."
(let ((line (cond
((eq 'inline h)
(let ((stars (aref org-indent-stars
(min l org-indent-max-levels))))
(and stars
(if (org-bound-and-true-p org-inlinetask-show-first-star)
(concat org-indent-inlinetask-first-star
(substring stars 1))
stars))))
(h (aref org-indent-stars
(min l org-indent-max-levels)))
(t (aref org-indent-strings
(min l org-indent-max)))))
(wrap (aref org-indent-strings (min w org-indent-max))))
When optional argument HEADING is non-nil, assume line is at
a heading. Moreover, if is is `inlinetask', the first star will
have `org-warning' face."
(let* ((line (aref (pcase heading
(`nil org-indent--text-line-prefixes)
(`inlinetask org-indent--inlinetask-line-prefixes)
(_ org-indent--heading-line-prefixes))
level))
(wrap
(org-add-props
(concat line
(if heading (concat (make-string level ?*) " ")
(make-string indentation ?\s)))
nil 'face 'org-indent)))
;; Add properties down to the next line to indent empty lines.
(add-text-properties (point) (min (1+ (point-at-eol)) (point-max))
(add-text-properties (line-beginning-position) (line-beginning-position 2)
`(line-prefix ,line wrap-prefix ,wrap)))
(forward-line 1))
(forward-line))
(defun org-indent-add-properties (beg end &optional delay)
"Add indentation properties between BEG and END.
@ -322,26 +321,14 @@ stopped."
(org-with-wide-buffer
(goto-char beg)
(beginning-of-line)
;; 1. Initialize prefix at BEG. This is done by storing two
;; variables: INLINE-PF and PF, representing respectively
;; length of current `line-prefix' when line is inside an
;; inline task or not.
;; Initialize prefix at BEG, according to current entry's level.
(let* ((case-fold-search t)
(limited-re (org-get-limited-outline-regexp))
(added-ind-per-lvl (abs (1- org-indent-indentation-per-level)))
(pf (save-excursion
(and (ignore-errors (let ((outline-regexp limited-re))
(org-back-to-heading t)))
(+ (* org-indent-indentation-per-level
(- (match-end 0) (match-beginning 0) 2)) 2))))
(pf-inline (and (featurep 'org-inlinetask)
(org-inlinetask-in-task-p)
(+ (* org-indent-indentation-per-level
(1- (org-inlinetask-get-task-level))) 2)))
(level (or (org-current-level) 0))
(time-limit (and delay (time-add (current-time) delay))))
;; 2. For each line, set `line-prefix' and `wrap-prefix'
;; properties depending on the type of line (headline,
;; inline task, item or other).
;; For each line, set `line-prefix' and `wrap-prefix'
;; properties depending on the type of line (headline, inline
;; task, item or other).
(org-with-silent-modifications
(while (and (<= (point) end) (not (eobp)))
(cond
@ -354,38 +341,23 @@ stopped."
((and delay (time-less-p time-limit (current-time)))
(setq org-indent-agent-resume-timer
(run-with-idle-timer
(time-add (current-idle-time)
org-indent-agent-resume-delay)
(time-add (current-idle-time) org-indent-agent-resume-delay)
nil #'org-indent-initialize-agent))
(throw 'interrupt (point)))
;; Headline or inline task.
((looking-at org-outline-regexp)
(let* ((nstars (- (match-end 0) (match-beginning 0) 1))
(line (* added-ind-per-lvl (1- nstars)))
(wrap (+ line (1+ nstars))))
(cond
;; Headline: new value for PF.
((looking-at limited-re)
(org-indent-set-line-properties line wrap t)
(setq pf wrap))
;; End of inline task: PF-INLINE is now nil.
((looking-at "\\*+ end[ \t]*$")
(org-indent-set-line-properties line wrap 'inline)
(setq pf-inline nil))
;; Start of inline task. Determine if it contains
;; text, or if it is only one line long. Set
;; PF-INLINE accordingly.
(t (org-indent-set-line-properties line wrap 'inline)
(setq pf-inline (and (org-inlinetask-in-task-p) wrap))))))
(type (or (looking-at-p limited-re) 'inlinetask)))
(org-indent-set-line-properties nstars 0 type)
;; At an headline, define new value for LEVEL.
(unless (eq type 'inlinetask) (setq level nstars))))
;; List item: `wrap-prefix' is set where body starts.
((org-at-item-p)
(let* ((line (or pf-inline pf 0))
(wrap (+ (org-list-item-body-column (point)) line)))
(org-indent-set-line-properties line wrap nil)))
;; Normal line: use PF-INLINE, PF or nil as prefixes.
(t (let* ((line (or pf-inline pf 0))
(wrap (+ line (org-get-indentation))))
(org-indent-set-line-properties line wrap nil))))))))))
(org-indent-set-line-properties
level (org-list-item-body-column (point))))
;; Regular line.
(t
(org-indent-set-line-properties level (org-get-indentation))))))))))
(defun org-indent-notify-modified-headline (beg end)
"Set `org-indent-modified-headline-flag' depending on context.
@ -398,13 +370,14 @@ Flag will be non-nil if command is going to modify or delete an
headline."
(when org-indent-mode
(setq org-indent-modified-headline-flag
(save-excursion
(goto-char beg)
(save-match-data
(or (and (org-at-heading-p) (< beg (match-end 0)))
(re-search-forward org-outline-regexp-bol end t)))))))
(org-with-wide-buffer
(goto-char beg)
(save-match-data
(or (and (org-at-heading-p) (< beg (match-end 0)))
(re-search-forward
(org-with-limited-levels org-outline-regexp-bol) end t)))))))
(defun org-indent-refresh-maybe (beg end dummy)
(defun org-indent-refresh-maybe (beg end _)
"Refresh indentation properties in an adequate portion of buffer.
BEG and END are the positions of the beginning and end of the
range of inserted text. DUMMY is an unused argument.
@ -414,19 +387,21 @@ This function is meant to be called by `after-change-functions'."
(save-match-data
;; If a headline was modified or inserted, set properties until
;; next headline.
(if (or org-indent-modified-headline-flag
(save-excursion
(goto-char beg)
(beginning-of-line)
(re-search-forward org-outline-regexp-bol end t)))
(let ((end (save-excursion
(goto-char end)
(org-with-limited-levels (outline-next-heading))
(point))))
(setq org-indent-modified-headline-flag nil)
(org-indent-add-properties beg end))
;; Otherwise, only set properties on modified area.
(org-indent-add-properties beg end)))))
(org-with-wide-buffer
(if (or org-indent-modified-headline-flag
(save-excursion
(goto-char beg)
(beginning-of-line)
(re-search-forward
(org-with-limited-levels org-outline-regexp-bol) end t)))
(let ((end (save-excursion
(goto-char end)
(org-with-limited-levels (outline-next-heading))
(point))))
(setq org-indent-modified-headline-flag nil)
(org-indent-add-properties beg end))
;; Otherwise, only set properties on modified area.
(org-indent-add-properties beg end))))))
(provide 'org-indent)

97
lisp/org/org-info.el
View file

@ -1,4 +1,4 @@
;;; org-info.el --- Support for links to Info nodes from within Org-Mode
;;; org-info.el --- Support for Links to Info Nodes -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2017 Free Software Foundation, Inc.
@ -24,8 +24,8 @@
;;
;;; Commentary:
;; This file implements links to Info nodes from within Org-mode.
;; Org-mode loads this module by default - if this is not what you want,
;; This file implements links to Info nodes from within Org mode.
;; Org mode loads this module by default - if this is not what you want,
;; configure the variable `org-modules'.
;;; Code:
@ -40,19 +40,20 @@
(defvar Info-current-node)
;; Install the link type
(org-add-link-type "info" 'org-info-open)
(add-hook 'org-store-link-functions 'org-info-store-link)
(org-link-set-parameters "info"
:follow #'org-info-open
:export #'org-info-export
:store #'org-info-store-link)
;; Implementation
(defun org-info-store-link ()
"Store a link to an Info file and node."
(when (eq major-mode 'Info-mode)
(let (link desc)
(setq link (concat "info:"
(file-name-nondirectory Info-current-file)
"#" Info-current-node))
(setq desc (concat (file-name-nondirectory Info-current-file)
"#" Info-current-node))
(let ((link (concat "info:"
(file-name-nondirectory Info-current-file)
"#" Info-current-node))
(desc (concat (file-name-nondirectory Info-current-file)
"#" Info-current-node)))
(org-store-link-props :type "info" :file Info-current-file
:node Info-current-node
:link link :desc desc)
@ -67,12 +68,76 @@
"Follow an Info file and node link specified by NAME."
(if (or (string-match "\\(.*\\)[#:]:?\\(.*\\)" name)
(string-match "\\(.*\\)" name))
(progn
(let ((filename (match-string 1 name))
(nodename-or-index (or (match-string 2 name) "Top")))
(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 "Could not open: %s" name)))
;; If nodename-or-index is invalid node name, then look it up
;; in the index.
(condition-case nil
(Info-find-node filename nodename-or-index)
(user-error (Info-find-node filename "Top")
(condition-case nil
(Info-index nodename-or-index)
(user-error "Could not find '%s' node or index entry"
nodename-or-index)))))
(user-error "Could not open: %s" name)))
(defconst org-info-emacs-documents
'("ada-mode" "auth" "autotype" "bovine" "calc" "ccmode" "cl" "dbus" "dired-x"
"ebrowse" "ede" "ediff" "edt" "efaq-w32" "efaq" "eieio" "eintr" "elisp"
"emacs-gnutls" "emacs-mime" "emacs" "epa" "erc" "ert" "eshell" "eudc" "eww"
"flymake" "forms" "gnus" "htmlfontify" "idlwave" "ido" "info" "mairix-el"
"message" "mh-e" "newsticker" "nxml-mode" "octave-mode" "org" "pcl-cvs"
"pgg" "rcirc" "reftex" "remember" "sasl" "sc" "semantic" "ses" "sieve"
"smtpmail" "speedbar" "srecode" "todo-mode" "tramp" "url" "vip" "viper"
"widget" "wisent" "woman")
"List of emacs documents available.
Taken from <http://www.gnu.org/software/emacs/manual/html_mono/.>")
(defconst org-info-other-documents
'(("libc" . "http://www.gnu.org/software/libc/manual/html_mono/libc.html")
("make" . "http://www.gnu.org/software/make/manual/make.html"))
"Alist of documents generated from Texinfo source.
When converting info links to HTML, links to any one of these manuals are
converted to use these URL.")
(defun org-info-map-html-url (filename)
"Return URL or HTML file associated to Info FILENAME.
If FILENAME refers to an official GNU document, return a URL pointing to
the official page for that document, e.g., use \"gnu.org\" for all Emacs
related documents. Otherwise, append \".html\" extension to FILENAME.
See `org-info-emacs-documents' and `org-info-other-documents' for details."
(cond ((member filename org-info-emacs-documents)
(format "http://www.gnu.org/software/emacs/manual/html_mono/%s.html"
filename))
((cdr (assoc filename org-info-other-documents)))
(t (concat filename ".html"))))
(defun org-info--expand-node-name (node)
"Expand Info NODE to HTML cross reference."
;; See (info "(texinfo) HTML Xref Node Name Expansion") for the
;; expansion rule.
(let ((node (replace-regexp-in-string
"\\([ \t\n\r]+\\)\\|\\([^a-zA-Z0-9]\\)"
(lambda (m)
(if (match-end 1) "-" (format "_%04x" (string-to-char m))))
(org-trim node))))
(cond ((string= node "") "")
((string-match-p "\\`[0-9]" node) (concat "g_t" node))
(t node))))
(defun org-info-export (path desc format)
"Export an info link.
See `org-link-parameters' for details about PATH, DESC and FORMAT."
(when (eq format 'html)
(or (string-match "\\(.*\\)[#:]:?\\(.*\\)" path)
(string-match "\\(.*\\)" path))
(let ((filename (match-string 1 path))
(node (or (match-string 2 path) "Top")))
(format "<a href=\"%s#%s\">%s</a>"
(org-info-map-html-url filename)
(org-info--expand-node-name node)
(or desc path)))))
(provide 'org-info)

50
lisp/org/org-inlinetask.el
View file

@ -1,4 +1,4 @@
;;; org-inlinetask.el --- Tasks independent of outline hierarchy
;;; org-inlinetask.el --- Tasks Independent of Outline Hierarchy -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
;;
@ -26,7 +26,7 @@
;;
;;; Commentary:
;;
;; This module implements inline tasks in Org-mode. Inline tasks are
;; This module implements inline tasks in Org mode. Inline tasks are
;; tasks that have all the properties of normal outline nodes,
;; including the ability to store meta data like scheduling dates,
;; TODO state, tags and properties. However, these nodes are treated
@ -108,7 +108,6 @@ When nil, the first star is not shown."
(defvar org-odd-levels-only)
(defvar org-keyword-time-regexp)
(defvar org-drawer-regexp)
(defvar org-complex-heading-regexp)
(defvar org-property-end-re)
@ -168,9 +167,9 @@ The number of levels is controlled by `org-inlinetask-min-level'."
(stars-re (org-inlinetask-outline-regexp))
(task-beg-re (concat stars-re "\\(?:.*\\)"))
(task-end-re (concat stars-re "END[ \t]*$")))
(or (org-looking-at-p task-beg-re)
(or (looking-at-p task-beg-re)
(and (re-search-forward "^\\*+[ \t]+" nil t)
(progn (beginning-of-line) (org-looking-at-p task-end-re)))))))
(progn (beginning-of-line) (looking-at-p task-end-re)))))))
(defun org-inlinetask-goto-beginning ()
"Go to the beginning of the inline task at point."
@ -178,7 +177,7 @@ The number of levels is controlled by `org-inlinetask-min-level'."
(let ((case-fold-search t)
(inlinetask-re (org-inlinetask-outline-regexp)))
(re-search-backward inlinetask-re nil t)
(when (org-looking-at-p (concat inlinetask-re "END[ \t]*$"))
(when (looking-at-p (concat inlinetask-re "END[ \t]*$"))
(re-search-backward inlinetask-re nil t))))
(defun org-inlinetask-goto-end ()
@ -190,17 +189,16 @@ Return point."
(inlinetask-re (org-inlinetask-outline-regexp))
(task-end-re (concat inlinetask-re "END[ \t]*$")))
(cond
((looking-at task-end-re) (forward-line))
((looking-at task-end-re))
((looking-at inlinetask-re)
(forward-line)
(cond
((looking-at task-end-re) (forward-line))
((looking-at task-end-re))
((looking-at inlinetask-re))
((org-inlinetask-in-task-p)
(re-search-forward inlinetask-re nil t)
(forward-line))))
(t (re-search-forward inlinetask-re nil t)
(forward-line)))
(re-search-forward inlinetask-re nil t))))
(t (re-search-forward inlinetask-re nil t)))
(end-of-line)
(point))))
(defun org-inlinetask-get-task-level ()
@ -273,8 +271,7 @@ If the task has an end part, also demote it."
(defvar org-indent-indentation-per-level) ; defined in org-indent.el
(defface org-inlinetask
(org-compatible-face 'shadow '((t (:bold t))))
(defface org-inlinetask '((t :inherit shadow))
"Face for inlinetask headlines."
:group 'org-faces)
@ -288,7 +285,7 @@ If the task has an end part, also demote it."
",\\}\\)\\(\\*\\* .*\\)"))
;; Virtual indentation will add the warning face on the first
;; star. Thus, in that case, only hide it.
(start-face (if (and (org-bound-and-true-p org-indent-mode)
(start-face (if (and (bound-and-true-p org-indent-mode)
(> org-indent-indentation-per-level 1))
'org-hide
'org-warning)))
@ -315,19 +312,36 @@ If the task has an end part, also demote it."
;; Nothing to show/hide.
((= end start))
;; Inlinetask was folded: expand it.
((get-char-property (1+ start) 'invisible)
((eq (get-char-property (1+ start) 'invisible) 'outline)
(outline-flag-region start end nil)
(org-cycle-hide-drawers 'children))
(t (outline-flag-region start end t)))))
(defun org-inlinetask-hide-tasks (state)
"Hide inline tasks in buffer when STATE is `contents' or `children'.
This function is meant to be used in `org-cycle-hook'."
(pcase state
(`contents
(let ((regexp (org-inlinetask-outline-regexp)))
(save-excursion
(goto-char (point-min))
(while (re-search-forward regexp nil t)
(org-inlinetask-toggle-visibility)
(org-inlinetask-goto-end)))))
(`children
(save-excursion
(while (and (outline-next-heading) (org-inlinetask-at-task-p))
(org-inlinetask-toggle-visibility)
(org-inlinetask-goto-end))))))
(defun org-inlinetask-remove-END-maybe ()
"Remove an END line when present."
(when (looking-at (format "\\([ \t]*\n\\)*\\*\\{%d,\\}[ \t]+END[ \t]*$"
org-inlinetask-min-level))
(replace-match "")))
(eval-after-load "org"
'(add-hook 'org-font-lock-hook 'org-inlinetask-fontify))
(add-hook 'org-font-lock-hook 'org-inlinetask-fontify)
(add-hook 'org-cycle-hook 'org-inlinetask-hide-tasks)
(provide 'org-inlinetask)

26
lisp/org/org-irc.el
View file

@ -1,4 +1,4 @@
;;; org-irc.el --- Store links to IRC sessions
;;; org-irc.el --- Store Links to IRC Sessions -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2008-2017 Free Software Foundation, Inc.
;;
@ -22,8 +22,8 @@
;;; Commentary:
;; This file implements links to an IRC session from within Org-mode.
;; Org-mode loads this module by default - if this is not what you want,
;; This file implements links to an IRC session from within Org mode.
;; Org mode loads this module by default - if this is not what you want,
;; configure the variable `org-modules'.
;;
;; Please customize the variable `org-modules' to select
@ -59,8 +59,6 @@
(declare-function erc-server-buffer "erc" ())
(declare-function erc-get-server-nickname-list "erc" ())
(declare-function erc-cmd-JOIN "erc" (channel &optional key))
(declare-function org-pop-to-buffer-same-window
"org-compat" (&optional buffer-or-name norecord label))
(defvar org-irc-client 'erc
"The IRC client to act on.")
@ -73,9 +71,7 @@
;; Generic functions/config (extend these for other clients)
(add-to-list 'org-store-link-functions 'org-irc-store-link)
(org-add-link-type "irc" 'org-irc-visit nil)
(org-link-set-parameters "irc" :follow #'org-irc-visit :store #'org-irc-store-link)
(defun org-irc-visit (link)
"Parse LINK and dispatch to the correct function based on the client found."
@ -114,11 +110,9 @@ chars that the value AFTER with `...'"
(cons "[ \t]*$" "")
(cons (concat "^\\(.\\{" after
"\\}\\).*") "\\1..."))))
(mapc (lambda (x)
(when (string-match (car x) string)
(setq string (replace-match (cdr x) nil nil string))))
replace-map)
string))
(dolist (x replace-map string)
(when (string-match (car x) string)
(setq string (replace-match (cdr x) nil nil string))))))
;; ERC specific functions
@ -233,7 +227,7 @@ default."
(throw 'found x))))))
(if chan-buf
(progn
(org-pop-to-buffer-same-window chan-buf)
(pop-to-buffer-same-window chan-buf)
;; if we got a nick, and they're in the chan,
;; then start a chat with them
(let ((nick (pop link)))
@ -244,9 +238,9 @@ default."
(insert (concat nick ": ")))
(error "%s not found in %s" nick chan-name)))))
(progn
(org-pop-to-buffer-same-window server-buffer)
(pop-to-buffer-same-window server-buffer)
(erc-cmd-JOIN chan-name))))
(org-pop-to-buffer-same-window server-buffer)))
(pop-to-buffer-same-window server-buffer)))
;; no server match, make new connection
(erc-select :server server :port port))))

1225
lisp/org/org-lint.el Normal file
View file

File diff suppressed because it is too large Load diff

1499
lisp/org/org-list.el
View file

File diff suppressed because it is too large Load diff

259
lisp/org/org-macro.el
View file

@ -1,4 +1,4 @@
;;; org-macro.el --- Macro Replacement Code for Org Mode
;;; org-macro.el --- Macro Replacement Code for Org -*- lexical-binding: t; -*-
;; Copyright (C) 2013-2017 Free Software Foundation, Inc.
@ -30,6 +30,10 @@
;; `org-macro-initialize-templates', which recursively calls
;; `org-macro--collect-macros' in order to read setup files.
;; Argument in macros are separated with commas. Proper escaping rules
;; are implemented in `org-macro-escape-arguments' and arguments can
;; be extracted from a string with `org-macro-extract-arguments'.
;; Along with macros defined through #+MACRO: keyword, default
;; templates include the following hard-coded macros:
;; {{{time(format-string)}}}, {{{property(node-property)}}},
@ -39,19 +43,25 @@
;; {{{email}}} and {{{title}}} macros.
;;; Code:
(require 'cl-lib)
(require 'org-macs)
(require 'org-compat)
(declare-function org-element-at-point "org-element" (&optional keep-trail))
(declare-function org-element-at-point "org-element" ())
(declare-function org-element-context "org-element" (&optional element))
(declare-function org-element-macro-parser "org-element" ())
(declare-function org-element-property "org-element" (property element))
(declare-function org-element-type "org-element" (element))
(declare-function org-remove-double-quotes "org" (s))
(declare-function org-mode "org" ())
(declare-function org-file-contents "org" (file &optional noerror))
(declare-function org-in-commented-heading-p "org" (&optional no-inheritance))
(declare-function org-mode "org" ())
(declare-function vc-backend "vc-hooks" (f))
(declare-function vc-call "vc-hooks" (fun file &rest args) t)
(declare-function vc-exec-after "vc-dispatcher" (code))
;;; Variables
(defvar org-macro-templates nil
(defvar-local org-macro-templates nil
"Alist containing all macro templates in current buffer.
Associations are in the shape of (NAME . TEMPLATE) where NAME
stands for macro's name and template for its replacement value,
@ -59,48 +69,48 @@ both as strings. This is an internal variable. Do not set it
directly, use instead:
#+MACRO: name template")
(make-variable-buffer-local 'org-macro-templates)
;;; Functions
(defun org-macro--collect-macros ()
"Collect macro definitions in current buffer and setup files.
Return an alist containing all macro templates found."
(let* (collect-macros ; For byte-compiler.
(collect-macros
(lambda (files templates)
;; Return an alist of macro templates. FILES is a list of
;; setup files names read so far, used to avoid circular
;; dependencies. TEMPLATES is the alist collected so far.
(let ((case-fold-search t))
(org-with-wide-buffer
(goto-char (point-min))
(while (re-search-forward
"^[ \t]*#\\+\\(MACRO\\|SETUPFILE\\):" nil t)
(let ((element (org-element-at-point)))
(when (eq (org-element-type element) 'keyword)
(let ((val (org-element-property :value element)))
(if (equal (org-element-property :key element) "MACRO")
;; Install macro in TEMPLATES.
(when (string-match
"^\\(.*?\\)\\(?:\\s-+\\(.*\\)\\)?\\s-*$" val)
(let* ((name (match-string 1 val))
(template (or (match-string 2 val) ""))
(old-cell (assoc name templates)))
(if old-cell (setcdr old-cell template)
(push (cons name template) templates))))
;; Enter setup file.
(let ((file (expand-file-name
(org-remove-double-quotes val))))
(unless (member file files)
(with-temp-buffer
(org-mode)
(insert (org-file-contents file 'noerror))
(setq templates
(funcall collect-macros (cons file files)
templates)))))))))))
templates))))
(letrec ((collect-macros
(lambda (files templates)
;; Return an alist of macro templates. FILES is a list
;; of setup files names read so far, used to avoid
;; circular dependencies. TEMPLATES is the alist
;; collected so far.
(let ((case-fold-search t))
(org-with-wide-buffer
(goto-char (point-min))
(while (re-search-forward
"^[ \t]*#\\+\\(MACRO\\|SETUPFILE\\):" nil t)
(let ((element (org-element-at-point)))
(when (eq (org-element-type element) 'keyword)
(let ((val (org-element-property :value element)))
(if (equal (org-element-property :key element) "MACRO")
;; Install macro in TEMPLATES.
(when (string-match
"^\\(.*?\\)\\(?:\\s-+\\(.*\\)\\)?\\s-*$" val)
(let* ((name (match-string 1 val))
(template (or (match-string 2 val) ""))
(old-cell (assoc name templates)))
(if old-cell (setcdr old-cell template)
(push (cons name template) templates))))
;; Enter setup file.
(let ((file (expand-file-name
(org-unbracket-string "\"" "\"" val))))
(unless (member file files)
(with-temp-buffer
(setq default-directory
(file-name-directory file))
(org-mode)
(insert (org-file-contents file 'noerror))
(setq templates
(funcall collect-macros (cons file files)
templates)))))))))))
templates))))
(funcall collect-macros nil nil)))
(defun org-macro-initialize-templates ()
@ -117,15 +127,26 @@ function installs the following ones: \"property\",
(if old-template (setcdr old-template (cdr cell))
(push cell templates))))))
;; Install hard-coded macros.
(mapc (lambda (cell) (funcall update-templates cell))
(list (cons "property" "(eval (org-entry-get nil \"$1\" 'selective))")
(mapc update-templates
(list (cons "property"
"(eval (save-excursion
(let ((l \"$2\"))
(when (org-string-nw-p l)
(condition-case _
(let ((org-link-search-must-match-exact-headline t))
(org-link-search l nil t))
(error
(error \"Macro property failed: cannot find location %s\"
l)))))
(org-entry-get nil \"$1\" 'selective)))")
(cons "time" "(eval (format-time-string \"$1\"))")))
(let ((visited-file (buffer-file-name (buffer-base-buffer))))
(when (and visited-file (file-exists-p visited-file))
(mapc (lambda (cell) (funcall update-templates cell))
(mapc update-templates
(list (cons "input-file" (file-name-nondirectory visited-file))
(cons "modification-time"
(format "(eval (format-time-string \"$1\" '%s))"
(format "(eval (format-time-string \"$1\" (or (and (org-string-nw-p \"$2\") (org-macro--vc-modified-time %s)) '%s)))"
(prin1-to-string visited-file)
(prin1-to-string
(nth 5 (file-attributes visited-file)))))))))
(setq org-macro-templates templates)))
@ -154,38 +175,132 @@ default value. Return nil if no template was found."
;; Return string.
(format "%s" (or value ""))))))
(defun org-macro-replace-all (templates)
(defun org-macro-replace-all (templates &optional finalize keywords)
"Replace all macros in current buffer by their expansion.
TEMPLATES is an alist of templates used for expansion. See
`org-macro-templates' for a buffer-local default value."
`org-macro-templates' for a buffer-local default value.
If optional arg FINALIZE is non-nil, raise an error if a macro is
found in the buffer with no definition in TEMPLATES.
Optional argument KEYWORDS, when non-nil is a list of keywords,
as strings, where macro expansion is allowed."
(save-excursion
(goto-char (point-min))
(let (record)
(let ((properties-regexp
(format "\\`EXPORT_%s\\+?\\'" (regexp-opt keywords)))
record)
(while (re-search-forward "{{{[-A-Za-z0-9_]" nil t)
(let ((object (org-element-context)))
(when (eq (org-element-type object) 'macro)
(let* ((value (org-macro-expand object templates))
(begin (org-element-property :begin object))
(signature (list begin
object
(org-element-property :args object))))
;; Avoid circular dependencies by checking if the same
;; macro with the same arguments is expanded at the same
;; position twice.
(if (member signature record)
(error "Circular macro expansion: %s"
(org-element-property :key object))
(when value
(push signature record)
(delete-region
begin
;; Preserve white spaces after the macro.
(progn (goto-char (org-element-property :end object))
(skip-chars-backward " \t")
(point)))
;; Leave point before replacement in case of recursive
;; expansions.
(save-excursion (insert value)))))))))))
(unless (save-match-data (org-in-commented-heading-p))
(let* ((datum (save-match-data (org-element-context)))
(type (org-element-type datum))
(macro
(cond
((eq type 'macro) datum)
;; In parsed keywords and associated node
;; properties, force macro recognition.
((or (and (eq type 'keyword)
(member (org-element-property :key datum)
keywords))
(and (eq type 'node-property)
(string-match-p properties-regexp
(org-element-property :key
datum))))
(save-excursion
(goto-char (match-beginning 0))
(org-element-macro-parser))))))
(when macro
(let* ((value (org-macro-expand macro templates))
(begin (org-element-property :begin macro))
(signature (list begin
macro
(org-element-property :args macro))))
;; Avoid circular dependencies by checking if the same
;; macro with the same arguments is expanded at the
;; same position twice.
(cond ((member signature record)
(error "Circular macro expansion: %s"
(org-element-property :key macro)))
(value
(push signature record)
(delete-region
begin
;; Preserve white spaces after the macro.
(progn (goto-char (org-element-property :end macro))
(skip-chars-backward " \t")
(point)))
;; Leave point before replacement in case of
;; recursive expansions.
(save-excursion (insert value)))
(finalize
(error "Undefined Org macro: %s; aborting"
(org-element-property :key macro))))))))))))
(defun org-macro-escape-arguments (&rest args)
"Build macro's arguments string from ARGS.
ARGS are strings. Return value is a string with arguments
properly escaped and separated with commas. This is the opposite
of `org-macro-extract-arguments'."
(let ((s ""))
(dolist (arg (reverse args) (substring s 1))
(setq s
(concat
","
(replace-regexp-in-string
"\\(\\\\*\\),"
(lambda (m)
(concat (make-string (1+ (* 2 (length (match-string 1 m)))) ?\\)
","))
;; If a non-terminal argument ends on backslashes, make
;; sure to also escape them as they will be followed by
;; a comma.
(concat arg (and (not (equal s ""))
(string-match "\\\\+\\'" arg)
(match-string 0 arg)))
nil t)
s)))))
(defun org-macro-extract-arguments (s)
"Extract macro arguments from string S.
S is a string containing comma separated values properly escaped.
Return a list of arguments, as strings. This is the opposite of
`org-macro-escape-arguments'."
;; Do not use `org-split-string' since empty strings are
;; meaningful here.
(split-string
(replace-regexp-in-string
"\\(\\\\*\\),"
(lambda (str)
(let ((len (length (match-string 1 str))))
(concat (make-string (/ len 2) ?\\)
(if (zerop (mod len 2)) "\000" ","))))
s nil t)
"\000"))
(defun org-macro--vc-modified-time (file)
(save-window-excursion
(when (vc-backend file)
(let ((buf (get-buffer-create " *org-vc*"))
(case-fold-search t)
date)
(unwind-protect
(progn
(vc-call print-log file buf nil nil 1)
(with-current-buffer buf
(vc-exec-after
(lambda ()
(goto-char (point-min))
(when (re-search-forward "Date:?[ \t]*" nil t)
(let ((time (parse-time-string
(buffer-substring
(point) (line-end-position)))))
(when (cl-some #'identity time)
(setq date (apply #'encode-time time))))))))
(let ((proc (get-buffer-process buf)))
(while (and proc (accept-process-output proc .5 nil t)))))
(kill-buffer buf))
date))))
(provide 'org-macro)

183
lisp/org/org-macs.el
View file

@ -1,4 +1,4 @@
;;; org-macs.el --- Top-level definitions for Org-mode
;;; org-macs.el --- Top-level Definitions for Org -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2017 Free Software Foundation, Inc.
@ -25,29 +25,12 @@
;;; Commentary:
;; This file contains macro definitions, defsubst definitions, other
;; stuff needed for compilation and top-level forms in Org-mode, as well
;; lots of small functions that are not org-mode specific but simply
;; generally useful stuff.
;; stuff needed for compilation and top-level forms in Org mode, as
;; well lots of small functions that are not Org mode specific but
;; simply generally useful stuff.
;;; Code:
(eval-and-compile
(unless (fboundp 'declare-function)
(defmacro declare-function (fn file &optional _arglist _fileonly)
`(autoload ',fn ,file)))
(if (>= emacs-major-version 23)
(defsubst org-char-to-string(c)
"Defsubst to decode UTF-8 character values in emacs 23 and beyond."
(char-to-string c))
(defsubst org-char-to-string (c)
"Defsubst to decode UTF-8 character values in emacs 22."
(string (decode-char 'ucs c)))))
(declare-function org-add-props "org-compat" (string plist &rest props))
(declare-function org-string-match-p "org-compat"
(regexp string &optional start))
(defmacro org-with-gensyms (symbols &rest body)
(declare (debug (sexp body)) (indent 1))
`(let ,(mapcar (lambda (s)
@ -55,26 +38,11 @@
symbols)
,@body))
(defmacro org-called-interactively-p (&optional kind)
(declare (debug (&optional ("quote" symbolp)))) ;Why not just t?
(if (featurep 'xemacs)
`(interactive-p)
(if (or (> emacs-major-version 23)
(and (>= emacs-major-version 23)
(>= emacs-minor-version 2)))
;; defined with no argument in <=23.1
`(with-no-warnings (called-interactively-p ,kind))
`(interactive-p))))
(defmacro org-bound-and-true-p (var)
"Return the value of symbol VAR if it is bound, else nil."
(declare (debug (symbolp)))
`(and (boundp (quote ,var)) ,var))
(defun org-string-nw-p (s)
"Is S a string with a non-white character?"
"Return S if S is a string containing a non-blank character.
Otherwise, return nil."
(and (stringp s)
(org-string-match-p "\\S-" s)
(string-match-p "[^ \r\t\n]" s)
s))
(defun org-not-nil (v)
@ -82,25 +50,6 @@
Otherwise return nil."
(and v (not (equal v "nil")) v))
(defun org-substitute-posix-classes (re)
"Substitute posix classes in regular expression RE."
(let ((ss re))
(save-match-data
(while (string-match "\\[:alnum:\\]" ss)
(setq ss (replace-match "a-zA-Z0-9" t t ss)))
(while (string-match "\\[:word:\\]" ss)
(setq ss (replace-match "a-zA-Z0-9" t t ss)))
(while (string-match "\\[:alpha:\\]" ss)
(setq ss (replace-match "a-zA-Z" t t ss)))
(while (string-match "\\[:punct:\\]" ss)
(setq ss (replace-match "\001-@[-`{-~" t t ss)))
ss)))
(defmacro org-re (s)
"Replace posix classes in regular expression."
(declare (debug (form)))
(if (featurep 'xemacs) `(org-substitute-posix-classes ,s) s))
(defmacro org-preserve-lc (&rest body)
(declare (debug (body)))
(org-with-gensyms (line col)
@ -136,19 +85,6 @@ Otherwise return nil."
(partial-completion-mode 1))
,@body))
;; FIXME: Slated for removal. Current Org mode does not support Emacs < 22
(defmacro org-maybe-intangible (props)
"Add (intangible t) to PROPS if Emacs version is earlier than Emacs 22.
In Emacs 21, invisible text is not avoided by the command loop, so the
intangible property is needed to make sure point skips this text.
In Emacs 22, this is not necessary. The intangible text property has
led to problems with flyspell. These problems are fixed in flyspell.el,
but we still avoid setting the property in Emacs 22 and later.
We use a macro so that the test can happen at compilation time."
(if (< emacs-major-version 22)
`(append '(intangible t) ,props)
props))
(defmacro org-with-point-at (pom &rest body)
"Move to buffer and point of point-or-marker POM for the duration of BODY."
(declare (debug (form body)) (indent 1))
@ -160,10 +96,6 @@ We use a macro so that the test can happen at compilation time."
(goto-char (or ,mpom (point)))
,@body)))))
(defmacro org-no-warnings (&rest body)
(declare (debug (body)))
(cons (if (fboundp 'with-no-warnings) 'with-no-warnings 'progn) body))
(defmacro org-with-remote-undo (buffer &rest body)
"Execute BODY while recording undo information in two buffers."
(declare (debug (form body)) (indent 1))
@ -199,22 +131,12 @@ We use a macro so that the test can happen at compilation time."
org-emphasis t)
"Properties to remove when a string without properties is wanted.")
(defsubst org-match-string-no-properties (num &optional string)
(if (featurep 'xemacs)
(let ((s (match-string num string)))
(and s (remove-text-properties 0 (length s) org-rm-props s))
s)
(match-string-no-properties num string)))
(defsubst org-no-properties (s &optional restricted)
"Remove all text properties from string S.
When RESTRICTED is non-nil, only remove the properties listed
in `org-rm-props'."
(if (fboundp 'set-text-properties)
(set-text-properties 0 (length s) nil s)
(if restricted
(remove-text-properties 0 (length s) org-rm-props s)
(set-text-properties 0 (length s) nil s)))
(if restricted (remove-text-properties 0 (length s) org-rm-props s)
(set-text-properties 0 (length s) nil s))
s)
(defsubst org-get-alist-option (option key)
@ -236,16 +158,6 @@ program is needed for, so that the error message can be more informative."
(error "Can't find `%s'%s" cmd
(if use (format " (%s)" use) "")))))
(defsubst org-inhibit-invisibility ()
"Modified `buffer-invisibility-spec' for Emacs 21.
Some ops with invisible text do not work correctly on Emacs 21. For these
we turn off invisibility temporarily. Use this in a `let' form."
(if (< emacs-major-version 22) nil buffer-invisibility-spec))
(defsubst org-set-local (var value)
"Make VAR local in current buffer and set it to VALUE."
(set (make-local-variable var) value))
(defsubst org-last (list)
"Return the last element of LIST."
(car (last list)))
@ -282,11 +194,11 @@ we turn off invisibility temporarily. Use this in a `let' form."
(<= (match-beginning n) pos)
(>= (match-end n) pos)))
(defun org-match-line (re)
"Looking-at at the beginning of the current line."
(defun org-match-line (regexp)
"Match REGEXP at the beginning of the current line."
(save-excursion
(goto-char (point-at-bol))
(looking-at re)))
(beginning-of-line)
(looking-at regexp)))
(defun org-plist-delete (plist property)
"Delete PROPERTY from PLIST.
@ -298,13 +210,6 @@ This is in contrast to merely setting it to 0."
(setq plist (cddr plist)))
p))
(defun org-replace-match-keep-properties (newtext &optional fixedcase
literal string)
"Like `replace-match', but add the text properties found original text."
(setq newtext (org-add-props newtext (text-properties-at
(match-beginning 0) string)))
(replace-match newtext fixedcase literal string))
(defmacro org-save-outline-visibility (use-markers &rest body)
"Save and restore outline visibility around BODY.
If USE-MARKERS is non-nil, use markers for the positions.
@ -313,19 +218,15 @@ but it also means that the buffer should stay alive
during the operation, because otherwise all these markers will
point nowhere."
(declare (debug (form body)) (indent 1))
(org-with-gensyms (data rtn)
`(let ((,data (org-outline-overlay-data ,use-markers))
,rtn)
(org-with-gensyms (data)
`(let ((,data (org-outline-overlay-data ,use-markers)))
(unwind-protect
(progn
(setq ,rtn (progn ,@body))
(prog1 (progn ,@body)
(org-set-outline-overlay-data ,data))
(when ,use-markers
(mapc (lambda (c)
(and (markerp (car c)) (move-marker (car c) nil))
(and (markerp (cdr c)) (move-marker (cdr c) nil)))
,data)))
,rtn)))
(dolist (c ,data)
(when (markerp (car c)) (move-marker (car c) nil))
(when (markerp (cdr c)) (move-marker (cdr c) nil))))))))
(defmacro org-with-wide-buffer (&rest body)
"Execute body while temporarily widening the buffer."
@ -355,17 +256,16 @@ point nowhere."
(defun org-get-limited-outline-regexp ()
"Return outline-regexp with limited number of levels.
The number of levels is controlled by `org-inlinetask-min-level'"
(if (or (not (derived-mode-p 'org-mode)) (not (featurep 'org-inlinetask)))
org-outline-regexp
(let* ((limit-level (1- org-inlinetask-min-level))
(nstars (if org-odd-levels-only (1- (* limit-level 2)) limit-level)))
(format "\\*\\{1,%d\\} " nstars))))
(defun org-format-seconds (string seconds)
"Compatibility function replacing format-seconds."
(if (fboundp 'format-seconds)
(format-seconds string seconds)
(format-time-string string (seconds-to-time seconds))))
(cond ((not (derived-mode-p 'org-mode))
outline-regexp)
((not (featurep 'org-inlinetask))
org-outline-regexp)
(t
(let* ((limit-level (1- org-inlinetask-min-level))
(nstars (if org-odd-levels-only
(1- (* limit-level 2))
limit-level)))
(format "\\*\\{1,%d\\} " nstars)))))
(defmacro org-eval-in-environment (environment form)
(declare (debug (form form)) (indent 1))
@ -382,10 +282,27 @@ the value in cdr."
;;;###autoload
(defmacro org-load-noerror-mustsuffix (file)
"Load FILE with optional arguments NOERROR and MUSTSUFFIX. Drop the MUSTSUFFIX argument for XEmacs, which doesn't recognize it."
(if (featurep 'xemacs)
`(load ,file 'noerror)
`(load ,file 'noerror nil nil 'mustsuffix)))
"Load FILE with optional arguments NOERROR and MUSTSUFFIX."
`(load ,file 'noerror nil nil 'mustsuffix))
(defun org-unbracket-string (pre post string)
"Remove PRE/POST from the beginning/end of STRING.
Both PRE and POST must be pre-/suffixes of STRING, or neither is
removed."
(if (and (string-prefix-p pre string)
(string-suffix-p post string))
(substring string (length pre) (- (length post)))
string))
(defun org-read-function (prompt &optional allow-empty?)
"Prompt for a function.
If ALLOW-EMPTY? is non-nil, return nil rather than raising an
error when the user input is empty."
(let ((func (completing-read prompt obarray #'fboundp t)))
(cond ((not (string= func ""))
(intern func))
(allow-empty? nil)
(t (user-error "Empty input is not valid")))))
(provide 'org-macs)

Some files were not shown because too many files have changed in this diff Show more