~.
You may want to check whether your HTML files are rendered differently
after this change.
*** New keybinding =
= for ~org-force-cycle-archived~
~org-force-cycle-archived~ used to be associated with == but
this keybinding is used in Emacs for navigating tabs in Emacs. The
new keybinding is ==.
** New default settings for some options
These options now default to =t=:
- ~org-loop-over-headlines-in-active-region~
- ~org-fontify-done-headline~
- ~org-src-tab-acts-natively~
You may want to read the docstrings of these options to understand the
consequences of this change.
Also, ~org-startup-folded~ now defaults to ~showeverything~.
** New features
*** =RET= and =C-j= now obey ~electric-indent-mode~
Since Emacs 24.4, ~electric-indent-mode~ is enabled by default. In
most major modes, this causes =RET= to reindent the current line and
indent the new line, and =C-j= to insert a newline without indenting.
Org mode now obeys this minor mode: when ~electric-indent-mode~ is
enabled, and point is neither in a table nor on a timestamp or a link:
- =RET= (bound to ~org-return~) reindents the current line and indents
the new line;
- =C-j= (bound to the new command ~org-return-and-maybe-indent~)
merely inserts a newline.
To get the previous behavior back, disable ~electric-indent-mode~
explicitly:
#+begin_src emacs-lisp
(add-hook 'org-mode-hook (lambda () (electric-indent-local-mode -1)))
#+end_src
Alternatively, if you wish to keep =RET= as the "smart-return" key,
but dislike Org's default indentation of sections, you may prefer to
customize ~org-adapt-indentation~ to either nil or =headline-data=.
*** New allowed value for ~org-adapt-indentation~
~org-adapt-indentation~ now accepts a new value, =headline-data=.
When set to this value, Org will only adapt indentation of headline
data lines, such as planning/clock lines and property/logbook drawers.
Also, with this setting, =org-indent-mode= will keep these data lines
correctly aligned with the headline above.
*** Looping agenda commands over headlines
~org-agenda-loop-over-headlines-in-active-region~ allows you to loop
agenda commands over the active region.
When set to =t= (the default), loop over all headlines. When set to
='start-level=, loop over headlines with the same level as the first
headline in the region. When set to a string, loop over lines
matching this regular expression.
*** New minor mode ~org-table-header-line-mode~
Turn on the display of the first data row of the table at point in the
window header line when this first row is not visible anymore in the
buffer.
You can activate this minor mode by default by setting the option
~org-table-header-line-p~ to =t=. You can also change the face for
the header line by customizing the ~org-table-header~ face.
*** New minor mode ~org-list-checkbox-radio-mode~
When this minor mode is on, checkboxes behave as radio buttons: if a
checkbox is turned on, other checkboxes at the same level are turned
off.
If you want to occasionally toggle a checkbox as a radio button
without turning this minor mode on, you can use == to
call ~org-toggle-radio-button~.
You can also add =#+ATTR_ORG: :radio t= right before the list to tell
Org to use radio buttons for this list only.
*** Numeric priorities are now allowed (up to 65)
You can now set ~org-priority-highest/lowest/default~ to integers to
use numeric priorities globally or set, for example
#+PRIORITIES: 1 10 5
to define a buffer-local range and default for priorities. Priority
commands should work as usual. You cannot use numbers superior to 64
for numeric priorities, as it would clash with priorities like [#A]
where the "A" is internally converted to its numeric value of 65.
*** Property drawers allowed before first headline
Property drawers are now allowed before the first headline.
Org mode is moving more towards making things before the first
headline behave just as if it was at outline level 0. Inheritance for
properties will work also for this level. In other words: defining
things in a property drawer before the first headline will make them
"inheritable" for all headlines.
*** Refinement in window behavior on exiting Org source buffer
After editing a source block, Org will restore the window layout when
~org-src-window-setup~ is set to a value that modifies the layout.
*** Display remote inline images
Org now knows how to display remote images inline.
Whether the images are actually displayed is controlled by the new
option ~org-display-remote-inline-images~.
*** New option to resolve open clock at a provided time
~org-resolve-clocks~ now has a `t' option, which works just like the
`k' option, but the user specifies a time of day, not a number of
minutes.
*** New step value =semimonth= accepted for clock tables
*** Allow text rescaling in column view
You can now use =C-x C-+= in column view: the columns face size will
increase or decrease, together with the column header size.
*** New startup option =#+startup: num=
When this startup option is set, display headings as numerated.
Use =#+startup: nonum= to turn this off.
*** New tool for custom links
Org provides a new tool ~org-link-open-as-file~, useful when defining
new link types similar to "file"-type links. See docstring for
details.
*** New optional numeric argument for ~org-return~
In situations where ~org-return~ calls ~newline~, multiple newlines
can now be inserted with this prefix argument.
*** New source code block header argument =:file-mode=
Source code block header argument =:file-mode= can set file
permissions if =:file= argument is provided.
*** =ob-C.el= allows the inclusion of non-system header files
In C and C++ blocks, ~:includes~ arguments that do not start with a
~<~ character will now be formatted as double-quoted ~#include~
statements.
*** =ob-clojure.el= supports inf-clojure.el and ClojureScript evaluation
You can now set ~(setq org-babel-clojure-backend 'inf-clojure)~ and
evaluate Clojure source blocks using [[https://github.com/clojure-emacs/inf-clojure][inf-clojure]]. With a header
argument like =:alias "alias"= the Clojure REPL will boot with
=clojure -Aalias=. Otherwise Clojure will boot with =lein=, =boot= or
=tools.deps=, depending on whether the current directory contains a
=project.clj=, =build.boot= or =deps.edn=, falling back on
~inf-clojure-generic-cmd~ in case no such file is present.
Also, when using [[https://github.com/clojure-emacs/cider][cider]], you can now use =#+begin_src clojurescript= to
execute ClojureScript code from Org files. Note that this works only
if your Org file is associated with a cider session that knows how to
run ClojureScript code. A bare =lein repl= session outside of a
directory configured for ClojureScript will /not/ work.
*** =ob-java.el= supports Java command line arguments
Babel Java blocks recognize header argument =:cmdargs= and pass its
value in call to =java=.
*** =ob-screen.el= now accepts =:screenrc= header argument
Screen blocks now recognize the =:screenrc= header argument and pass
its value to the screen command via the "-c" option. The default
remains =/dev/null= (i.e. a clean screen session)
*** =ob-plantuml=: now supports using PlantUML executable to generate diagrams
Set =org-plantuml-exec-mode= to ='plantuml= in order to use the
executable instead of JAR. When using an executable it is also
possible to configure executable location as well as arguments via:
=org-plantuml-executable-path= and =org-plantuml-executable-args=.
** New commands
*** ~org-table-header-line-mode~
Turn on a minor mode to display the first data row of the table at
point in the header-line when the beginning of the table is invisible.
*** ~org-agenda-ctrl-c-ctrl-c~
Hitting == in an agenda view now calls ~org-agenda-set-tags~.
*** ~org-hide-entry~
This command is the counterpart of ~org-show-entry~.
*** ~org-columns-toggle-or-columns-quit~
== bound to ~org-columns-toggle-or-columns-quit~ replaces the
recent ~org-columns-set-tags-or-toggle~. Tag setting is still
possible via column view value edit or with ==.
*** ~org-datetree-find-month-create~
Find or create a month entry for a date.
** New options and settings
*** New option ~org-html-prefer-user-labels~
When non-nil, use =NAME= affiliated keyword, or raw target values, to
generate anchor's ID. Otherwise, consistently use internal naming
scheme.
=CUSTOM_ID= values are still always used, when available.
*** New option for using tabs in ~org-agenda-window-setup~
Choosing ~other-tab~ for ~org-agenda-window-setup~ will open the
agenda view in a new tab. This will work with versions of Emacs since
27.1 when ~tab-bar-mode~ was introduced.
*** New option ~org-table-header-line-p~
Setting this option to =t= will activate ~org-table-header-line-mode~
in org-mode buffers.
*** New option ~org-startup-numerated~
When this option is =t=, Org files will start using ~(org-num-mode 1)~
and headings will be visually numerated.
You can turn this on/off on a per-file basis with =#+startup: num= or
=#+startup: nonum=.
*** New option ~org-clock-auto-clockout-timer~
When this option is set to a number and the user configuration
contains =(org-clock-auto-clockout-insinuate)=, Org will clock out the
currently clocked in task after that number of seconds of idle time.
This is useful when you often forget to clock out before being idle
and don't want to have to manually set the clocking time to take into
account.
*** New option to group captured datetime entries by month
A new `:tree-type month' option was added to org-capture-templates to
group new datetime entries by month.
*** New option to show source buffers using "plain" display-buffer
There is a new option ~plain~ to ~org-src-window-setup~ to show source
buffers using ~display-buffer~. This allows users to control how
source buffers are displayed by modifying ~display-buffer-alist~ or
~display-buffer-base-action~.
*** New option ~org-archive-subtree-save-file-p~
Archiving a subtree used to always save the target archive buffer.
Commit [[git::b186d1d7][b186d1d7]] changed this behavior by always not saving the target
buffer, because batch archiving from agenda could take too much time.
This new option ~org-archive-subtree-save-file-p~ defaults to the
value =from-org= so that archiving a subtree will save the target
buffer when done from an org-mode buffer, but not from the agenda.
You can also set this option to =t= or to =from-agenda=.
*** New option ~org-show-notification-timeout~
This option will add a timeout to notifications.
*** New option ~org-latex-to-html-convert-command~
This new option allows you to convert a LaTeX fragment directly into
HTML.
*** New option ~org-babel-shell-results-defaults-to-output~
By default, source code blocks are executed in "functional mode": it
means that the results of executing them are the value of their last
statement (see [[https://orgmode.org/manual/Results-of-Evaluation.html][the documentation]].)
The value of a shell script's execution is its exit code. But most
users expect the results of executing a shell script to be its output,
not its exit code.
So we introduced this option, that you can set to nil if you want to
stick using ~:results value~ as the implicit header.
In all Babel libraries, the absence of a ~:results~ header should
produce the same result than setting ~:results value~, unless there is
an option to explicitly create an exception.
See [[msg:CA+A2iZaziAfMeGpBqL6qGrzrWEVvLvC0DUw++T4gCF3NGuW-DQ@mail.gmail.com][this thread]] for more context.
*** New option in ~org-attach-store-link-p~
~org-attach-store-link-p~ has a new option to store a file link to the
attachment.
*** New option ~org-fontify-todo-headline~
This feature is the same as ~org-fontify-done-headline~, but for TODO
headlines instead. This allows you to distinguish TODO headlines from
normal headlines. The face can be customized via ~org-headline-todo~.
*** New default value for ~org-file-apps~
The new value uses Emacs as the application for opening directory.
*** New hook ~org-agenda-filter-hook~
Functions in this hook are run after ~org-agenda-filter~ is called.
** Removed or renamed functions and variables
*** Deprecated ~org-flag-drawer~ function
Use ~org-hide-drawer-toggle~ instead.
*** Deprecated ~org-hide-block-toggle-maybe~ function
Use ~org-hide-block-toggle~ instead.
*** Deprecated ~org-hide-block-toggle-all~ function
This function was not used in the code base, and has no clear use
either. It has been marked for future removal. Please contact the
mailing list if you use this function.
*** Deprecated ~org-return-indent~ function
In Elisp code, use ~(org-return t)~ instead. Interactively, =C-j= is
now bound to ~org-return-and-maybe-indent~, which indents the new line
when ~electric-indent-mode~ is disabled.
*** Removed ~org-maybe-keyword-time-regexp~
The variable was not used in the code base.
*** Removed ~org-export-special-keywords~
The variable was not used in the code base.
*** Renamed ~org-at-property-block-p~
The new name is ~org-at-property-drawer-p~, which is less confusing.
*** Renamed ~org-columns-set-tags-or-toggle~
See [[*~org-columns-toggle-or-columns-quit~]].
*** Renamed priority options
From ~org-lowest-priority~ to ~org-priority-lowest~.
From ~org-default-priority~ to ~org-priority-default~.
From ~org-highest-priority~ to ~org-priority-highest~.
From ~org-enable-priority-commands~ to ~org-priority-enable-commands~.
From ~org-show-priority~ to ~org-priority-show~.
** Miscellaneous
*** =ob-screen.el= now respects screen =:session= name
Screen babel session are now named based on the =:session= header
argument (defaults to ~default~).
Previously all session names had ~org-babel-session-~ prepended.
*** Forward/backward paragraph functions in line with the rest of Emacs
~org-forward-paragraph~ and ~org-backward-paragraph~, bound to
~~ and ~~ functions mimic more closely behavior of
~forward-paragraph~ and ~backward-paragraph~ functions when
available.
They also accept an optional argument for multiple calls.
See their docstring for details.
*** ~org-table-to-lisp~ no longer checks if point is at a table
The caller is now responsible for the check. It can use, e.g.,
~org-at-table-p~.
The function is also much more efficient than it used to be, even on
very large tables.
*** New function ~org-collect-keywords~
*** Drawers' folding use an API similar to block's
Tooling for folding drawers interactively or programmatically is now
on par with block folding. In particular, ~org-hide-drawer-toggle~,
a new function, is the central place for drawer folding.
*** Duration can be read and written in compact form
~org-duration-to-minutes~ understands =1d3h5min= as a duration,
whereas ~org-duration-from-minutes~ can output this compact form if
the duration format contains the symbol ~compact~.
*** C-n, C-p, SPC and DEL in agenda commands dispatch window
You can now use ==, ==, == and == key to scroll up
and down the agenda and attach dispatch window.
*** == in agenda calls ~org-agenda-set-tags~
Both == and == set the tags of the headline in the
Org buffer. Both keybindings are now available from the agenda too.
*** Allow to use an empty HTML extension
Using =(setq org-html-extension "")= or setting the HTML extension in
any fashion will produce the expected output, with no trailing period
to the resulting HTML file.
*** Handle repeated tasks with =.+= type and hours step
A task using a =.+= repeater and hours step is repeated starting from
now. E.g.,
#+begin_example
,,** TODO Wash my hands
DEADLINE: <2019-04-05 08:00 Sun .+1h>
Marking this DONE shifts the date to exactly one hour from now.
#+end_example
*** The format of equation reference in HTML export can now be specified
By default, HTML (via MathJax) and LaTeX export equation references
using different commands. LaTeX must use ~\ref{%s}~ because it is used
for all labels; however, HTML (via MathJax) uses ~\eqref{%s}~ for
equations producing inconsistent output. New option
~org-html-equation-reference-format~ sets the command used in HTML
export.
*** =ob-haskell.el= supports compilation with =:compile= header argument
By default, Haskell blocks are interpreted. By adding =:compile yes=
to a Haskell source block, it will be compiled, executed and the
results will be displayed.
*** Support for ~org-edit-special~ with LaTeX fragments
Calling ~org-edit-special~ on an inline LaTeX fragment calls a new
function, ~org-edit-latex-fragment~. This functions in a comparable
manner to editing inline source blocks, bringing up a minibuffer set
to LaTeX mode. The math-mode deliminators are read only.
*** ~org-capture-current-plist~ is now accessible during ~org-capture-mode-hook~
*** New =org-refile.el= file
Org refile variables and functions have been moved to a new file.
*** The end of a 7 years old bug
This bug [[https://lists.gnu.org/archive/html/emacs-orgmode/2013-08/msg00072.html][originally reported]] by Matt Lundin and investigated by Andrew
Hyatt has been fixed. Thanks to both of them.
* Version 9.3
** Incompatible changes
*** Change bracket link escaping syntax
Org used to percent-encode sensitive characters in the URI part of the
bracket links.
Now, escaping mechanism uses the usual backslash character, according
to the following rules:
1. All =[= and =]= characters in the URI must be escaped;
2. Every =\= character preceding either =[= or =]= must be escaped;
3. Every =\= character at the end of the URI must be escaped.
When in doubt, use the function ~org-link-escape~ in order to turn
a link string into its properly escaped form.
The following function will help switching your links to the new
syntax:
#+begin_src emacs-lisp
(defun org-update-link-syntax (&optional no-query)
"Update syntax for links in current buffer.
Query before replacing a link, unless optional argument NO-QUERY
is non-nil."
(interactive "P")
(org-with-point-at 1
(let ((case-fold-search t))
(while (re-search-forward "\\[\\[[^]]*?%\\(?:2[05]\\|5[BD]\\)" nil t)
(let ((object (save-match-data (org-element-context))))
(when (and (eq 'link (org-element-type object))
(= (match-beginning 0)
(org-element-property :begin object)))
(goto-char (org-element-property :end object))
(let* ((uri-start (+ 2 (match-beginning 0)))
(uri-end (save-excursion
(goto-char uri-start)
(re-search-forward "\\][][]" nil t)
(match-beginning 0)))
(uri (buffer-substring-no-properties uri-start uri-end)))
(when (or no-query
(y-or-n-p
(format "Possibly obsolete URI syntax: %S. Fix? "
uri)))
(setf (buffer-substring uri-start uri-end)
(org-link-escape (org-link-decode uri)))))))))))
#+end_src
The old ~org-link-escape~ and ~org-link-unescape~ functions have been
renamed into ~org-link-encode~ and ~org-link-decode~.
*** Change match group number in ~org-link-bracket-re~
Link description, if any, is located in match group 2 instead of match
group 3.
*** ob-clojure does not auto prepend ~(ns ..)~ statement anymore
When tangling, user usually just wants to tangle literally code instead
of prepend inserting a ~(ns ..)~ statement before source block
code. Now, when you have no ~:ns~ header argument specified, this
behavior will not happen automatically.
*** Change in behavior on exit from an Org edit buffer
Org will no longer attempt to restore the window configuration in the
frame to which the user returns after editing a source block with
~org-edit-src-code~. Instead, the window configuration will remain as
it is.
*** Change default value for ~org-email-link-description-format~
When linking from a mail buffer, Org used to truncate the subject of
the message to 30 characters in order to build the description of the
link. This behavior was considered as too surprising. As
a consequence, Org no longer truncates subjects.
You can get the old behavior back with the following:
: (setq org-email-link-description-format "Email %c: %.30s")
*** ~:file~ header argument no longer assume "file" ~:results~
The "file" ~:results~ value is now mandatory for a code block
returning a link to a file. The ~:file~ or ~:file-ext~ header
arguments no longer imply a "file" result is expected.
*** Plain numbers are hours in Column View mode
See [[git:3367ac9457]] for details.
*** All LaTeX preview backends use now xcolor
The dvipng backend was previously relying on fg and bg parameters to
be passed to the CLI. This didn't work when xcolor was directly or
indirectly used in the document (e.g. tkiz is a user of xcolor). Since
every other backend was already using xcolor to set fg and bg, the CLI
alternative was removed and there is no more a :use-xcolor options
since now it's implicitly always true.
*** Org-Attach Git commit
[[*Org-Attach has been refactored and extended][Refactoring of Org-Attach]] affected the Git commit functionality. Not
much, but the following changes are required if you still need to
auto-commit attachments to git:
- Customization of ~org-attach-annex-auto-get~ needs to be renamed to
~org-attach-git-annex-auto-get~.
- Customization of ~org-attach-commit~ is no longer needed. Instead
one need to require the =org-attach-git= module in the startup.
** New features
*** New option to wrap source code lines in HTML export
When new option ~html-wrap-src-lines~ (with variable
~org-html-wrap-src-lines~) is non-nil, HTML export wraps source code
lines in HTML ~code~ elements.
*** New option to handle schedules and deadlines in iCalendar export
Export ignore done tasks with a deadline when
~org-icalendar-use-deadline~ contains ~event-if-todo-not-done~.
Likewise, scheduled done tasks are also ignored when
~org-icalendar-use-scheduled~ contains the same symbol.
*** Add ~split-window-right~ option for src block edit window placement
Given the increasing popularity of wide screen monitors, splitting
horizontally may make more sense than splitting vertically. An
option, ~split-window-right~, to request horizontal splitting has been
added to ~org-src-window-setup~.
*** Org-Attach has been refactored and extended
Org attach has been refactored and the functionality extended. It
should now be easier to understand how it works. A few improvements
and extra options have been added as well.
From the initial comment in org-attach source-code:
- Attachments are managed either by using a custom property DIR or by
using property ID from org-id. When DIR is defined, a location in
the filesystem is directly attached to the outline node. When
org-id is used, attachments are stored in a folder named after the
ID, in a location defined by ~org-attach-id-dir~. DIR has
precedence over ID when both parameters are defined for the current
outline node (also when inherited parameters are taken into
account).
From now on inheritance requires no extra property and will adhere to
~org-attach-use-inheritance~ by default. Inheritance can be
customized to always be activated or never be activated in
~org-attach-use-inheritance~.
The ATTACH_DIR property is deprecated in favor of the shorter
property DIR. Links to folders inside the DIR property can now be
declared as relative links. This is not enabled by default, but can
be set in ~org-attach-dir-relative~.
When adding new attachment to the outline node the preferred way of
doing so can be customized. Take a look at
~org-attach-preferred-new-method~. It defaults to using ID since that
was the behavior before this change.
If both DIR and ID properties are set on the same node, DIR has
precedence and will be used.
One can now also choose to build attachment-directory-paths in a
customized way. This is an advanced topic, but in some case it makes
sense to parse an ID in a different way than the default one. Create
your own function and add it to the beginning of
~org-attach-id-to-path-function~list~ if you want to customize the ID
based folder structure.
If you've used ATTACH_DIR properties to manage attachments, use the
following code to rename that property to DIR which supports the same
functionality. ATTACH_DIR_INHERIT is no longer supported and is
removed.
#+begin_src emacs-lisp
(defun org-update-attach-properties ()
"Change properties for Org-Attach."
(interactive)
(org-with-point-at 1
(while (outline-next-heading)
(let ((DIR (org--property-local-values "ATTACH_DIR" nil)))
(when DIR
(org-set-property "DIR" (car DIR))
(org-delete-property "ATTACH_DIR"))))
(org-delete-property-globally "ATTACH_DIR_INHERIT")))
#+end_src
For those who hate breaking changes, even though the changes are made
to clean things up; fear not. ATTACH_DIR will still continue to work.
It's just not documented any longer. When you get the chance, run the
code above to clean things up anyway!
**** New hooks
Two hooks are added to org-attach:
- org-attach-after-change-hook
- org-attach-open-hook
They are added mostly for internal restructuring purposes, but can
ofc. be used for other things as well.
*** New link-type: Attachment
Attachment-links are now first-class citizens. They mimic file-links
in everything they do but use the existing attachment-folder as a base
when expanding the links. Both =DIR= and =ID= properties are used to
try to resolve the links, in exactly the same way as Org-Attach uses
those properties.
*** Handle overlay specification for notes in Beamer export
This aligns Beamer notes with slide overlays.
*** Add support for lettered lists in Texinfo
Using =:enum A= or =:enum a= Texinfo attribute switches an otherwise
numbered list to a lettered list.
*** Add a dispatcher command to insert dynamic blocks
You can add new dynamic blocks with function
~org-dynamic-block-define~. All such dynamic blocks can be used by
~org-dynamic-block-insert-dblock~ command.
*** Babel
**** ob-emacs-lisp sets ~lexical-binding~ in Org edit buffers
When editing an Elisp src block, the editing buffer's
~lexical-binding~ is set according to the src block's =:lexical=
parameter.
**** Add LaTeX output support in PlantUML
*** New minor mode to display headline numbering
Use == to get a visual indication of the numbering
in the outline. The numbering is also automatically updated upon
changes in the buffer.
*** New property =HTML_HEADLINE_CLASS= in HTML export
The new property =HTML_HEADLINE_CLASS= assigns a class attribute to
a headline.
*** Allow LaTeX attributes and captions for "table.el" tables
Supported LaTeX attributes are ~:float~, ~:center~, ~:font~ and
~:caption~.
*** Attach buffer contents to headline
With == key from attachment dispatcher (==), it is now
possible to write the contents of a buffer to a file in the headline
attachment directory.
*** iCalendar export respects a =CLASS= property
Set the =CLASS= property on an entry to specify a visibility class for
that entry only during iCalendar export. The property can be set to
anything the calendar server supports. The iCalendar standard defines
the values =PUBLIC=, =CONFIDENTIAL=, =PRIVATE=, which can be
interpreted as publicly visible, accessible to a specific group, and
private respectively.
This property can be inherited during iCalendar export, depending on
the value of ~org-use-property-inheritance~.
*** New parameter for =INCLUDE= keyword
Add =:coding CODING-SYSTEM= to include files using a different coding
system than the main Org document. For example:
#+begin_example
,#+INCLUDE: "myfile.cmd" src cmd :coding cp850-dos
#+end_example
*** New values in clock tables' step: =month= and =year=
*** ODT export handles numbers cookies in lists
*** New cell movement functions in tables
~S-~, ~S-~, ~S-~, and ~S-~ now move cells in
the corresponding direction by swapping with the adjacent cell.
*** New option to natively fontify LaTeX snippets and environments
A 'native option was added to org-highlight-latex-and-related. It
matches the same structures than 'latex but it calls
org-src-font-lock-fontify-block instead, thus bringing about full
LaTeX font locking.
*** ~org-clone-subtree-with-time-shift~ learned to shift backward in time
== (~org-clone-subtree-with-time-shift~) now takes a
negative value as a valid repeater to shift time stamps in backward
in cloned subtrees. You can give, for example, ‘-3d’ to shift three
days in the past.
*** Toggle display of all vs. undone scheduled habits conveniently
== (~org-habit-toggle-display-in-agenda~) in an agenda toggles
the display of all habits to those which are undone and scheduled.
This is a function for convenience.
*** New parameter for SQL Babel blocks: ~:dbconnection~
The new parameter ~:dbconnection~ allows to specify a connection name
in a SQL block header: this name is used to look up connection
parameters in ~sql-connection-alist~.
*** New =:scale= attribute supported by LaTeX exporters
The builtin "latex" exporters now accept and use a =:scale= attribute,
which scales an image by a given factor.
This attribute is wrapped around the =scale= parameter of LaTeX's
=\includegraphics= (bitmap images) or a TiKZ's =\scalebox=.
Therefore, its value should be some string palatable to LaTeX as
a positive float Its default value is an empty string (i.e. disabled).
This attribute overrides the =:width= and =:height= attributes.
#+begin_example
,#+name: Beastie
,#+caption: I think I saw this curious horse already, but where ?
,#+LATEX_ATTR: :scale 2
[[https://orgmode.org/img/org-mode-unicorn-logo.png]]
#+end_example
*** Allow specifying the target for a table of contents
The =+TOC= keyword now accepts a =:target:= attribute that specifies
the headline to use for making the table of contents.
#+begin_example
,* Target
:PROPERTIES:
:CUSTOM_ID: TargetSection
:END:
,** Heading A
,** Heading B
,* Another section
,#+TOC: headlines 1 :target "#TargetSection"
#+end_example
** New functions
*** ~org-dynamic-block-insert-dblock~
Use default keybinding == to run command
~org-dynamic-block-insert-dblock~. It will prompt user to select
dynamic block in ~org-dynamic-block-alist~.
*** ~org-table-cell-up~
*** ~org-table-cell-down~
*** ~org-table-cell-left~
*** ~org-table-cell-right~
*** ~org-habit-toggle-display-in-agenda~
** Removed functions and variables
*** Removed Org Drill
You can install it back from MELPA.
*** ~org-babel-set-current-result-hash~
*** ~org-capture-insert-template-here~
*** ~org-attach-directory~
It has been deprecated in favor of ~org-attach-id-dir~ which is less
ambiguous given the restructured org-attach.
*** ~org-enable-fixed-width-editor~
This variable was not used through the code base.
** Miscellaneous
*** Change signature for ~org-list-to-subtree~
The function now accepts the level of the subtree as an optional
argument. It no longer deduces it from the current level.
*** LaTeX preview is simplified
Function ~org-latex-preview~, formerly known as
~org-toggle-latex-fragment~, has a hopefully simpler and more
predictable behavior. See its docstring for details.
*** ~org-table-copy-down~ supports patterns
When ~org-table-copy-increment~ is non-nil, it is now possible to
increment fields like =A1=, or =0A=, i.e., any string prefixed or
suffixed with a whole number.
*** No more special indentation for description items
Descriptions items are indented like regular ones, i.e., text starts
after the bullet. Special indentation used to introduce bugs when
inserting sub-items in a description list.
*** New hook: ~org-todo-repeat-hook~
This hook was actually introduced in Org 9.2.1, but wasn't advertised.
*** Org Table reads numbers starting with 0 as strings
*** Disable fast tag selection interface via prefix arg
A call of ~org-set-tags-command~ with prefix argument C-u C-u avoids
the fast tag selection interface and instead offers the plain
interface.
*** ~:mkdirp~ now supports create directory for ~:dir~ path
The ~:mkdirp~ header argument used to only work for ~:tangle~ tangle
files. Now ~:mkdirp~ works for ~:dir~ too. This is more convenient for
specify default directory and with ~:file~ header argument.
*** New variable: ~org-agenda-breadcrumbs-separator~
If breadcrumbs are showed in org-agenda with the help of "%b" format
in ~org-agenda-prefix-format~, user can customize breadcrumbs's
separator using ~org-agenda-breadcrumbs-separator~.
*** New variable ~org-attach-commands~
This variable makes it possible to customize the list of commands for
the attachment dispatcher.
*** New ID method based on timestamp
If one chooses, it is now possible to create ID's based on timestamp
(ISO8601) instead of UUID by changing org-id-method to ts.
For an improved folder structure when using timestamp as ID, make sure
to promote ~org-attach-id-ts-folder-format~ to the first element of
~org-attach-id-to-path-function-list~ in your configuration at the
same time.
*** New customization: ~org-id-locations-relative~
New customization to make the persisting of org-id-locations between
sessions to store links to files as relative instead of absolute. The
links will be stored as relative to the path of org-id-locations-file.
*** ~org-ctrl-c-tab~ is functional before the first headline
I.e. treat the whole file as if it was a subtree.
Also fold everything below the chosen level. Former behavior was to
leave unfolded subtrees unfolded.
*** ~org-kill-note-or-show-branches~ is functional before the first headline
I.e. treat the whole file as if it was a subtree.
*** Respect narrowing when agenda command is restricted to buffer
*** ~org-table-insert-column~ inserts the column at point position
Before, the new column was inserted to the right of the column at
point position.
*** Table column deletion now consistent with row deletion
Point stays in the column at deletion, except when deleting the
rightmost column.
* Version 9.2
** Incompatible changes
*** Removal of OrgStruct mode mode and radio lists
OrgStruct minor mode and radio lists mechanism (~org-list-send-list~
and ~org-list-radio-lists-templates~) are removed from the code base.
Note that only radio /lists/ have been removed, not radio tables.
If you want to manipulate lists like in Org in other modes, we suggest
to use =orgalist.el=, which you can install from GNU ELPA.
If you want to use Org folding outside of Org buffers, you can have a
look at the outshine package in the MELPA repository.
*** Change in the structure template expansion
Org 9.2 comes with a new template expansion mechanism, combining
~org-insert-structure-template~ bound to ~C-c C-,~.
If you customized the ~org-structure-template-alist~ option manually,
you probably need to update it, see the docstring for accepted values.
If you prefer using previous patterns, e.g. =>
,#+END_SRC
#+END_SRC
should become
#+BEGIN_SRC org
,#+NAME: foo
,#+BEGIN_SRC emacs-lisp :noweb-ref bar
1
,#+END_SRC
,#+BEGIN_SRC emacs-lisp :noweb-ref bar
2
,#+END_SRC
,#+BEGIN_SRC emacs-lisp :noweb yes
<>
,#+END_SRC
#+END_SRC
*** Default/accepted values of ~org-calendar-to-agenda-key~
The default value and accepted value of ~org-calendar-to-agenda-key~
changed. This is an excerpt of the new docstring:
: When set to ‘default’, bind the function to ‘c’, but only if it is
: available in the Calendar keymap. This is the default choice because
: ‘c’ can then be used to switch back and forth between agenda and calendar.
:
: When nil, ‘org-calendar-goto-agenda’ is not bound to any key.
Check the full docstring for more.
*** Change the signature of the ~org-set-effort~ function
Here is the new docstring:
: (org-set-effort &optional INCREMENT VALUE)
:
: Set the effort property of the current entry.
: If INCREMENT is non-nil, set the property to the next allowed
: value. Otherwise, if optional argument VALUE is provided, use
: it. Eventually, prompt for the new value if none of the previous
: variables is set.
*** Placeholders in =(eval ...)= macros are always strings
Within =(eval ...)= macros, =$1=-like placeholders are always replaced
with a string. As a consequence, they must not be enclosed within
quotes. As an illustration, consider the following, now valid,
examples:
#+begin_example
,#+macro: join (eval (concat $1 $2))
,#+macro: sum (eval (+ (string-to-number $1) (string-to-number $2)))
{{{join(a,b)}}} => ab
{{{sum(1,2)}}} => 3
#+end_example
However, there is no change in non-eval macros:
#+begin_example
,#+macro: disp argument: $1
{{{disp(text)}}} => argument: text
#+end_example
*** =align= STARTUP value no longer narrow table columns
Columns narrowing (or shrinking) is now dynamic. See [[*Dynamically
narrow table columns]] for details. In particular, it is decoupled from
aligning.
If you need to automatically shrink columns upon opening an Org
document, use =shrink= value instead, or in addition to align:
#+BEGIN_EXAMPLE
,#+STARTUP: align shrink
#+END_EXAMPLE
*** ~org-get-tags~ meaning change
Function ~org-get-tags~ used to return local tags to the current
headline. It now returns all the inherited tags in addition to the
local tags. In order to get the old behavior back, you can use:
: (org-get-tags nil t)
*** Alphabetic sorting in tables and lists
When sorting alphabetically, ~org-table-sort-lines~ and ~org-sort-list~
now sort according to the locale’s collation rules instead of by
code-point.
*** Change the name of the :tags clocktable option to :match
The =:match= (renamed from =:tags=) option allows to limit clock entries
to those matching a todo-tags matcher.
The old =:tags= option can be set to =t= to display a headline's tags in a
dedicated column.
This is consistent with the naming of =org-dblock-write:columnview=
options, where =:match= is also used as a headlines filter.
** New features
*** Add ~:session~ support of ob-clojure for CIDER
You can initialize source block session with Babel default keybinding
=[C-c C-v C-z]= to use =sesman= session manager to link current
project, directory or buffer with specific Clojure session, or
=cider-jack-in= a new CIDER REPL if no CIDER REPLs available. In older
CIDER version which has not =sesman= integrated, only has
=cider-jack-in= without Clojure project is supported.
#+begin_src clojure :session
(dissoc Clojure 'JVM)
(conj clojurists "stardiviner")
#+end_src
*** Add ~:results link~ support for Babel
With this output format, create a link to the file specified in
~:file~ header argument, without actually writing any result to it:
#+begin_example
,#+begin_src shell :dir "data/tmp" :results link :file "crackzor_1.0.c.gz"
wget -c "https://ben.akrin.com/crackzor/crackzor_1.0.c.gz"
,#+end_src
,#+results:
[[file:data/tmp/crackzor_1.0.c.gz]]
#+end_example
*** Add ~:session~ support of ob-js for js-comint
#+begin_src js :session "*Javascript REPL*"
console.log("stardiviner")
#+end_src
*** Add ~:session~ support of ob-js for Indium
#+begin_src js :session "*JS REPL*"
console.log("stardiviner")
#+end_src
*** Add ~:session~ support of ob-js for skewer-mode
#+begin_src js :session "*skewer-repl*"
console.log("stardiviner")
#+end_src
*** Add support for links to LaTeX equations in HTML export
Use MathJax links when enabled (by ~org-html-with-latex~), otherwise
add a label to the rendered equation.
*** Org Tempo may used for snippet expansion of structure template.
See manual and the commentary section in ~org-tempo.el~ for details.
*** Exclude unnumbered headlines from table of contents
Set their =UNNUMBERED= property to the special =notoc= value. See
manual for details.
*** ~org-archive~ functions update status cookies
Archiving headers through ~org-archive-subtree~ and
~org-archive-to-archive-sibling~ such as the ones listed below:
#+BEGIN_SRC org
,* Top [1/2]
,** DONE Completed
,** TODO Working
#+END_SRC
Will update the status cookie in the top level header.
*** Disable =org-agenda-overriding-header= by setting to empty string
The ~org-agenda-overriding-header~ inserted into agenda views can now
be disabled by setting it to an empty string.
*** Dynamically narrow table columns
With ~C-c TAB~, it is now possible to narrow a column to the width
specified by a width cookie in the column, or to 1 character if there
is no such cookie. The same keybinding expands a narrowed column to
its previous state.
Editing the column automatically expands the whole column to its full
size.
*** =org-columns-summary-types= entries can take an optional COLLECT function
You can use this to make collection of a property from an entry
conditional on another entry. E.g. given this configuration:
#+BEGIN_SRC emacs-lisp
(defun custom/org-collect-confirmed (property)
"Return `PROPERTY' for `CONFIRMED' entries"
(let ((prop (org-entry-get nil property))
(confirmed (org-entry-get nil "CONFIRMED")))
(if (and prop (string= "[X]" confirmed))
prop
"0")))
(setq org-columns-summary-types
'(("X+" org-columns--summary-sum
custom/org-collect-confirmed)))
#+END_SRC
You can have a file =bananas.org= containing:
#+BEGIN_SRC org
,#+columns: %ITEM %CONFIRMED %Bananas{+} %Bananas(Confirmed Bananas){X+}
,* All shipments
,** Shipment 1
:PROPERTIES:
:CONFIRMED: [X]
:Bananas: 4
:END:
,** Shipment 2
:PROPERTIES:
:CONFIRMED: [ ]
:BANANAS: 7
:END:
#+END_SRC
... and when going to the top of that file and entering column view
you should expect to see something like:
| ITEM | CONFIRMED | Bananas | Confirmed Bananas |
|---------------+-----------+---------+-------------------|
| All shipments | | 11 | 4 |
| Shipment 1 | [X] | 4 | 4 |
| Shipment 2 | [ ] | 7 | 7 |
#+BEGIN_EXAMPLE
,#+STARTUP: shrink
#+END_EXAMPLE
*** Allow to filter by tags/property when capturing colview
You can now use =:match= to filter entries using a todo/tags/properties
matcher.
*** Add support for Oracle's database alias in Babel blocks
=ob-sql= library already support running SQL blocks against an Oracle
database using ~sqlplus~. Now it's possible to use alias names
defined in =TNSNAMES= file instead of specifying full connection
parameters. See example below.
#+BEGIN_SRC org
you can use the previous full connection parameters
,#+BEGIN_SRC sql :engine oracle :dbuser me :dbpassword my_insecure_password :database my_db_name :dbhost my_db_host :dbport 1521
select sysdate from dual;
,#+END_SRC
or the alias defined in your TNSNAMES file
,#+BEGIN_SRC sql :engine oracle :dbuser me :dbpassword my_insecure_password :database my_tns_alias
select sysdate from dual;
,#+END_SRC
#+END_SRC
*** ~org-agenda-set-restriction-lock~ toggle agenda restriction at point
You can set an agenda restriction lock with =C-x C-x <= or with =<= at the
beginning of a headline when using Org speed commands. Now, if there
is already a restriction at point, hitting =<= again (or =C-x C-x <=) will
remove it.
*** Headlines can now link to themselves in HTML export
When enabling ~org-html-self-link-headlines~ the headlines exported to
HTML contain a hyperlink to themselves.
** New commands and functions
*** ~org-insert-structure-template~
This function can be used to wrap existing text of Org elements in
a #+BEGIN_FOO/#+END_FOO block. Bound to C-c C-x w by default.
*** ~org-export-excluded-from-toc-p~
See docstring for details.
*** ~org-timestamp-to-time~
*** ~org-timestamp-from-string~
*** ~org-timestamp-from-time~
*** ~org-attach-dired-to-subtree~
See docstring for details.
*** ~org-toggle-narrow-to-subtree~
Toggle the narrowing state of the buffer: when in a narrowed state,
widen, otherwise call ~org-narrow-to-subtree~ to narrow.
This is attached to the "s" speed command, so that hitting "s" twice
will go back to the widen state.
*** ~org-browse-news~
Browse https://orgmode.org/Changes.html to let users read information
about the last major release.
There is a new menu entry for this in the "Documentation" menu item.
*** ~org-info-find-node~
From an Org file or an agenda switch to a suitable info page depending
on the context.
The function is bound to =C-c C-x I=.
** Removed commands and functions
*** ~org-outline-overlay-data~
Use ~org-save-outline-visibility~ instead.
*** ~org-set-outline-overlay-data~
Use ~org-save-outline-visibility~ instead.
*** ~org-get-string-indentation~
It was not used throughout the code base.
*** ~org-fix-indentation~
It was not used throughout code base.
*** ~org-context-p~
Use ~org-element-at-point~ instead.
*** ~org-preserve-lc~
It is no longer used in the code base.
*** ~org-try-structure-completion~
Org Tempo may be used as a replacement. See details above.
** Removed options
*** org-babel-use-quick-and-dirty-noweb-expansion
See [[*Change to Noweb expansion][Change to Noweb expansion]] for explanations.
** Miscellaneous
*** New default value for ~org-texinfo-table-scientific-notation~
It is now nil, which means numbers in scientific notation are not
handled specially by default.
*** New default value for ~org-latex-table-scientific-notation~
It is now nil, which means numbers in scientific notation are not
handled specially by default.
*** New face: ~org-upcoming-distant-deadline~
It is meant to be used as the face for distant deadlines, see
~org-agenda-deadline-faces~
*** ~org-paste-subtree~ no longer breaks sections
Unless point is at the beginning of a headline, ~org-paste-subtree~
now pastes the tree before the next visible headline. If you need to
break the section, use ~org-yank~ instead.
*** ~org-table-insert-column~ inserts a column to the right
It used to insert it on the left. With this change,
~org-table-insert-column~ and ~org-table-delete-column~ are
reciprocal.
*** ~org-publish-resolve-external-link~ accepts a new optional argument.
*** ~org-irc.el~ now supports exporting =irc:= links properly
Previously, irc links were exported by ~ox-md~ and ~ox-html~ as normal
file links, which lead to them being broken in web browsers. Now both
of these exporters will properly export to =irc:= links, which will
open properly in irc clients from web browsers.
*** ~org-comment-dwim~ (bound to =M-;=) now comments headings, if point is on a heading
*** Add support for open source block in window below
Set option ~org-src-window-setup~ to ~split-window-below~.
*** Alphabetic sorting in headings and tags now uses the locale’s sorting rules
When sorting alphabetically, ~org-sort-entries~ and
~org-tags-sort-function~ now sort according to the locale’s collation
rules instead of by code-point.
*** New speed command "k" to kill (cut) the subtree at point
* Version 9.1
** Incompatible changes
*** Variables relative to clocksum duration are obsolete
~org-time-clocksum-format~, ~org-time-clocksum-use-fractional~ and
~org-time-clocksum-fractional-format~ are obsolete. If you changed
them, consider modifying ~org-duration-format~ instead.
Variable ~org-time-clocksum-use-effort-durations~ is also obsolete.
Consider setting ~org-duration-units~ instead.
*** ~org-at-timestamp-p~ optional argument accepts different values
See docstrings for the allowed values. For backward compatibility,
~(org-at-timestamp-p t)~ is still supported, but should be updated
accordingly.
*** ~org-capture-templates~ no longer accepts S-expressions as file names
Since functions are allowed there, a straightforward way to migrate
is to turn, e.g.,
: (file (sexp))
into
: (file (lambda () (sexp)))
*** Deleted contributed packages
=org-ebib.el, =org-bullets.el= and =org-mime.el= have been deleted
from the contrib/ directory.
You can now find them here :
- https://github.com/joostkremers/ebib
- https://github.com/sabof/org-bullets
- https://github.com/org-mime/org-mime
*** Change ~org-texinfo-classes~ value
The value cannot support functions to create sectioning commands
anymore. Also, the sectioning commands should include commands for
appendices. See the docstring for more information.
*** Removal of ~:sitemap-sans-extension~
The publishing property is no longer recognized, as a consequence of
changes to site-map generation.
You can get the same functionality by setting ~:sitemap-format-entry~
to the following
#+BEGIN_SRC elisp
(lambda (entry style project)
(cond ((not (directory-name-p entry))
(format "[[file:%s][%s]]"
(file-name-sans-extension entry)
(org-publish-find-title entry project)))
((eq style 'tree) (file-name-nondirectory (directory-file-name entry)))
(t entry)))
#+END_SRC
*** Change signature for ~:sitemap-function~
~:sitemap-function~ now expects to be called with two arguments. See
~org-publish-project-alist~ for details.
*** Change signature for some properties in ~org-list-to-generic~
~:istart~, ~:icount~, ~:iend~ and ~:isep~ now expect the type of the
list as their first argument.
*** Change signature for ~org-get-repeater~
The optional argument is now a string to extract the repeater from.
See docstring for details.
*** Change signature for ~org-time-string-to-time~
See docstring for changes.
*** Change order of items in ~org-agenda-time-grid~
~org-agenda-time-grid~ gained an extra item to allow users to customize
the string displayed after times in the agenda. See docstring for
details.
*** ~tags-todo~ custom searches now include DONE keywords
Use "/!" markup when filtering TODO keywords to get only not-done TODO
keywords.
*** ~org-split-string~ returns ~("")~ when called on an empty string
It used to return nil.
*** Removal of =ob-scala.el=
See [[https://github.com/ensime/emacs-scala-mode/issues/114][this github issue]].
You can use =ob-scala.el= as packaged in scala-mode, available from the
MELPA repository.
** New features
*** iCalendar export uses inheritance for TIMEZONE and LOCATION properties
Both these properties can be inherited during iCalendar export,
depending on the value of ~org-use-property-inheritance~.
*** iCalendar export respects a TIMEZONE property
Set the TIMEZONE property on an entry to specify a time zone for that
entry only during iCalendar export. The property value should be
specified as in "Europe/London".
*** ~org-attach~ can move directory contents
When setting a new directory for an entry, org-attach offers to move
files over from the old directory. Using a prefix arg will reset the
directory to old, ID based one.
*** New Org duration library
This new library implements tools to read and print time durations in
various formats (e.g., "H:MM", or "1d 2h 3min"...).
See ~org-duration-to-minutes~ and ~org-duration-from-minutes~
docstrings.
*** Agenda
**** New variable : ~org-agenda-show-future-repeats~
**** New variable : ~org-agenda-prefer-last-repeat~
**** New variable : ~org-deadline-past-days~
See docstring for details.
**** Binding C-c C-x < for ~org-agenda-set-restriction-lock-from-agenda~
**** New auto-align default setting for =org-agenda-tags-column=
=org-agenda-tags-column= can now be set to =auto=, which will
automatically align tags to the right edge of the window. This is now
the default setting.
*** New value for ~org-publish-sitemap-sort-folders~
The new ~ignore~ value effectively allows toggling inclusion of
directories in published site-maps.
*** Babel
**** Scheme: support for tables
**** Scheme: new variable: ~org-babel-scheme-null-to~
This new custom option allows you to use an empty list or null symbol to
format the table output, initially assigned to ~hlines~.
**** Scheme: new header ~:prologue~
A new block code header has been created for Org Babel that enables
developers to prepend code to the scheme block being processed.
Multiple ~:prologue~ headers can be added each of them using a string
with the content to be added.
The scheme blocks are prepared by surrounding the code in the block
with a let form. The content of the ~:prologue~ headers are prepended
before this let form.
**** Support for hledger accounting reports added
**** Clojure: new setting ~org-babel-clojure-sync-nrepl-timeout~
Creation of a new setting to specify the Cider timeout. By setting
the =org-babel-clojure-sync-nrepl-timeout= setting option. The value
is in seconds and if set to nil then no timeout will occur.
**** Clojure: new header ~:show-process~
A new block code header has been created for Org Babel that enables
developers to output the process of an ongoing process into a new
window/buffer.
You can tell Org Babel to output the process of a running code block.
To show that output you only have to specify the =:show-process=
option in the code block's header like this:
#+begin_example
,#+BEGIN_SRC clojure :results output :show-process t
(dotimes [n 10]
(println n ".")
(Thread/sleep 500))
,#+END_SRC
#+end_example
If =:show-process= is specified that way, then when you will run the
code using =C-c C-c= a new window will open in Emacs. Everything that
is output by the REPL will immediately be added to that new window.
When the processing of the code is finished, then the window and its
buffer will be closed and the results will be reported in the
=#+RESULTS= section.
Note that the =:results= parameter's behavior is *not* changed. If
=silent= is specified, then no result will be displayed. If =output=
is specified then all the output from the window will appears in the
results section. If =value= is specified, then only the last returned
value of the code will be displayed in the results section.
**** Maxima: new headers ~:prologue~ and ~:epilogue~
Babel options ~:prologue~ and ~:epilogue~ have been implemented for
Maxima source blocks which prepend and append, respectively, the given
code strings. This can be useful for specifying formatting settings
which would add clutter to exported code. For instance, you can use
this ~:prologue "fpprintprec: 2; linel: 50;"~ for presenting Maxima
results in a beamer presentation.
**** PlantUML: add support for header arguments
[[https://plantuml.com/][Plantuml]] source blocks now support the [[https://orgmode.org/manual/prologue.html#prologue][~:prologue~]], [[https://orgmode.org/manual/epilogue.html#epilogue][~:epilogue~]] and
[[https://orgmode.org/manual/var.html#var][~:var~]] header arguments.
**** SQL: new engine added ~sqsh~
A new engine was added to support ~sqsh~ command line utility for use
against Microsoft SQL Server or Sybase SQL server.
More information on ~sqsh~ can be found here: [[https://sourceforge.net/projects/sqsh/][sourceforge/sqsh]]
To use ~sqsh~ in an *sql* =SRC_BLK= set the =:engine= like this:
#+begin_example
,#+BEGIN_SRC sql :engine sqsh :dbhost my_host :dbuser master :dbpassword pass :database support
Select * From Users
Where clue > 0
,#+END_SRC
#+end_example
**** SQL: new engine added =vertica=
A new engine was added to support vsql command line utility for use
against HP Vertica.
More information on =vsql= can be found here: [[https://my.vertica.com/docs/7.2.x/HTML/index.htm#Authoring/ConnectingToHPVertica/vsql/UsingVsql.htm][my.vertica.com]]
To use =vertica= in an sql =SRC_BLK= set the =:engine= like this:
#+BEGIN_EXAMPLE
,#+BEGIN_SRC sql :engine vertica :dbhost my_host :dbuser dbadmin :dbpassword pw :database vmart
SELECT * FROM nodes;
,#+END_SRC
#+END_EXAMPLE
**** C++: New header ~:namespaces~
The new ~:namespaces~ export option can be used to specify namespaces
to be used within a C++ org source block. Its usage is similar to
~:includes~, in that it can accept multiple, space-separated
namespaces to use. This header is equivalent to adding ~using
namespace ;~ in the source block. Here is a "Hello World" in C++
using ~:namespaces~:
#+begin_example
,#+BEGIN_SRC C++ :results output :namespaces std :includes
cout << "Hello World" << endl;
,#+END_SRC
#+end_example
**** Support for Vala language
[[https://wiki.gnome.org/Projects/Vala][Vala]] language blocks support two special header arguments:
- ~:flags~ passes arguments to the compiler
- ~:cmdline~ passes commandline arguments to the generated executable
Support for [[https://orgmode.org/manual/var.html#var][~:var~]] does not exist yet, also there is no [[https://orgmode.org/manual/session.html#session][~:session~]]
support because Vala is a compiled language.
The Vala compiler binary can be changed via the ~defcustom~
~org-babel-vala-compiler~.
*** New ~function~ scope argument for the Clock Table
Added a nullary function that returns a list of files as a possible
argument for the scope of the clock table.
*** Export
**** Implement vernacular table of contents in Markdown exporter
Global table of contents are generated using vanilla Markdown syntax
instead of HTML. Also #+TOC keyword, including local table of
contents, are now supported.
**** Add Slovenian translations
**** Implement ~org-export-insert-image-links~
This new function is meant to be used in back-ends supporting images
as descriptions of links, a.k.a. image links. See its docstring for
details.
**** New macro : ~{{{n}}}~
This macro creates and increment multiple counters in a document. See
manual for details.
**** Add global macros through ~org-export-global-macros~
With this variable, one can define macros available for all documents.
**** New keyword ~#+EXPORT_FILE_NAME~
Similarly to ~:EXPORT_FILE_NAME:~ property, this keyword allows the
user to specify the name of the output file upon exporting the
document. This also has an effect on publishing.
**** Horizontal rules are no longer ignored in LaTeX table math mode
**** Use ~compilation-mode~ for compilation output
**** Plain lists accept a new ~:separator~ attribute in Texinfo
The new ~:separator~ attribute splits a tag from a description list
item into multiple parts. This allows to have two-column tables with
multiple entries in the first column. See manual for more details.
**** ~latex-environment~ elements support ~caption~ keywords for LaTeX export
*** ~org-edit-special~ can edit LaTeX environments
Using ~C-c '~ on a LaTeX environment opens a sub-editing buffer. By
default, major mode in that buffer is ~latex-mode~, but it can be
changed by configuring ~org-src-lang-modes~.
*** ~org-list-to-generic~ includes a new property: ~:ifmt~
~:ifmt~ is a function to be called on the body of each item. See
~org-list-to-generic~ documentation for details.
*** New variable : ~org-bibtex-headline-format-function~
This allow to use a different title than entry title.
*** ~org-attach~ supports attaching files from URLs
Using ~C-c C-a u~ prompts for a URL pointing to a file to be attached
to the document.
*** New option for ~org-refile-use-outline-path~
~org-refile-use-outline-path~ now supports the setting ~buffer-name~,
which causes refile targets to be prefixed with the buffer’s
name. This is particularly useful when used in conjunction with
~uniquify.el~.
*** ~org-file-contents~ now allows the FILE argument to be a URL.
This allows ~#+SETUPFILE:~ to accept a URL instead of a local file
path. The URL contents are auto-downloaded and saved to a temporary
cache ~org--file-cache~. A new optional argument ~NOCACHE~ is added
to ~org-file-contents~.
*** ~org-mode-restart~ now resets the newly added ~org--file-cache~.
Using ~C-c C-c~ on any keyword (like ~#+SETUPFILE~) will reset the
that file cache.
*** New option : ~org-table-duration-hour-zero-padding~
This variable allow computed durations in tables to be zero-padded.
*** New mode switch for table formulas : =U=
This mode omits seconds in durations.
** Removed functions
*** Org Timeline
This feature has been removed. Use a custom agenda view, possibly
narrowed to current buffer to achieve a similar functionality.
*** ~org-agenda-skip-entry-when-regexp-matches~ is obsolete
Use ~org-agenda-skip-if~ instead.
*** ~org-agenda-skip-subtree-when-regexp-matches~ is obsolete
Use ~org-agenda-skip-if~ instead.
*** ~org-agenda-skip-entry-when-regexp-matches-in-subtree~ is obsolete
Use ~org-agenda-skip-if~ instead.
*** ~org-minutes-to-clocksum-string~ is obsolete
Use ~org-duration-from-minutes~ instead.
*** ~org-hh:mm-string-to-minutes~ is obsolete
Use ~org-duration-to-minutes~ instead.
*** ~org-duration-string-to-minutes~ is obsolete
Use ~org-duration-to-minutes~ instead.
*** ~org-gnus-nnimap-cached-article-number~ is removed.
This function relied on ~nnimap-group-overview-filename~, which was
removed from Gnus circa September 2010.
** Removed options
*** ~org-agenda-repeating-timestamp-show-all~ is removed.
For an equivalent to a nil value, set ~org-agenda-show-future-repeats~
to nil and ~org-agenda-prefer-last-repeat~ to =t=.
*** ~org-gnus-nnimap-query-article-no-from-file~ is removed.
This variable has no effect, as it was relying on a function that was
removed from Gnus circa September 2010.
*** ~org-usenet-links-prefer-google~ is obsolete.
Use ~org-gnus-prefer-web-links~ instead.
*** ~org-publish-sitemap-file-entry-format~ is deprecated
One can provide new ~:sitemap-format-entry~ property for a function
equivalent to the removed format string.
*** ~org-enable-table-editor~ is removed.
Setting it to a nil value broke some other features (e.g., speed
keys).
*** ~org-export-use-babel~ cannot be set to ~inline-only~
The variable is now a boolean.
*** ~org-texinfo-def-table-markup~ is obsolete
Use ~org-texinfo-table-default-markup~ instead.
** New functions
*** ~org-publish-find-property~
This function can be used as a tool to format entries in a site-map,
in addition to ~org-publish-find-title~ and ~org-publish-find-date~.
*** ~org-list-to-org~
It is the reciprocal of ~org-list-to-lisp~, which see.
*** ~org-agenda-set-restriction-lock-from-agenda~
Call ~org-agenda-set-restriction-lock~ from the agenda.
** Miscellaneous
*** The Library of Babel now on Worg
The library-of-babel.org used to be accessible from the =doc/=
directory, distributed with Org’s core. It is now accessible
from the Worg community-driven documentation [[https://orgmode.org/worg/library-of-babel.html][here]].
If you want to contribute to it, please see [[https://orgmode.org/worg/org-contribute.html][how to contribute]].
*** Allow multiple columns view
Columns view is not limited to a single buffer anymore.
*** Org Attach obeys ~dired-dwim-target~
When a Dired buffer is opened next to the Org document being edited,
the prompt for file to attach can start in the Dired buffer's
directory if `dired-dwim-target' in non-nil.
*** ~org-fill-paragraph~ can now fill a whole region
*** More specific anniversary descriptions
Anniversary descriptions (used in the agenda view, for instance)
include the point in time, when the anniversary appears. This is,
in its most general form, just the date of the anniversary. Or
more specific terms, like "today", "tomorrow" or "in n days" are
used to describe the time span.
This feature allows to automatically change the description of an
anniversary, depending on if it occurs in the next few days or
far away in the future.
*** Computed dates in tables appear as inactive time stamps
*** Save point before opening a file with an unknown search option
When following a file link with a search option (e.g., =::#custom-id=)
that doesn't exist in the target file, save position before raising an
error. As a consequence, it is possible to jump back to the original
document with ~org-mark-ring-goto~ (default binding =C-c &=).
*** ~org-get-heading~ accepts two more optional arguments
See docstring for details.
*** New option ~org-babel-uppercase-example-markers~
This variable is a ~defcustom~ and replaces the variable
~org-babel-capitalize-example-region-markers~, which is a ~defvar~ and
is now obsolete.
*** =INCLUDE= keywords in commented trees are now ignored.
*** Default value for ~org-texinfo-text-markup-alist~ changed.
Now ~=...=~ markup uses ~@samp{}~ instead of ~@verb{}~. You can use
~@verb{}~ again by customizing the variable.
*** Texinfo exports example blocks as ~@example~
*** Texinfo exports inline source blocks as ~@code{}~
*** Texinfo default table markup is ~@asis~
It used to be ~@samp~ but ~@asis~ is neutral and, therefore, more
suitable as a default value.
*** Texinfo default process includes ~--no-split~ option
*** New entities : ~\dollar~ and ~\USD~
*** Support for date style URLs in =org-protocol://open-source=
URLs like =https://cool-blog.com/2017/05/20/cool-post/= are covered by
rewrite rules.
*** Add (C) =COMMENT= support to ~org-structure-template-alist~
* Version 9.0
** Incompatible changes
*** Emacs 23 support has been dropped
From now on, Org expects at least Emacs 24.3, although Emacs 24.4 or
above is suggested.
*** XEmacs support has been dropped
Incomplete compatibility layer with XEmacs has been removed. If you
want to take over maintenance of this compatibility, please contact
our mailing list.
*** New syntax for export blocks
Export blocks are explicitly marked as such at the syntax level to
disambiguate their parsing from special blocks. The new syntax is
#+BEGIN_SRC org
,#+BEGIN_EXPORT backend
...
,#+END_EXPORT
#+END_SRC
instead of
#+BEGIN_SRC org
,#+BEGIN_backend
...
,#+END_backend
#+END_SRC
As a consequence, =INCLUDE= keywords syntax is modified, e.g.,
#+BEGIN_SRC org
,#+INCLUDE: "file.org" HTML
#+END_SRC
becomes
#+BEGIN_SRC org
,#+INCLUDE: "file.org" export html
#+END_SRC
The following function repairs export blocks and =INCLUDE= keywords
using previous syntax:
#+BEGIN_SRC emacs-lisp
(defun org-repair-export-blocks ()
"Repair export blocks and INCLUDE keywords in current buffer."
(interactive)
(when (eq major-mode 'org-mode)
(let ((case-fold-search t)
(back-end-re (regexp-opt
'("HTML" "ASCII" "LATEX" "ODT" "MARKDOWN" "MD" "ORG"
"MAN" "BEAMER" "TEXINFO" "GROFF" "KOMA-LETTER")
t)))
(org-with-wide-buffer
(goto-char (point-min))
(let ((block-re (concat "^[ \t]*#\\+BEGIN_" back-end-re)))
(save-excursion
(while (re-search-forward block-re nil t)
(let ((element (save-match-data (org-element-at-point))))
(when (eq (org-element-type element) 'special-block)
(save-excursion
(goto-char (org-element-property :end element))
(save-match-data (search-backward "_"))
(forward-char)
(insert "EXPORT")
(delete-region (point) (line-end-position)))
(replace-match "EXPORT \\1" nil nil nil 1))))))
(let ((include-re
(format "^[ \t]*#\\+INCLUDE: .*?%s[ \t]*$" back-end-re)))
(while (re-search-forward include-re nil t)
(let ((element (save-match-data (org-element-at-point))))
(when (and (eq (org-element-type element) 'keyword)
(string= (org-element-property :key element) "INCLUDE"))
(replace-match "EXPORT \\1" nil nil nil 1)))))))))
#+END_SRC
Moreover, ~:export-block~ keyword used in ~org-export-define-backend~ and
~org-export-define-derived-backend~ is no longer used and needs to be
removed.
*** Footnotes changes
**** [1]-like constructs are not valid footnotes
Using =[1]= as a footnote was already discouraged in the manual, since
it introduced too many false-positives in many Org documents. These
constructs are now unsupported.
If you used =[N]= in some of your documents, consider turning them into
=[fn:N]=.
**** /Org Footnote/ library doesn't handle non-Org buffers
Commands for footnotes in an Org document no longer try to do
something in non-Org ones. If you need to have footnotes there,
consider using the =footnote.el= library, shipped with Emacs.
In particular, ~org-footnote-tag-for-non-org-mode-files~ no longer
exists.
*** ~org-file-apps~ no longer accepts S-expressions as commands
The variable now accepts functions of two arguments instead of plain
S-expressions. Replacing an S-expression with an appropriate function
is straightforward. For example
: ("pdf" . (foo))
becomes
: ("pdf" . (lambda (file link) (foo)))
*** The ~{{{modification-time}}}~ macro can get time via =vc=
The modification time will be determined via =vc.el= if the second
argument is non-nil. See the manual for details.
*** Preparation and completion functions in publishing projects change signature
Preparation and completion functions are now called with an argument,
which is the project property list. It used to be dynamically scoped
through the ~project-plist~ variable.
*** Old Babel header properties are no longer supported
Using header arguments as property names is no longer possible. As
such, the following
#+BEGIN_EXAMPLE
,* Headline
:PROPERTIES:
:exports: code
:var: a=1 b=2
:var+: c=3
:END:
#+END_EXAMPLE
should be written instead
#+BEGIN_EXAMPLE
,* Headline
:PROPERTIES:
:header-args: :exports code
:header-args+: :var a=1 b=2
:header-args+: :var c=3
:END:
#+END_EXAMPLE
Please note that, however, old properties were defined at the source
block definition. Current ones are defined where the block is called.
** New features
*** ~org-eww~ has been moved into core
*** New org-protocol key=value syntax
Org-protocol can now handle query-style parameters such as:
#+begin_example
org-protocol://store-link?url=http:%2F%2Flocalhost%2Findex.html&title=The%20title
org-protocol://capture?template=x&title=Hello&body=World&url=http:%2F%2Fexample.com
#+end_example
Old-style links such as
: org-protocol://store-link:/http:%2F%2Flocalhost%2Findex.html/The%20title
continue to be supported.
If you have defined your own handler functions for
~org-protocol-protocol-alist~, change them to accept either a property
list (for new-style links) or a string (for old-style links). Use
~org-protocol-parse-parameters~ to convert old-style links into property
lists.
*** New Org linter library
~org-lint~ can check syntax and report common issues in Org documents.
*** New option ~date-tree-last~ for ~org-agenda-insert-diary-strategy~
When ~org-agenda-insert-diary-strategy~ is set to ~date-tree-last~, diary
entries are added to last in the date tree.
*** New ~vbar~ entity
~\vbar~ or ~\vbar{}~ will be exported unconditionally as a =|=,
unlike to existing ~\vert~, which is expanded as ~|~ when using
a HTML derived export back-end.
*** Export
**** New =#+latex_compiler= keyword to set LaTeX compiler.
PDFLaTeX, XeLaTeX, and LuaLaTeX are supported. See the manual for
details.
**** New option ~org-export-with-broken-links~
This option tells the export process how to behave when encountering
a broken internal link. See its docstring for more information.
**** Attributes support in custom language environments for LaTeX export
Custom language environments for LaTeX export can now define the
string to be inserted during export, using attributes to indicate the
position of the elements. See variable ~org-latex-custom-lang-environments~
for more details.
**** New Texinfo ~options~ attribute on special blocks
Using ~:options~ as a Texinfo attribute, it is possible to add
information to custom environments. See manual for details.
**** New HTML ~id~ attributes on special, example and quote blocks
If the block has a =#+NAME:= attribute assigned, then the HTML element
will have an ~id~ attribute with that name in the HTML export. This
enables one to create links to these elements in other places, e.g.,
~text ~.
**** Listings with captions are now numbered in HTML export
The class associated to the numbering is "listing-number". If you
don't want these blocks to be numbered, as it was the case until now,
You may want to add ~.listing-number { display: none; }~ to the CSS
used.
**** Line Numbering in SRC/EXAMPLE blocks support arbitrary start number
The ~-n~ option to ~SRC~ and ~EXAMPLE~ blocks can now take a numeric
argument to specify the staring line number for the source or example
block. The ~+n~ option can now take a numeric argument that will be
added to the last line number from the previous block as the starting
point for the SRC/EXAMPLE block.
#+BEGIN_SRC org
,#+BEGIN_SRC emacs-lisp -n 20
;; this will export with line number 20
(message "This is line 21")
,#+END_SRC
,#+BEGIN_SRC emacs-lisp +n 10
;; This will be listed as line 31
(message "This is line 32")
,#+END_SRC
#+END_SRC
**** Allow toggling center for images in LaTeX export
With the global variable ~org-latex-images-centered~ or the local
attribute ~:center~ it is now possible to center an image in LaTeX
export.
**** Default CSS class ~org-svg~ for SVG images in HTML export
SVG images exported in HTML are now by default assigned a CSS class
~org-svg~ if no CSS class is specified with the ~:class~ attribute. By
default, the CSS styling of class ~org-svg~ specifies an image width of
90\thinsp{}% of the container the image.
**** Markdown footnote export customization
Variables ~org-md-footnotes-section~ and ~org-md-footnote-format~
introduced for =ox-md.el=. Both new variables define template strings
which can be used to customize the format of the exported footnotes
section and individual footnotes, respectively.
*** Babel
**** Blocks with coderefs labels can now be evaluated
The labels are removed prior to evaluating the block.
**** Support for Lua language
**** Support for SLY in Lisp blocks
See ~org-babel-lisp-eval-fn~ to activate it.
**** Support for Stan language
New ob-stan.el library.
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
https://orgmode.org/worg/org-contrib/babel/languages/ob-doc-stan.html
**** Support for Oracle databases via ~sqlplus~
=ob-sql= library supports running SQL blocks against an Oracle
database using ~sqlplus~. Use with properties like this (all
mandatory):
#+BEGIN_EXAMPLE
:engine oracle
:dbhost
:dbport <1521>
:dbuser
:database
:dbpassword
#+END_EXAMPLE
**** Improved support to Microsoft SQL Server via ~sqlcmd~
=ob-sql= library removes support to the ~msosql~ engine which uses the
deprecated ~osql~ command line tool, and replaces it with ~mssql~
engine which uses the ~sqlcmd~ command line tool. Use with properties
like this:
#+BEGIN_EXAMPLE
:engine mssql
:dbhost
:dbuser
:dbpassword
:database
#+END_EXAMPLE
If you want to use the *trusted connection* feature, omit *both* the
=dbuser= and =dbpassword= properties and add =cmdline -E= to the properties.
If your Emacs is running in a Cygwin environment, the =ob-sql= library
can pass the converted path to the =sqlcmd= tool.
**** Improved support of header arguments for postgresql
The postgresql engine in a sql code block now supports ~:dbport~ and
~:dbpassword~ as header arguments.
**** Support for additional plantuml output formats
The support for output formats of [[https://plantuml.com/][plantuml]] has been extended to now
include:
All Diagrams:
- png ::
- svg ::
- eps ::
- pdf ::
- vdx ::
- txt :: ASCII art
- utxt :: ASCII art using unicode characters
Class Diagrams:
- xmi ::
- html ::
State Diagrams:
- scxml ::
The output formats are determined by the file extension specified
using the :file property, e.g.:
#+begin_src plantuml :file diagram.png
@startuml
Alice -> Bob: Authentication Request
Bob --> Alice: Authentication Response
Alice -> Bob: Another authentication Request
Alice <-- Bob: another authentication Response
@enduml
#+end_src
Please note that *pdf* *does not work out of the box* and needs additional
setup in addition to plantuml. See [[https://plantuml.com/pdf.html]] for
details and setup information.
*** Rewrite of radio lists
Radio lists, i.e, Org plain lists in foreign buffers, have been
rewritten to be on par with Radio tables. You can use a large set of
parameters to control how a given list should be rendered. See manual
for details.
*** org-bbdb-anniversaries-future
Used like ~org-bbdb-anniversaries~, it provides a few days warning for
upcoming anniversaries (default: 7 days).
*** Clear non-repeated SCHEDULED upon repeating a task
If the task is repeated, and therefore done at least one, scheduling
information is no longer relevant. It is therefore removed.
See [[git:481719fbd5751aaa9c672b762cb43aea8ee986b0][commit message]] for more information.
*** Support for ISO week trees
ISO week trees are an alternative date tree format that orders entries
by ISO week and not by month.
For example:
: * 2015
: ** 2015-W35
: ** 2015-W36
: *** 2015-08-31 Monday
They are supported in org-capture via ~file+weektree~ and
~file+weektree+prompt~ target specifications.
*** Accept ~:indent~ parameter when capturing column view
When defining a "columnview" dynamic block, it is now possible to add
an :indent parameter, much like the one in the clock table.
On the other hand, stars no longer appear in an ITEM field.
*** Columns view
**** ~org-columns~ accepts a prefix argument
When called with a prefix argument, ~org-columns~ apply to the whole
buffer unconditionally.
**** New variable : ~org-agenda-view-columns-initially~
The variable used to be a ~defvar~, it is now a ~defcustom~.
**** Allow custom summaries
It is now possible to add new summary types, or override those
provided by Org by customizing ~org-columns-summary-types~, which see.
**** Allow multiple summaries for any property
Columns can now summarize the same property using different summary
types.
*** Preview LaTeX snippets in buffers not visiting files
*** New option ~org-attach-commit~
When non-nil, commit attachments with git, assuming the document is in
a git repository.
*** Allow conditional case-fold searches in ~org-occur~
When set to ~smart~, the new variable ~org-occur-case-fold-search~ allows
to mimic =isearch.el=: if the regexp searched contains any upper case
character (or character class), the search is case sensitive.
Otherwise, it is case insensitive.
*** More robust repeated =ox-latex= footnote handling
Repeated footnotes are now numbered by referring to a label in the
first footnote.
*** The ~org-block~ face is inherited by ~src-blocks~
This works also when =org-src-fontify-natively= is non-nil. It is also
possible to specify per-languages faces. See =org-src-block-faces= and
the manual for details.
*** Links are now customizable
Links can now have custom colors, tooltips, keymaps, display behavior,
etc. Links are now centralized in ~org-link-parameters~.
** New functions
*** ~org-next-line-empty-p~
It replaces the deprecated ~next~ argument to ~org-previous-line-empty-p~.
*** ~org-show-children~
It is a faster implementation of ~outline-show-children~.
** Removed functions
*** ~org-agenda-filter-by-tag-refine~ has been removed.
Use ~org-agenda-filter-by-tag~ instead.
*** ~org-agenda-todayp~ is deprecated.
Use ~org-agenda-today-p~ instead.
*** ~org-babel-get-header~ is removed.
Use ~org-babel--get-vars~ or ~assq~ instead, as applicable.
*** ~org-babel-trim~ is deprecated.
Use ~org-trim~ instead.
*** ~org-element-remove-indentation~ is deprecated.
Use ~org-remove-indentation~ instead.
*** ~org-image-file-name-regexp~ is deprecated
Use ~image-file-name-regexp~ instead.
The never-used-in-core ~extensions~ argument has been dropped.
*** ~org-list-parse-list~ is deprecated
Use ~org-list-to-lisp~ instead.
*** ~org-on-heading-p~ is deprecated
A comment to this effect was in the source code since 7.8.03, but
now a byte-compiler warning will be generated as well.
*** ~org-table-p~ is deprecated
Use ~org-at-table-p~ instead.
*** ~org-table-recognize-table.el~ is deprecated
It was not called by any org code since 2010.
*** Various reimplementations of cl-lib functions are deprecated
The affected functions are:
- ~org-count~
- ~org-remove-if~
- ~org-remove-if-not~
- ~org-reduce~
- ~org-every~
- ~org-some~
Additionally, ~org-sublist~ is deprecated in favor of ~cl-subseq~. Note
the differences in indexing conventions: ~org-sublist~ is 1-based and
end-inclusive; ~cl-subseq~ is 0-based and end-exclusive.
** Removed options
*** Remove all options related to ~ido~ or ~iswitchb~
This includes ~org-completion-use-iswitchb~ and ~org-completion-use-ido~.
Instead Org uses regular functions, e.g., ~completion-read~ so as to
let those libraries operate.
*** Remove ~org-list-empty-line-terminates-plain-lists~
Two consecutive blank lines always terminate all levels of current
plain list.
*** ~fixltx2e~ is removed from ~org-latex-default-packages-alist~
fixltx2e is obsolete, see LaTeX News 22.
** Miscellaneous
*** Add Icelandic smart quotes
*** Allow multiple receiver locations in radio tables and lists
*** Allow angular links within link descriptions
It is now allowed to write, e.g.,
~[[http:orgmode.org][]]~ as an equivalent to
~[[http:orgmode.org][file:unicorn.png]]~. The advantage of the former
is that spaces are allowed within the path.
*** Beamer export back-ends uses ~org-latex-prefer-user-labels~
*** ~:preparation-function~ called earlier during publishing
Functions in this list are called before any file is associated to the
current project. Thus, they can be used to generate to be published
Org files.
*** Function ~org-remove-indentation~ changes.
The new algorithm doesn't remove TAB characters not used for
indentation.
*** Secure placeholders in capture templates
Placeholders in capture templates are no longer expanded recursively.
However, ~%(...)~ constructs are expanded very late, so you can fill
the contents of the S-exp with the replacement text of non-interactive
placeholders. As before, interactive ones are still expanded as the
very last step, so the previous statement doesn't apply to them.
Note that only ~%(...)~ placeholders initially present in the
template, or introduced using a file placeholder, i.e., ~%[...]~ are
expanded. This prevents evaluating potentially malicious code when
another placeholder, e.g., ~%i~ expands to a S-exp.
*** Links stored by ~org-gnus-store-link~ in nnir groups
Since gnus nnir groups are temporary, ~org-gnus-store-link~ now refers
to the article's original group.
*** ~org-babel-check-confirm-evaluate~ is now a function instead of a macro
The calling convention has changed.
*** HTML export table row customization changes
Variable ~org-html-table-row-tags~ has been split into
~org-html-table-row-open-tag~ and ~org-html-table-row-close-tag~.
Both new variables can be either a string or a function which will be
called with 6 parameters.
*** =ITEM= special property returns headline without stars
*** Rename ~org-insert-columns-dblock~ into ~org-columns-insert-dblock~
The previous name is, for the time being, kept as an obsolete alias.
*** ~org-trim~ can preserve leading indentation.
When setting a new optional argument to a non-nil value, ~org-trim~
preserves leading indentation while removing blank lines at the
beginning of the string. The behavior is identical for white space at
the end of the string.
*** Function ~org-info-export~ changes.
HTML links created from certain info links now point to =gnu.org= URL's rather
than just to local files. For example info links such as =info:emacs#List
Buffers= used to be converted to HTML links like this:
: emacs#List Buffers
where local file =emacs.html= is referenced.
For most folks this file does not exist.
Thus the new behavior is to generate this HTML link instead:
: emacs#List Buffers
All emacs related info links are similarly translated plus few other
=gnu.org= manuals.
*** Repeaters with a ~++~ interval and a time can be shifted to later today
Previously, if a recurring task had a timestamp of
~<2016-01-01 Fri 20:00 ++1d>~ and was completed on =2016-01-02= at
=08:00=, the task would skip =2016-01-02= and would be rescheduled for
=2016-01-03=. Timestamps with ~++~ cookies and a specific time will
now shift to the first possible future occurrence, even if the
occurrence is later the same day the task is completed. (Timestamps
already in the future are still shifted one time further into the
future.)
*** ~org-mobile-action-alist~ is now a defconst
It used to be a defcustom, with a warning that it shouldn't be
modified anyway.
*** ~file+emacs~ and ~file+sys~ link types are deprecated
They are still supported in Org 9.0 but will eventually be removed in
a later release. Use ~file~ link type along with universal arguments
to force opening it in either Emacs or with system application.
*** New defcustom ~org-babel-J-command~ stores the j command
*** New defalias ~org-babel-execute:j~
Allows J source blocks be indicated by letter j. Previously the
indication letter was solely J.
*** ~org-open-line~ ignores tables at the very beginning of the buffer
When ~org-special-ctrl-o~ is non-nil, it is impractical to create
a blank line above a table at the beginning of the document. Now, as
a special case, ~org-open-line~ behaves normally in this situation.
*** ~org-babel-hash-show-time~ is now customizable
The experimental variable used to be more or less confidential, as
a ~defvar~.
*** New ~:format~ property to parsed links
It defines the format of the original link. Possible values are:
~plain~, ~bracket~ and ~angle~.
* Version 8.3
** Incompatible changes
*** Properties drawers syntax changes
Properties drawers are now required to be located right after a
headline and its planning line, when applicable.
It will break some documents as TODO states changes were sometimes
logged before the property drawer.
The following function will repair them:
#+BEGIN_SRC emacs-lisp
(defun org-repair-property-drawers ()
"Fix properties drawers in current buffer.
Ignore non Org buffers."
(when (eq major-mode 'org-mode)
(org-with-wide-buffer
(goto-char (point-min))
(let ((case-fold-search t)
(inline-re (and (featurep 'org-inlinetask)
(concat (org-inlinetask-outline-regexp)
"END[ \t]*$"))))
(org-map-entries
(lambda ()
(unless (and inline-re (org-looking-at-p inline-re))
(save-excursion
(let ((end (save-excursion (outline-next-heading) (point))))
(forward-line)
(when (org-looking-at-p org-planning-line-re) (forward-line))
(when (and (< (point) end)
(not (org-looking-at-p org-property-drawer-re))
(save-excursion
(and (re-search-forward org-property-drawer-re end t)
(eq (org-element-type
(save-match-data (org-element-at-point)))
'drawer))))
(insert (delete-and-extract-region
(match-beginning 0)
(min (1+ (match-end 0)) end)))
(unless (bolp) (insert "\n"))))))))))))
#+END_SRC
*** Using "COMMENT" is now equivalent to commenting with "#"
If you used "COMMENT" in headlines to prevent a subtree from being
exported, you can still do it but all information within the subtree
is now commented out, i.e. no #+OPTIONS line will be parsed or taken
into account when exporting.
If you want to exclude a headline from export while using its contents
for setting options, use =:noexport:= (see =org-export-exclude-tags=.)
*** =#+CATEGORY= keywords no longer apply partially to document
It was possible to use several such keywords and have them apply to
the text below until the next one, but strongly deprecated since Org
5.14 (2008).
=#+CATEGORY= keywords are now global to the document. You can use node
properties to set category for a subtree, e.g.,
#+BEGIN_SRC org
,* Headline
:PROPERTIES:
:CATEGORY: some category
:END:
#+END_SRC
*** New variable to control visibility when revealing a location
~org-show-following-heading~, ~org-show-siblings~, ~org-show-entry-below~
and ~org-show-hierarchy-above~ no longer exist. Instead, visibility is
controlled through a single variable: ~org-show-context-detail~, which
see.
*** Replace disputed keys again when reading a date
~org-replace-disputed-keys~ has been ignored when reading date since
version 8.1, but the former behavior is restored again.
Keybinding for reading date can be customized with a new variable
~org-read-date-minibuffer-local-map~.
*** No default title is provided when =TITLE= keyword is missing
Skipping =TITLE= keyword no longer provides the current file name, or
buffer name, as the title. Instead, simply ignore the title.
*** Default bindings of =C-c C-n= and =C-c C-p= changed
The key sequences =C-c C-n= and =C-c C-p= are now bound to
~org-next-visible-heading~ and ~org-previous-visible-heading~
respectively, rather than the =outline-mode= versions of these
functions. The Org version of these functions skips over inline tasks
(and even-level headlines when ~org-odd-levels-only~ is set).
*** ~org-element-context~ no longer return objects in keywords
~org-element-context~ used to return objects on some keywords, i.e.,
=TITLE=, =DATE= and =AUTHOR=. It now returns only the keyword.
*** ~org-timer-default-timer~ type changed from number to string
If you have, in your configuration, something like =(setq
org-timer-default-timer 10)= replace it with =(setq
org-timer-default-timer "10")=.
*** Functions signature changes
The following functions require an additional argument. See their
docstring for more information.
- ~org-export-collect-footnote-definitions~
- ~org-html-format-headline-function~
- ~org-html-format-inlinetask-function~
- ~org-latex-format-headline-function~
- ~org-latex-format-inlinetask-function~
- ~org-link-search~
** New features
*** Default lexical evaluation of emacs-lisp source blocks
Emacs-lisp source blocks in Babel are now evaluated using lexical
scoping. There is a new header to control this behavior.
The default results in an eval with lexical scoping.
:lexical yes
This turns lexical scoping off in the eval (the former behavior).
:lexical no
This uses the lexical environment with x=42 in the eval.
:lexical '((x . 42))
*** Behavior of ~org-return~ changed
If point is before or after the headline title, insert a new line
without changing the headline.
*** Hierarchies of tags
The functionality of nesting tags in hierarchies is added to Org mode.
This is the generalization of what was previously called "Tag groups"
in the manual. That term is now changed to "Tag hierarchy".
The following in-buffer definition:
#+BEGIN_SRC org
,#+TAGS: [ Group : SubOne SubTwo ]
,#+TAGS: [ SubOne : SubOne1 SubOne2 ]
,#+TAGS: [ SubTwo : SubTwo1 SubTwo2 ]
#+END_SRC
Should be seen as the following tree of tags:
- Group
- SubOne
- SubOne1
- SubOne2
- SubTwo
- SubTwo1
- SubTwo2
Searching for "Group" should return all tags defined above. Filtering
on SubOne filters also it's sub-tags. Etc.
There is no limit on the depth for the tag hierarchy.
*** Additional syntax for non-unique grouptags
Additional syntax is defined for grouptags if the tags in the group
don't have to be distinct on a heading.
Grouptags had to previously be defined with { }. This syntax is
already used for exclusive tags and Grouptags need their own,
non-exclusive syntax. This behavior is achieved with [ ]. Note: { }
can still be used also for Grouptags but then only one of the given
tags can be used on the headline at the same time. Example:
[ group : sub1 sub2 ]
#+BEGIN_SRC org
,* Test :sub1:sub2:
#+END_SRC
This is a more general case than the already existing syntax for
grouptags; { }.
*** Define regular expression patterns as tags
Tags can be defined as grouptags with regular expressions as
"sub-tags".
The regular expressions in the group must be marked up within { }.
Example use:
: #+TAGS: [ Project : {P@.+} ]
Searching for the tag Project will now list all tags also including
regular expression matches for P@.+. This is good for example for
projects tagged with a common identifier, i.e. P@2014_OrgTags.
*** Filtering in the agenda on grouptags (Tag hierarchies)
Filtering in the agenda on grouptags filters all of the related tags.
Except if a filter is applied with a (double) prefix-argument.
Filtering in the agenda on subcategories does not filter the "above"
levels anymore.
If a grouptag contains a regular expression the regular expression
is also used as a filter.
*** Minor refactoring of ~org-agenda-filter-by-tag~
Now uses the argument ARG and optional argument exclude instead of
strip and narrow. ARG because the argument has multiple purposes and
makes more sense than strip now. The term "narrowing" is changed to
exclude.
The main purpose is for the function to make more logical sense when
filtering on tags now when tags can be structured in hierarchies.
*** Babel: support for sed scripts
Thanks to Bjarte Johansen for this feature.
*** Babel: support for Processing language
New ob-processing.el library.
This library implements necessary functions for implementing editing
of Processing code blocks, viewing the resulting sketches in an
external viewer, and HTML export of the sketches.
Check the documentation for more details.
Thanks to Jarmo Hurri for this feature.
*** New behavior for ~org-toggle-latex-fragment~
The new behavior is the following:
- With a double prefix argument or with a single prefix argument when
point is before the first headline, toggle overlays in the whole
buffer;
- With a single prefix argument, toggle overlays in the current
subtree;
- On latex code, toggle overlay at point;
- Otherwise, toggle overlays in the current section.
*** Additional markup with =#+INCLUDE= keyword
The content of the included file can now be optionally marked up, for
instance as HTML. See the documentation for details.
*** File links with =#+INCLUDE= keyword
Objects can be extracted via =#+INCLUDE= using file links. It is
possible to include only the contents of the object. See manual for
more information.
*** Drawers do not need anymore to be referenced in =#+DRAWERS=
One can use a drawer without listing it in the =#+DRAWERS= keyword,
which is now obsolete. As a consequence, this change also deprecates
~org-drawers~ variable.
*** ~org-edit-special~ can edit export blocks
Using C-c ' on an export block now opens a sub-editing buffer. Major
mode in that buffer is determined by export backend name (e.g.,
"latex" \to "latex-mode"). You can define exceptions to this rule by
configuring ~org-src-lang-modes~, which see.
*** Additional =:hline= processing to ob-shell
If the argument =:hlines yes= is present in a babel call, an optional
argument =:hlines-string= can be used to define a string to use as a
representation for the lisp symbol ='hline= in the shell program. The
default is =hline=.
*** Markdown export supports switches in source blocks
For example, it is now possible to number lines using the =-n= switch in
a source block.
*** New option in ASCII export
Plain lists can have an extra margin by setting ~org-ascii-list-margin~
variable to an appropriate integer.
*** New blocks in ASCII export
ASCII export now supports =#+BEGIN_JUSTIFYRIGHT= and =#+BEGIN_JUSTIFYLEFT=
blocks. See documentation for details.
*** More back-end specific publishing options
The number of publishing options specific to each back-end has been
increased. See manual for details.
*** Export inline source blocks
Inline source code was used to be removed upon exporting. They are
now handled as standard code blocks, i.e., the source code can appear
in the output, depending on the parameters.
*** Extend ~org-export-first-sibling-p~ and ~org-export-last-sibling-p~
These functions now support any element or object, not only headlines.
*** New function: ~org-export-table-row-in-header-p~
*** New function: ~org-export-get-reference~
*** New function: ~org-element-lineage~
This function deprecates ~org-export-get-genealogy~. It also provides
more features. See docstring for details.
*** New function: ~org-element-copy~
*** New filter: ~org-export-filter-body-functions~
Functions in this filter are applied on the body of the exported
document, before wrapping it within the template.
*** New :environment parameter when exporting example blocks to LaTeX
: #+ATTR_LATEX: :environment myverbatim
: #+BEGIN_EXAMPLE
: This sentence is false.
: #+END_EXAMPLE
will be exported using =@samp(myverbatim)= instead of =@samp(verbatim)=.
*** Various improvements on radio tables
Radio tables feature now relies on Org's export framework ("ox.el").
~:no-escape~ parameter no longer exists, but additional global
parameters are now supported: ~:raw~, ~:backend~. Moreover, there are new
parameters specific to some pre-defined translators, e.g.,
~:environment~ and ~:booktabs~ for ~orgtbl-to-latex~. See translators
docstrings (including ~orgtbl-to-generic~) for details.
*** Non-floating minted listings in LaTeX export
It is not possible to specify =#+attr_latex: :float nil= in conjunction
with source blocks exported by the minted package.
*** Field formulas can now create columns as needed
Previously, evaluating formulas that referenced out-of-bounds columns
would throw an error. A new variable ~org-table-formula-create-columns~
was added to adjust this behavior. It is now possible to silently add
new columns, to do so with a warning or to explicitly ask the user
each time.
*** ASCII plot
Ability to plot values in a column through ASCII-art bars. See manual
for details.
*** New hook: ~org-archive-hook~
This hook is called after successfully archiving a subtree, with point
on the original subtree, not yet deleted.
*** New option: ~org-attach-archive-delete~
When non-nil, attachments from archived subtrees are removed.
*** New option: ~org-latex-caption-above~
This variable generalizes ~org-latex-table-caption-above~, which is now
deprecated. In addition to tables, it applies to source blocks,
special blocks and images. See docstring for more information.
*** New option: ~org-latex-prefer-user-labels~
See the docstring for more information.
*** Export unnumbered headlines
Headlines, for which the property ~UNNUMBERED~ is non-nil, are now
exported without section numbers irrespective of their levels. The
property is inherited by children.
*** Tables can be sorted with an arbitrary function
It is now possible to specify a function, both programmatically,
through a new optional argument, and interactively with ~f~ or ~F~ keys,
to sort a table.
*** Table of contents can be local to a section
The ~TOC~ keywords now accepts an optional ~local~ parameter. See manual
for details.
*** Countdown timers can now be paused
~org-timer-pause-time~ now pauses and restarts both relative and
countdown timers.
*** New option ~only-window~ for ~org-agenda-window-setup~
When ~org-agenda-window-setup~ is set to ~only-window~, the agenda is
displayed as the sole window of the current frame.
*** ~{{{date}}}~ macro supports optional formatting argument
It is now possible to supply and optional formatting argument to
~{{{date}}}~. See manual for details.
*** ~{{{property}}}~ macro supports optional search argument
It is now possible to supply an optional search option to
~{{{property}}}~ in order to retrieve remote properties optional. See
manual for details.
*** New option ~org-export-with-title~
It is possible to suppress the title insertion with ~#+OPTIONS:
title:nil~ or globally using the variable ~org-export-with-title~.
*** New entities family: "\_ "
"\_ " are used to insert up to 20 contiguous spaces in various
back-ends. In particular, this family can be used to introduce
leading spaces within table cells.
*** New MathJax configuration options
Org uses the MathJax CDN by default. See the manual and the docstring
of ~org-html-mathjax-options~ for details.
*** New behavior in `org-export-options-alist'
When defining a back-end, it is now possible to specify to give
`parse' behavior on a keyword. It is equivalent to call
`org-element-parse-secondary-string' on the value.
However, parsed =KEYWORD= is automatically associated to an
=:EXPORT_KEYWORD:= property, which can be used to override the keyword
value during a subtree export. Moreover, macros are expanded in such
keywords and properties.
*** Viewport support in html export
Viewport for mobile-optimized website is now automatically inserted
when exporting to html. See ~org-html-viewport~ for details.
*** New ~#+SUBTITLE~ export keyword
Org can typeset a subtitle in some export backends. See the manual
for details.
*** Remotely edit a footnote definition
Calling ~org-edit-footnote-reference~ (C-c ') on a footnote reference
allows to edit its definition, as long as it is not anonymous, in a
dedicated buffer. It works even if buffer is currently narrowed.
*** New function ~org-delete-indentation~ bound to ~M-^~
Work as ~delete-indentation~ unless at heading, in which case text is
added to headline text.
*** Support for images in Texinfo export
~Texinfo~ back-end now handles images. See the manual for details.
*** Support for captions in Texinfo export
Tables and source blocks can now have captions. Additionally, lists
of tables and lists of listings can be inserted in the document with
=#+TOC= keyword.
*** Countdown timer support hh:mm:ss format
In addition to setting countdown timers in minutes, they can also be
set using the hh:mm:ss format.
*** Extend ~org-clone-subtree-with-time-shift~
~org-clone-subtree-with-time-shift~ now accepts 0 as an argument for the
number of clones, which removes the repeater from the original subtree
and creates one shifted, repeating clone.
*** New time block for clock tables: ~untilnow~
It encompasses all past closed clocks.
*** Support for the ~polyglossia~ LaTeX package
See the docstring of ~org-latex-classes~ and
~org-latex-guess-polyglossia-language~ for details.
*** None-floating tables, graphics and blocks can have captions
*** `org-insert-heading' can be forced to insert top-level headline
** Removed functions
*** Removed function ~org-translate-time~
Use ~org-timestamp-translate~ instead.
*** Removed function ~org-beamer-insert-options-template~
This function inserted a Beamer specific template at point or in
current subtree. Use ~org-export-insert-default-template~ instead, as
it provides more features and covers all export back-ends. It is also
accessible from the export dispatcher.
*** Removed function ~org-timer-cancel-timer~
~org-timer-stop~ now stops both relative and countdown timers.
*** Removed function ~org-export-solidify-link-text~
This function, being non-bijective, introduced bug in internal
references. Use ~org-export-get-reference~ instead.
*** Removed function ~org-end-of-meta-data-and-drawers~
The function is superseded by ~org-end-of-meta-data~, called with an
optional argument.
*** Removed functions ~org-table-colgroup-line-p~, ~org-table-cookie-line-p~
These functions were left-over from pre 8.0 era. They are not correct
anymore. Since they are not needed, they have no replacement.
** Removed options
*** ~org-list-empty-line-terminates-plain-lists~ is deprecated
It will be kept in code base until next release, for backward
compatibility.
If you need to separate consecutive lists with blank lines, always use
two of them, as if this option was nil (default value).
*** ~org-export-with-creator~ is a boolean
Special ~comment~ value is no longer allowed. It is possible to use a
body filter to add comments about the creator at the end of the
document instead.
*** Removed option =org-html-use-unicode-chars=
Setting this to non-nil was problematic as it converted characters
everywhere in the buffer, possibly corrupting URLs.
*** Removed option =org-babel-sh-command=
This undocumented option defaulted to the value of =shell-file-name= at
the time of loading =ob-shell=. The new behavior is to use the value
of =shell-file-name= directly when the shell language is =shell=. To chose
a different shell, either customize =shell-file-name= or bind this
variable locally.
*** Removed option =org-babel-sh-var-quote-fmt=
This undocumented option was supposed to provide different quoting
styles when changing the shell type. Changing the shell type can now
be done directly from the source block and the quoting style has to be
compatible across all shells, so a customization doesn't make sense
anymore. The chosen hard coded quoting style conforms to POSIX.
*** Removed option ~org-insert-labeled-timestamps-at-point~
Setting this option to anything else that the default value (nil)
would create invalid planning info. This dangerous option is now
removed.
*** Removed option ~org-koma-letter-use-title~
Use org-export-with-title instead. See also below.
*** Removed option ~org-entities-ascii-explanatory~
This variable has no effect since Org 8.0.
*** Removed option ~org-table-error-on-row-ref-crossing-hline~
This variable has no effect since August 2009.
*** Removed MathML-related options from ~org-html-mathjax-options~
MathJax automatically chooses the best display technology based on the
end-users browser. You may force initial usage of MathML via
~org-html-mathjax-template~ or by setting the ~path~ property of
~org-html-mathjax-options~.
*** Removed comment-related filters
~org-export-filter-comment-functions~ and
~org-export-filter-comment-block-functions~ variables do not exist
anymore.
** Miscellaneous
*** Strip all meta data from ITEM special property
ITEM special property does not contain TODO, priority or tags anymore.
*** File names in links accept are now compatible with URI syntax
Absolute file names can now start with =///= in addition to =/=. E.g.,
=[[file:///home/me/unicorn.jpg]]=.
*** Footnotes in included files are now local to the file
As a consequence, it is possible to include multiple Org files with
footnotes in a master document without being concerned about footnote
labels colliding.
*** Mailto links now use regular URI syntax
This change deprecates old Org syntax for mailto links:
=mailto:user@domain::Subject=.
*** =QUOTE= keywords do not exist anymore
=QUOTE= keywords have been deprecated since Org 8.2.
*** Select tests to perform with the build system
The build system has been enhanced to allow test selection with a
regular expression by defining =BTEST_RE= during the test invocation.
This is especially useful during bisection to find just when a
particular test failure was introduced.
*** Exact heading search for external links ignore spaces and cookies
Exact heading search for links now ignore spaces and cookies. This is
the case for links of the form ~file:projects.org::*task title~, as well
as links of the form ~file:projects.org::some words~ when
~org-link-search-must-match-exact-headline~ is not nil.
*** ~org-latex-hyperref-template~, ~org-latex-title-command~ formatting
New formatting keys are supported. See the respective docstrings.
Note, ~org-latex-hyperref-template~ has a new default value.
*** ~float, wasysym, marvosym~ are removed from ~org-latex-default-packages-alist~
If you require any of these package add them to your preamble via
~org-latex-packages-alist~. Org also uses default LaTeX ~\tolerance~ now.
*** When exporting, throw an error on unresolved id/fuzzy links and code refs
This helps spotting wrong links.
* Version 8.2
** Incompatible changes
*** =ob-sh.el= renamed to =ob-shell=
This may require two changes in user config.
1. In =org-babel-do-load-languages=, change =(sh . t)= to =(shell . t)=.
2. Edit =local.mk= files to change the value of =BTEST_OB_LANGUAGES=
to remove "sh" and include "shell".
*** Combine org-mac-message.el and org-mac-link-grabber into org-mac-link.el
Please remove calls to =(require 'org-mac-message)= and =(require
'org-mac-link-grabber)= in your =.emacs= initialization file. All you
need now is =(require 'org-mac-link)=.
Additionally, replace any calls to =ogml-grab-link= to
=org-mac-grab-link=. For example, replace this line:
: (define-key org-mode-map (kbd "C-c g") 'omgl-grab-link)
with this:
: (define-key org-mode-map (kbd "C-c g") 'org-mac-grab-link)
*** HTML export: Replace =HTML_HTML5_FANCY= by =:html-html5-fancy= (...)
Some of the HTML specific export options in Org <8.1 are either nil or
t, like =#+HTML_INCLUDE_STYLE=. We replaced these binary options with
option keywords like :html-include-style.
So you need to replace
: #+HTML_INCLUDE_STYLE: t
by
: #+OPTIONS: :html-include-style t
Options affected by this change: =HTML5_FANCY=, =HTML_INCLUDE_SCRIPTS=
and =HTML_INCLUDE_STYLE=.
*** Add an argument to ~org-export-to-file~ and ~org-export-to-buffer~
~org-export-to-file~ and ~org-export-to-file~ can run in a different
process when provided a non-nil =ASYNC= optional argument, without
relying on ~org-export-async-start~ macro.
Since =ASYNC= is the first of optional arguments, you have to shift
the other optional arguments accordingly.
*** Export back-ends are now structures
Export back-ends are now structures, and stored as such in the
communication channel during an export process. In other words, from
now on, ~(plist-get info :back-end)~ will return a structure instead
of a symbol.
Arguments in hooks and in filters are still symbols, though.
** Important bugfixes
*** [[doc:org-insert-heading][org-insert-heading]] has been rewritten and bugs are now fixed
*** The replacement of disputed keys is now turned of when reading a date
*** Match string for sparse trees can now contain a slash in a property value
You can now have searches like SOMEPROP="aaa/bbb". Until now,
this would break because the slash would be interpreted as the
separator starting a TOTO match string.
** New features
*** =C-c ^ x= will now sort checklist items by their checked status
See [[doc:org-sort-list][org-sort-list]]: hitting =C-c ^ x= will put checked items at the end
of the list.
*** Various LaTeX export enhancements
- Support SVG images
- Support for .pgf files
- LaTeX Babel blocks can now be exported as =.tikz= files
- Allow =latexmk= as an option for [[doc:org-latex-pdf-process][org-latex-pdf-process]]
- When using =\usepackage[AUTO]{babel}=, AUTO will automatically be
replaced with a value compatible with ~org-export-default-language~
or ~LANGUAGE~ keyword.
- The dependency on the =latexsym= LaTeX package has been removed, we
now use =amssymb= symbols by default instead.
*** New functions for paragraph motion
The commands =C-down= and =C-up= now invoke special commands
that use knowledge from the org-elements parser to move the cursor
in a paragraph-like way.
*** New entities in =org-entities.el=
Add support for ell, imath, jmath, varphi, varpi, aleph, gimel, beth,
dalet, cdots, S (§), dag, ddag, colon, therefore, because, triangleq,
leq, geq, lessgtr, lesseqgtr, ll, lll, gg, ggg, prec, preceq,
preccurlyeq, succ, succeq, succurlyeq, setminus, nexist(s), mho,
check, frown, diamond. Changes loz, vert, checkmark, smile and tilde.
*** Anonymous export back-ends
~org-export-create-backend~ can create anonymous export back-ends,
which can then be passed to export functions like
~org-export-to-file~, ~org-export-to-buffer~ or ~org-export-as~.
It allows for quick translation of Org syntax without the overhead of
registering a new back-end.
*** New agenda fortnight view
The agenda has not, in addition to day, week, month, and year
views, also a fortnight view covering 14 days.
** New options
*** New option [[doc:org-bookmark-names-plist][org-bookmark-names-plist]]
This allows to specify the names of automatic bookmarks.
*** New option [[doc:org-agenda-ignore-drawer-properties][org-agenda-ignore-drawer-properties]]
This allows more flexibility when optimizing the agenda generation.
See https://orgmode.org/worg/agenda-optimization.html for details.
*** New option: [[doc:org-html-link-use-abs-url][org-html-link-use-abs-url]] to force using absolute URLs
This is an export/publishing option, and should be used either within
the =#+OPTIONS= line(s) or within a [[doc:org-publish-project-alist][org-publish-project-alist]].
Setting this option to =t= is needed when the HTML output does not
allow relative URLs. For example, the =contrib/lisp/ox-rss.el=
library produces a RSS feed, and RSS feeds need to use absolute URLs,
so a combination of =:html-link-home "..." and :html-link-use-abs-url
t= is required---see the configuration example in the comment section
of =ox-rss.el=.
*** New option [[doc:org-babel-ditaa-java-cmd][org-babel-ditaa-java-cmd]]
This makes java executable configurable for ditaa blocks.
*** New options [[doc:org-babel-latex-htlatex][org-babel-latex-htlatex]] and [[doc:org-babel-latex-htlatex-packages][org-babel-latex-htlatex-packages]]
This enables SVG generation from latex code blocks.
*** New option: [[doc:org-habit-show-done-always-green][org-habit-show-done-always-green]]
See [[https://lists.gnu.org/r/emacs-orgmode/2013-05/msg00214.html][this message]] from Max Mikhanosha.
*** New option: [[doc:org-babel-inline-result-wrap][org-babel-inline-result-wrap]]
If you set this to the following
: (setq org-babel-inline-result-wrap "$%s$")
then inline code snippets will be wrapped into the formatting string.
*** New option: [[doc:org-special-ctrl-o][org-special-ctrl-o]]
This variable can be used to turn off the special behavior of
=C-o= in tables.
** New contributed packages
- =ox-bibtex.el= by Nicolas Goaziou :: an utility to handle BibTeX
export to both LaTeX and HTML exports. It uses the [[https://www.lri.fr/~filliatr/bibtex2html/][bibtex2html]]
software.
- =org-screenshot.el= by Max Mikhanosha :: an utility to handle
screenshots easily from Org, using the external tool [[https://freecode.com/projects/scrot][scrot]].
** Miscellaneous
*** "QUOTE" keywords in headlines are deprecated
"QUOTE" keywords are an undocumented feature in Org. When a headline
starts with the keyword "QUOTE", its contents are parsed as
a ~quote-section~ and treated as an example block. You can achieve
the same with example blocks.
This feature is deprecated and will be removed in the next Org
release.
* Version 8.0.1
** Installation
Installation instructions have been updated and simplified.
If you have troubles installing or updating Org, focus on these
instructions:
- when updating via a =.zip/.tar.gz= file, you only need to set the
=load-path= in your =.emacs=. Set it before any other Org
customization that would call autoloaded Org functions.
- when updating by pulling Org's Git repository, make sure to create the
correct autoloads. You can do this by running =~$ make autoloads= (to
only create the autoloads) or by running =~$ make= (to also compile
the Emacs lisp files.) =~$ make help= and =~$ make helpall= gives you
detailed explanations.
- when updating through ELPA (either from GNU ELPA or from Org ELPA),
you have to install Org's ELPA package in a session where no Org
function has been called already.
When in doubt, run =M-x org-version RET= and see if you have a mixed-up
installation.
See https://orgmode.org/org.html#Installation for details.
** Incompatible changes
Org 8.0 is the most disruptive major version of Org.
If you configured export options, you will have to update some of them.
If you used =#+ATTR_*= keywords, the syntax of the attributes changed and
you will have to update them.
Below is a list of changes for which you need to take action.
See https://orgmode.org/worg/org-8.0.html for the most recent version of
this list and for detailed instructions on how to migrate.
**** New export engine
Org 8.0 comes with a new export engine written by Nicolas Goaziou. This
export engine relies on ~org-element.el~ (Org's syntax parser), which was
already in Org's core. This new export engine triggered the rewriting of
/all/ export back-ends.
The most visible change is the export dispatcher, accessible through the
keybinding =C-c C-e=. By default, this menu only shows some of the
built-in export formats, but you can add more formats by loading them
directly (e.g., =(require 'ox-texinfo)= or by configuring the option
[[doc:org-export-backends][org-export-backends]].
More contributed back-ends are available from the =contrib/= directory, the
corresponding files start with the =ox-= prefix.
If you customized an export back-end (like HTML or LaTeX), you will need to
rename some options so that your customization is not lost. Typically, an
option starting with =org-export-html-= is now named =org-html-=. See the
manual for details and check [[https://orgmode.org/worg/org-8.0.html][this Worg page]] for directions.
**** New syntax for #+ATTR_HTML/LaTeX/... options
: #+ATTR_HTML width="200px"
should now be written
: #+ATTR_HTML :width 200px
Keywords like =#+ATTR_HTML= and =#+ATTR_LaTeX= are defined in their
respective back-ends, and the list of supported parameters depends on
each backend. See Org's manual for details.
**** ~org-remember.el~ has been removed
You cannot use =remember.el= anymore to capture notes.
Support for remember templates has been obsoleted since long, it is
now fully removed.
Use =M-x org-capture-import-remember-templates RET= to import your
remember templates into capture templates.
**** ~org-jsinfo.el~ has been merged into ~ox-html.el~
If you were requiring ~ox-jsinfo.el~ in your ~.emacs.el~ file, you
will have to remove this requirement from your initialization file.
**** Note for third-party developers
The name of the files for export back-end have changed: we now use the
prefix =ox-= for those files (like we use the =ob-= prefix for Babel
files.) For example ~org-html.el~ is now ~ox-html.el~.
If your code relies on these files, please update the names in your
code.
**** Packages moved from core to contrib
Since packages in Org's core are meant to be part of GNU Emacs, we try
to be minimalist when it comes to adding files into core. For 8.0, we
moved some contributions into the =contrib/= directory.
The rationale for deciding that these files should live in =contrib/=
is either because they rely on third-party software that is not
included in Emacs, or because they are not targeting a significant
user-base.
- org-colview-xemacs.el
- org-mac-message.el
- org-mew.el
- org-wl.el
- ox-freedmind.el
- ox-taskjuggler.el
Note that ~ox-freedmind.el~ has been rewritten by Jambunathan,
~org-mew.el~ has been enhanced by Tokuya Kameshima and
~ox-taskjuggler.el~ by Nicolas Goaziou and others.
Also, the Taskjuggler exporter now uses TJ3 by default. John Hendy
wrote [[https://orgmode.org/worg/org-tutorials/org-taskjuggler3.html][a tutorial on Worg]] for the TJ3 export.
** New packages in core
*** ~ob-makefile.el~ by Eric Schulte and Thomas S. Dye
=ob-makefile.el= implements Org Babel support for Makefile tangling.
*** ~ox-man.el~ by Luis Anaya
=ox-man.el= allows you to export Org files to =man= pages.
*** ~ox-md.el~ by Nicolas Goaziou
=ox-md.el= allows you to export Org files to Markdown files, using the
vanilla [[https://daringfireball.net/projects/markdown/][Markdown syntax]].
*** ~ox-texinfo.el~ by Jonathan Leech-Pepin
=ox-texinfo.el= allows you to export Org files to [[https://www.gnu.org/software/texinfo/][Texinfo]] files.
** New packages in contrib
*** ~ob-julia.el~ by G. Jay Kerns
[[https://julialang.org/][Julia]] is a new programming language.
=ob-julia.el= provides Org Babel support for evaluating Julia source
code.
*** ~ob-mathomatic.el~ by Luis Anaya
[[https://www.mathomatic.org/][mathomatic]] a portable, command-line, educational CAS and calculator
software, written entirely in the C programming language.
~ob-mathomatic.el~ provides Org Babel support for evaluating mathomatic
entries.
*** ~ob-tcl.el~ by Luis Anaya
~ob-tcl.el~ provides Org Babel support for evaluating [[https://www.tcl.tk/][Tcl]] source code.
*** ~org-bullets.el~ by Evgeni Sabof
Display bullets instead of stars for headlines.
Also see [[https://orgmode.org/worg/org-faq.html#sec-8-12][this updated FAQ]] on how to display another character than "*"
for starting headlines.
*** ~org-favtable.el~ by Marc-Oliver Ihm
~org-favtable.el~ helps you to create and update a table of favorite
locations in org, keeping the most frequently visited lines right at
the top. This table is called "favtable". See the documentation on
[[https://orgmode.org/worg/org-contrib/org-favtable.html][Worg]].
*** ~ox-confluence.el~ by Sébastien Delafond
~ox-confluence.el~ lets you convert Org files to [[https://confluence.atlassian.com/display/DOC/Confluence%2BWiki%2BMarkup][Confluence Wiki]] files.
*** ~ox-deck.el~ and ~ox-s5.el~ by Rick Frankel
[[http://imakewebthings.com/deck.js/][deck.js]] is a javascript library for displaying HTML ages as
presentations. ~ox-deck.el~ exports Org files to HTML presentations
using =deck.js=.
[[https://meyerweb.com/eric/tools/s5/][s5]] is a set of scripts which also allows to display HTML pages as
presentations. ~ox-s5.el~ exports Org files to HTML presentations
using =s5=.
*** ~ox-groff.el~ by Luis Anaya and Nicolas Goaziou
The [[https://www.gnu.org/software/groff/][groff]] (GNU troff) software is a typesetting package which reads
plain text mixed with formatting commands and produces formatted
output.
Luis Anaya and Nicolas Goaziou implemented ~ox-groff.el~ to allow
conversion from Org files to groff.
*** ~ox-koma-letter.el~ by Nicolas Goaziou and Alan Schmitt
This back-end allow to export Org pages to the =KOMA Scrlttr2= format.
*** ~ox-rss.el~ by Bastien
This back-end lets you export Org pages to RSS 2.0 feeds. Combined
with the HTML publishing feature, this allows you to build a blog
entirely with Org.
** New features
*** Export
**** New export generic options
If you use Org exporter, we advise you to re-read [[https://orgmode.org/org.html#Exporting][the manual section about
it]]. It has been updated and includes new options.
Among the new/updated export options, three are of particular importance:
- [[doc:org-export-allow-bind-keywords][org-export-allow-bind-keywords]] :: This option replaces the old option
=org-export-allow-BIND= and the default value is =nil=, not =confirm=.
You will need to explicitly set this to =t= in your initialization
file if you want to allow =#+BIND= keywords.
- [[doc:org-export-with-planning][org-export-with-planning]] :: This new option controls the export of
=SCHEDULED:, DEADLINE:, CLOSED:= lines, and planning information is
now skipped by default during export. This use to be the job of
[[doc:org-export-with-timestamps][org-export-with-timestamps]], but this latter option has been given a
new role: it controls the export of /standalone time-stamps/. When
set to =nil=, Org will not export active and inactive time-stamps
standing on a line by themselves or within a paragraph that only
contains time-stamps.
To check if an option has been introduced or its default value changed in
Org 8.0, do =C-h v [option] RET= and check if the documentation says that
the variable has been introduced (or changed) in version 24.4 of Emacs.
**** Enhanced default stylesheet for the HTML exporter
See the new default value of [[doc:org-html-style-default][org-html-style-default]].
**** New tags, classes and ids for the HTML exporter
See the new default value of [[doc:org-html-divs][org-html-divs]].
**** Support for tikz pictures in LaTeX export
**** ~org-man.el~: New export function for "man" links
**** ~org-docview.el~: New export function for docview links
*** Structure editing
**** =C-u C-u M-RET= inserts a heading at the end of the parent subtree
**** Cycling to the =CONTENTS= view keeps inline tasks folded
[[doc:org-cycle-hook][org-cycle-hook]] as a new function [[doc:org-cycle-hide-inline-tasks][org-cycle-hide-inline-tasks]] which
prevents the display of inline tasks when showing the content of a subtree.
**** =C-c -= in a region makes a list item for each line
This is the opposite of the previous behavior, where =C-c -= on a region
would create one item for the whole region, and where =C-u C-c -= would
create an item for each line. Now =C-c -= on the selected region creates
an item per line, and =C-u C-c -= creates a single item for the whole
region.
**** When transposing words, markup characters are now part of the words
In Emacs, you can transpose words with =M-t=. Transposing =*these*
_words__= will preserve markup.
**** New command [[doc:org-set-property-and-value][org-set-property-and-value]] bound to =C-c C-x P=
This command allows you to quickly add both the property and its value. It
is useful in buffers where there are many properties and where =C-c C-x p=
can slow down the flow of editing too much.
**** New commands [[doc:org-next-block][org-next-block]] and [[doc:org-previous-block][org-previous-block]]
These commands allow you to go to the previous block (=C-c M-b= or the
speedy key =B=) or to the next block (=C-c M-f= or the speedy key =F=.)
**** New commands [[doc:org-drag-line-forward][org-drag-line-forward]] and [[doc:org-drag-line-backward][org-drag-line-backward]]
These commands emulate the old behavior of =M-= and =M-= but are
now bound to =S-M-= and =S-M-= respectively, since =M-= and
=M-= now drag the whole element at point (a paragraph, a table, etc.)
forward and backward.
**** When a list item has a checkbox, inserting a new item uses a checkbox too
**** When sorting entries/items, only the description of links is considered
Now Org will sort this list
: - [[https://abc.org][B]]
: - [[https://def.org][A]]
like this:
: - [[https://def.org][A]]
: - [[https://abc.org][B]]
by comparing the descriptions, not the links.
Same when sorting headlines instead of list items.
**** New option =orgstruct-heading-prefix-regexp=
For example, setting this option to "^;;; " in Emacs lisp files and using
=orgstruct-mode= in those files will allow you to cycle through visibility
states as if lines starting with ";;; *..." where headlines.
In general, you want to set =orgstruct-heading-prefix-regexp= as a file
local variable.
**** New behavior of [[doc:org-clone-subtree-with-time-shift][org-clone-subtree-with-time-shift]]
The default is now to ask for a time-shift only when there is a time-stamp.
When called with a universal prefix argument =C-u=, it will not ask for a
time-shift even if there is a time-stamp.
**** New option [[doc:org-agenda-restriction-lock-highlight-subtree][org-agenda-restriction-lock-highlight-subtree]]
This defaults to =t= so that the whole subtree is highlighted when you
restrict the agenda view to it with =C-c C-x <= (or the speed command =<=).
The default setting helps ensuring that you are not adding tasks after the
restricted region. If you find this highlighting too intrusive, set this
option to =nil=.
**** New option [[doc:org-closed-keep-when-no-todo][org-closed-keep-when-no-todo]]
When switching back from a =DONE= keyword to a =TODO= keyword, Org now
removes the =CLOSED= planning information, if any. It also removes this
information when going back to a non-TODO state (e.g., with =C-c C-t SPC=).
If you want to keep the =CLOSED= planning information when removing the
TODO keyword, set [[doc:org-closed-keep-when-no-todo][org-closed-keep-when-no-todo]] to =t=.
**** New option [[doc:org-image-actual-width][org-image-actual-width]]
This option allows you to change the width of in-buffer displayed images.
The default is to use the actual width of the image, but you can use a
fixed value for all images, or fall back on an attribute like
: #+attr_html: :width 300px
*** Scheduled/deadline
**** Implement "delay" cookies for scheduled items
If you want to delay the display of a scheduled task in the agenda, you can
now use a delay cookie like this: =SCHEDULED: <2004-12-25 Sat -2d>=. The
task is still scheduled on the 25th but will appear in your agenda starting
from two days later (i.e. from March 27th.)
Imagine for example that your co-workers are not done in due time and tell
you "we need two more days". In that case, you may want to delay the
display of the task in your agenda by two days, but you still want the task
to appear as scheduled on March 25th.
In case the task contains a repeater, the delay is considered to affect all
occurrences; if you want the delay to only affect the first scheduled
occurrence of the task, use =--2d= instead. See [[doc:org-scheduled-delay-days][org-scheduled-delay-days]]
and [[doc:org-agenda-skip-scheduled-delay-if-deadline][org-agenda-skip-scheduled-delay-if-deadline]] for details on how to
control this globally or per agenda.
**** Use =C-u C-u C-c C-s= will insert a delay cookie for scheduled tasks
See the previous section for why delay cookies may be useful.
**** Use =C-u C-u C-c C-d= will insert a warning delay for deadline tasks
=C-u C-u C-c C-d= now inserts a warning delay to deadlines.
*** Calendar, diary and appts
**** New variable [[doc:org-read-date-minibuffer-local-map][org-read-date-minibuffer-local-map]]
By default, this new local map uses "." to go to today's date, like in the
normal =M-x calendar RET=. If you want to deactivate this and to reassign
the "@" key to =calendar-goto-today=, use this:
#+BEGIN_SRC emacs-lisp
;; Unbind "." in Org's calendar:
(define-key org-read-date-minibuffer-local-map (kbd ".") nil)
;; Bind "@" to `calendar-goto-today':
(define-key org-read-date-minibuffer-local-map
(kbd "@")
(lambda () (interactive) (org-eval-in-calendar '(calendar-goto-today))))
#+END_SRC
**** In Org's calendar, =!= displays diary entries of the date at point
This is useful when you want to check if you don't already have an
appointment when setting new ones with =C-c .= or =C-c s=. =!= will
call =diary-view-entries= and display the diary in a separate buffer.
**** [[doc:org-diary][org-diary]]: only keep the descriptions of links
[[doc:org-diary][org-diary]] returns diary information from Org files, but it returns it
in a diary buffer, not in an Org mode buffer. When links are displayed,
only show their description, not the full links.
*** Agenda
**** New agenda type =agenda*= and entry types =:scheduled* :deadline*=
When defining agenda custom commands, you can now use =agenda*=: this will
list entries that have both a date and a time. This is useful when you
want to build a list of appointments.
You can also set [[doc:org-agenda-entry-types][org-agenda-entry-types]] either globally or locally in
each agenda custom command and use =:timestamp*= and/or =:deadline*= there.
Another place where this is useful is your =.diary= file:
: %%(org-diary :scheduled*) ~/org/rdv.org
This will list only entries from =~/org/rdv.org= that are scheduled with a
time value (i.e. appointments).
**** New agenda sorting strategies
[[doc:org-agenda-sorting-strategy][org-agenda-sorting-strategy]] allows these new sorting strategies:
| Strategy | Explanations |
|----------------+------------------------------------------|
| timestamp-up | Sort by any timestamp, early first |
| timestamp-down | Sort by any timestamp, late first |
| scheduled-up | Sort by scheduled timestamp, early first |
| scheduled-down | Sort by scheduled timestamp, late first |
| deadline-up | Sort by deadline timestamp, early first |
| deadline-down | Sort by deadline timestamp, late first |
| ts-up | Sort by active timestamp, early first |
| ts-down | Sort by active timestamp, late first |
| tsia-up | Sort by inactive timestamp, early first |
| tsia-down | Sort by inactive timestamp, late first |
**** New options to limit the number of agenda entries
You can now limit the number of entries in an agenda view. This is
different from filters: filters only /hide/ the entries in the agenda,
while limits are set while generating the list of agenda entries.
These new options are available:
- [[doc:org-agenda-max-entries][org-agenda-max-entries]] :: limit by number of entries.
- [[doc:org-agenda-max-todos][org-agenda-max-todos]] :: limit by number of TODOs.
- [[doc:org-agenda-max-tags][org-agenda-max-tags]] :: limit by number of tagged entries.
- [[doc:org-agenda-max-effort][org-agenda-max-effort]] :: limit by effort (minutes).
For example, if you locally set [[doc:org-agenda-max-todos][org-agenda-max-todos]] to 3 in an agenda
view, the agenda will be limited to the first three todos. Other entries
without a TODO keyword or beyond the third TODO headline will be ignored.
When setting a limit (e.g. about an effort's sum), the default behavior is
to exclude entries that cannot be checked against (e.g. entries that have
no effort property.) To include other entries too, you can set the limit
to a negative number. For example =(setq org-agenda-max-tags -3)= will not
show the fourth tagged headline (and beyond), but it will also show
non-tagged headlines.
**** =~= in agenda view sets temporary limits
You can hit =~= in the agenda to temporarily set limits: this will
regenerate the agenda as if the limits were set. This is useful for
example when you want to only see a list of =N= tasks, or a list of tasks
that take only =N= minutes.
**** "=" in agenda view filters by regular expressions
You can now filter agenda entries by regular expressions using ~=~. =C-u
== will filter entries out. Regexp filters are cumulative. You can set
[[doc:org-agenda-regexp-filter-preset][org-agenda-regexp-filter-preset]] to suit your needs in each agenda view.
**** =|= in agenda view resets all filters
Since it's common to combine tag filters, category filters, and now regexp
filters, there is a new command =|= to reset all filters at once.
**** Allow writing an agenda to an =.org= file
You can now write an agenda view to an =.org= file. It copies the
headlines and their content (but not subheadings) into the new file.
This is useful when you want to quickly share an agenda containing the full
list of notes.
**** New commands to drag an agenda line forward (=M-=) or backward (=M-=)
It sometimes handy to move agenda lines around, just to quickly reorganize
your tasks, or maybe before saving the agenda to a file. Now you can use
=M-= and =M-= to move the line forward or backward.
This does not persist after a refresh of the agenda, and this does not
change the =.org= files who contribute to the agenda.
**** Use =%b= for displaying "breadcrumbs" in the agenda view
[[doc:org-agenda-prefix-format][org-agenda-prefix-format]] now allows to use a =%b= formatter to tell Org
to display "breadcrumbs" in the agenda view.
This is useful when you want to display the task hierarchy in your agenda.
**** Use =%l= for displaying the headline's level in the agenda view
[[doc:org-agenda-prefix-format][org-agenda-prefix-format]] allows to use a =%l= formatter to tell Org to
display entries with additional spaces corresponding to their level in the
outline tree.
**** [[doc:org-agenda-write][org-agenda-write]] will ask before overwriting an existing file
=M-x org-agenda-write RET= (or =C-c C-w= from an agenda buffer) used to
overwrite preexisting file with the same name without confirmation. It now
asks for a confirmation.
**** New commands =M-m= and =M-*= to toggle (all) mark(s) for bulk action
- [[doc:org-agenda-bulk-toggle][org-agenda-bulk-toggle]] :: this command is bound to =M-m= and toggles
the mark of the entry at point.
- [[doc:org-agenda-bulk-toggle-all][org-agenda-bulk-toggle-all]] :: this command is bound to =M-*= and
toggles all the marks in the current agenda.
**** New option [[doc:org-agenda-search-view-max-outline-level][org-agenda-search-view-max-outline-level]]
This option sets the maximum outline level to display in search view.
E.g. when this is set to 1, the search view will only show headlines of
level 1.
**** New option [[doc:org-agenda-todo-ignore-time-comparison-use-seconds][org-agenda-todo-ignore-time-comparison-use-seconds]]
This allows to compare times using seconds instead of days when honoring
options like =org-agenda-todo-ignore-*= in the agenda display.
**** New option [[doc:org-agenda-entry-text-leaders][org-agenda-entry-text-leaders]]
This allows you to get rid of the ">" character that gets added in front of
entries excerpts when hitting =E= in the agenda view.
**** New formatting string for past deadlines in [[doc:org-agenda-deadline-leaders][org-agenda-deadline-leaders]]
The default formatting for past deadlines is ="%2d d. ago: "=, which makes
it explicit that the deadline is in the past. You can configure this via
[[doc:org-agenda-deadline-leaders][org-agenda-deadline-leaders]]. Note that the width of the formatting
string is important to keep the agenda alignment clean.
**** New allowed value =repeated-after-deadline= for [[doc:org-agenda-skip-scheduled-if-deadline-is-shown][org-agenda-skip-scheduled-if-deadline-is-shown]]
When [[doc:org-agenda-skip-scheduled-if-deadline-is-shown][org-agenda-skip-scheduled-if-deadline-is-shown]] is set to
=repeated-after-deadline=, the agenda will skip scheduled items if they are
repeated beyond the current deadline.
**** New option for [[doc:org-agenda-skip-deadline-prewarning-if-scheduled][org-agenda-skip-deadline-prewarning-if-scheduled]]
This variable may be set to nil, t, the symbol `pre-scheduled', or a number
which will then give the number of days before the actual deadline when the
prewarnings should resume. The symbol `pre-scheduled' eliminates the
deadline prewarning only prior to the scheduled date.
Read the full docstring for details.
**** [[doc:org-class][org-class]] now supports holiday strings in the skip-weeks parameter
For example, this task will now be skipped only on new year's day:
: * Task
: <%%(org-class 2012 1 1 2013 12 12 2 "New Year's Day")>
*** Capture
**** Allow =C-1= as a prefix for [[doc:org-agenda-capture][org-agenda-capture]] and [[doc:org-capture][org-capture]]
With a =C-1= prefix, the capture mechanism will use the =HH:MM= value at
point (if any) or the current =HH:MM= time as the default time for the
capture template.
**** Expand keywords within %(sexp) placeholder in capture templates
If you use a =%:keyword= construct within a =%(sexp)= construct, Org will
expand the keywords before expanding the =%(sexp)=.
**** Allow to contextualize capture (and agenda) commands by checking the name of the buffer
[[doc:org-capture-templates-contexts][org-capture-templates-contexts]] and [[doc:org-agenda-custom-commands-contexts][org-agenda-custom-commands-contexts]]
allow you to define what capture templates and what agenda commands should
be available in various contexts. It is now possible for the context to
check against the name of the buffer.
*** Tag groups
Using =#+TAGS: { Tag1 : Tag2 Tag3 }= will define =Tag1= as a /group tag/
(note the colon after =Tag1=). If you search for =Tag1=, it will return
headlines containing either =Tag1=, =Tag2= or =Tag3= (or any combination
of those tags.)
You can use group tags for sparse tree in an Org buffer, for creating
agenda views, and for filtering.
See https://orgmode.org/org.html#Tag-groups for details.
*** Links
**** =C-u C-u M-x org-store-link RET= will ignore non-core link functions
Org knows how to store links from Org buffers, from info files and from
other Emacs buffers. Org can be taught how to store links from any buffer
through new link protocols (see [[https://orgmode.org/org.html#Adding-hyperlink-types]["Adding hyperlink types"]] in the manual.)
Sometimes you want Org to ignore added link protocols and store the link
as if the protocol was not known.
You can now do this with =C-u C-u M-x org-store-link RET=.
**** =C-u C-u C-u M-x org-store-link RET= on an active region will store links for each lines
Imagine for example that you want to store a link for every message in a
Gnus summary buffer. In that case =C-x h C-u C-u C-u M-x org-store-link
RET= will store a link for every line (i.e. message) if the region is
active.
**** =C-c C-M-l= will add a default description for links which don't have one
=C-c C-M-l= inserts all stored links. If a link does not have a
description, this command now adds a default one, so that we are not mixing
with-description and without-description links when inserting them.
**** No curly braces to bracket links within internal links
When storing a link to a headline like
: * See [[https://orgmode.org][Org website]]
[[doc:org-store-link][org-store-link]] used to convert the square brackets into curly brackets.
It does not anymore, taking the link description or the link path, when
there is no description.
*** Table
**** Switching between #+TBLFM lines
If you have several =#+TBLFM= lines below a table, =C-c C-c= on a line will
apply the formulas from this line, and =C-c C-c= on another line will apply
those other formulas.
**** You now use "nan" for empty fields in Calc formulas
If empty fields are of interest, it is recommended to reread the section
[[https://orgmode.org/org.html#Formula-syntax-for-Calc][3.5.2 Formula syntax for Calc]] of the manual because the description for the
mode strings has been clarified and new examples have been added towards
the end.
**** Handle localized time-stamps in formulas evaluation
If your =LOCALE= is set so that Org time-stamps use another language than
english, and if you make time computations in Org's table, it now works by
internally converting the time-stamps with a temporary =LOCALE=C= before
doing computation.
**** New lookup functions
There are now three lookup functions:
- [[doc:org-lookup-first][org-lookup-first]]
- [[doc:org-lookup-last][org-lookup-last]]
- [[doc:org-lookup-all][org-lookup-all]]
See [[https://orgmode.org/org.html#Lookup-functions][the manual]] for details.
*** Startup keywords
These new startup keywords are now available:
| Startup keyword | Option |
|----------------------------------+---------------------------------------------|
| =#+STARTUP: logdrawer= | =(setq org-log-into-drawer t)= |
| =#+STARTUP: nologdrawer= | =(setq org-log-into-drawer nil)= |
|----------------------------------+---------------------------------------------|
| =#+STARTUP: logstatesreversed= | =(setq org-log-states-order-reversed t)= |
| =#+STARTUP: nologstatesreversed= | =(setq org-log-states-order-reversed nil)= |
|----------------------------------+---------------------------------------------|
| =#+STARTUP: latexpreview= | =(setq org-startup-with-latex-preview t)= |
| =#+STARTUP: nolatexpreview= | =(setq org-startup-with-latex-preview nil)= |
*** Clocking
**** New option [[doc:org-clock-rounding-minutes][org-clock-rounding-minutes]]
E.g. if [[doc:org-clock-rounding-minutes][org-clock-rounding-minutes]] is set to 5, time is 14:47 and you
clock in: then the clock starts at 14:45. If you clock out within the next
5 minutes, the clock line will be removed; if you clock out 8 minutes after
your clocked in, the clock out time will be 14:50.
**** New option [[doc:org-time-clocksum-use-effort-durations][org-time-clocksum-use-effort-durations]]
When non-nil, =C-c C-x C-d= uses effort durations. E.g., by default, one
day is considered to be a 8 hours effort, so a task that has been clocked
for 16 hours will be displayed as during 2 days in the clock display or in
the clocktable.
See [[doc:org-effort-durations][org-effort-durations]] on how to set effort durations and
[[doc:org-time-clocksum-format][org-time-clocksum-format]] for more on time clock formats.
**** New option [[doc:org-clock-x11idle-program-name][org-clock-x11idle-program-name]]
This allows to set the name of the program which prints X11 idle time in
milliseconds. The default is to use =x11idle=.
**** New option [[doc:org-use-last-clock-out-time-as-effective-time][org-use-last-clock-out-time-as-effective-time]]
When non-nil, use the last clock out time for [[doc:org-todo][org-todo]]. Note that this
option has precedence over the combined use of [[doc:org-use-effective-time][org-use-effective-time]] and
[[doc:org-extend-today-until][org-extend-today-until]].
**** =S-= on a clocksum column will update the sum by updating the last clock
**** =C-u 3 C-S-= will update clock timestamps synchronously by 3 units
**** New parameter =:wstart= for clocktables to define the week start day
**** New parameter =:mstart= to state the starting day of the month
**** Allow relative times in clocktable tstart and tend options
**** The clocktable summary is now a caption
**** =:tstart= and =:tend= and friends allow relative times like "<-1w>" or ""
*** Babel
**** You can now use =C-c C-k= for [[doc:org-edit-src-abort][org-edit-src-abort]]
This allows you to quickly cancel editing a source block.
**** =C-u C-u M-x org-babel-tangle RET= tangles by the target file of the block at point
This is handy if you want to tangle all source code blocks that have the
same target than the block at point.
**** New options for auto-saving the base buffer or the source block editing buffer
When [[doc:org-edit-src-turn-on-auto-save][org-edit-src-turn-on-auto-save]] is set to =t=, editing a source block
in a new window will turn on =auto-save-mode= and save the code in a new
file under the same directory than the base Org file.
When [[doc:org-edit-src-auto-save-idle-delay][org-edit-src-auto-save-idle-delay]] is set to a number of minutes =N=,
the base Org buffer will be saved after this number of minutes of idle
time.
**** New =:post= header argument post-processes results
This header argument may be used to pass the results of the current
code block through another code block for post-processing. See the
manual for a usage example.
**** Commented out heading are ignored when collecting blocks for tangling
If you comment out a heading (with =C-c ;= anywhere on the heading or in
the subtree), code blocks from within this heading are now ignored when
collecting blocks for tangling.
**** New option [[doc:org-babel-hash-show-time][org-babel-hash-show-time]] to show a time-stamp in the result hash
**** Do not ask for confirmation if cached value is current
Do not run [[doc:org-babel-confirm-evaluate][org-babel-confirm-evaluate]] if source block has a cache and the
cache value is current as there is no evaluation involved in this case.
**** =ob-sql.el= and =ob-python.el= have been improved.
**** New Babel files only need to =(require 'ob)=
When writing a new Babel file, you now only need to use =(require 'ob)=
instead of requiring each Babel library one by one.
*** Faces
- Org now fontifies radio link targets by default
- In the agenda, use [[doc:org-todo-keyword-faces][org-todo-keyword-faces]] to highlight selected TODO keywords
- New face [[doc:org-priority][org-priority]], enhanced fontification of priority cookies in agenda
- New face [[doc:org-tag-group][org-tag-group]] for group tags
** Miscellaneous
- New speedy key =s= pour [[doc:org-narrow-to-subtree][org-narrow-to-subtree]]
- Handling of [[doc:org-html-table-row][org-html-table-row]] has been updated (incompatible change)
- [[doc:org-export-html-table-tag][org-export-html-table-tag]] is replaced by [[doc:org-html-table-default-attributes][org-html-table-default-attributes]]
- Support using =git-annex= with Org attachments
- org-protocol: Pass optional value using query in url to capture from protocol
- When the refile history is empty, use the current filename as default
- When you cannot change the TODO state of a task, Org displays the blocking task
- New option [[doc:org-mobile-allpriorities][org-mobile-allpriorities]]
- org-bibtex.el now use =visual-line-mode= instead of the deprecated =longlines-mode=
- [[doc:org-format-latex-options][org-format-latex-options]] allows to set the foreground/background colors automatically
- New option [[doc:org-archive-file-header-format][org-archive-file-header-format]]
- New "neg" entity in [[doc:org-entities][org-entities]]
- New function [[doc:org-docview-export][org-docview-export]] to export docview links
- New =:eps= header argument for ditaa code blocks
- New option [[doc:org-gnus-no-server][org-gnus-no-server]] to start Gnus with =gnus-no-server=
- Org is now distributed with =htmlize.el= version 1.43
- ~org-drill.el~ has been updated to version 2.3.7
- ~org-mac-iCal.el~ now supports OS X versions up to 10.8
- Various improvements to ~org-contacts.el~ and =orgpan.el=
** Outside Org
*** Spanish translation of the Org guide by David Arroyo Menéndez
David (and others) translated the Org compact guide in spanish:
You can read the [[https://orgmode.org/worg/orgguide/orgguide.es.pdf][PDF guide]].
*** ~poporg.el~ and ~outorg.el~
Two new libraries (~poporg.el~ by François Pinard and ~outorg.el~ by
Thorsten Jolitz) now enable editing of comment-sections from source-code
buffers in temporary Org-mode buffers, making the full editing power of
Org-mode available. ~outorg.el~ comes together with ~outshine.el~ and
~navi-mode.el~, two more libraries by Thorsten Jolitz with the goal to give
source-code buffers the /look & feel/ of Org-mode buffers while greatly
improving navigation and structure editing. A detailed description can be
found here: https://orgmode.org/worg/org-tutorials/org-outside-org.html
Here are two screencasts demonstrating Thorsten's tools:
- [[https://youtu.be/nqE6YxlY0rw]["Modern conventions for Emacs Lisp files"]]
- [[https://www.youtube.com/watch?v%3DII-xYw5VGFM][Exploring Bernt Hansen's Org-mode tutorial with 'navi-mode']]
*** MobileOrg for iOS
MobileOrg for iOS back in the App Store The 1.6.0 release was focused on
the new Dropbox API and minor bug fixes but also includes a new ability to
launch in Capture mode. Track development and contribute [[https://github.com/MobileOrg/mobileorg/issues][on github]].
* Version 7.9.3
** New option [[doc::org-agenda-use-tag-inheritance][org-agenda-use-tag-inheritance]]
[[doc::org-use-tag-inheritance][org-use-tag-inheritance]] controls whether tags are inherited when
org-tags-view is called (either in =tags=, =tags-tree= or =tags-todo=
agenda views.)
When generating other agenda types such as =agenda=, =todo= and
=todo-tree=, tags inheritance is not used when selecting the entries
to display. Still, you might want to have all tag information correct
in the agenda buffer, e.g. for tag filtering. In that case, add the
agenda type to this variable.
Setting this variable to nil should considerably speeds up the agenda
generation.
Note that the default was to display inherited tags in the agenda
lines even if `org-use-tag-inheritance' was nil. The default is now
to *never* display inherited tags in agenda lines, but to /know/ about
them when the agenda type is listed in [[doc::org-agenda-use-tag-inheritance][org-agenda-use-tag-inheritance]].
** New default value =nil= for [[doc::org-agenda-dim-blocked-tasks][org-agenda-dim-blocked-tasks]]
Using `nil' as the default value speeds up the agenda generation. You
can hit `#' (or `C-u #') in agenda buffers to temporarily dim (or turn
invisible) blocked tasks.
** New speedy keys for [[doc::org-speed-commands-default][org-speed-commands-default]]
You can now use `:' (instead of `;') for setting tags---this is
consistent with using the `:' key in agenda view.
You can now use `=' for [[doc::org-columns][org-columns]].
** =org-float= is now obsolete, use =diary-float= instead
** No GPL manual anymore
There used to be a GPL version of the Org manual, but this is not the
case anymore, the Free Software Foundation does not permit this.
The GNU FDL license is now included in the manual directly.
** Enhanced compatibility with Emacs 22 and XEmacs
Thanks to Achim for his work on enhancing Org's compatibility with
various Emacsen. Things may not be perfect, but Org should work okay
in most environments.
* Version 7.9.2
** New ELPA repository for Org packages
You can now add the Org ELPA repository like this:
#+BEGIN_SRC emacs-lisp
(add-to-list 'package-archives '("org" . "https://orgmode.org/elpa/") t)
#+END_SRC
It contains both the =org-*.tar= package (the core Org distribution, also
available through https://elpa.gnu.org) and the =org-plus*.tar= package (the
extended Org distribution, with non-GNU packages from the =contrib/=
directory.)
See https://orgmode.org/elpa/
** Overview of the new keybindings
| Keybinding | Speedy | Command |
|-----------------+--------+-----------------------------|
| =C-c C-x C-z= | | [[doc::org-clock-resolve][org-clock-resolve]] |
| =C-c C-x C-q= | | [[doc::org-clock-cancel][org-clock-cancel]] |
| =C-c C-x C-x= | | [[doc::org-clock-in-last][org-clock-in-last]] |
| =M-h= | | [[doc::org-mark-element][org-mark-element]] |
| =*= | | [[doc::org-agenda-bulk-mark-all][org-agenda-bulk-mark-all]] |
| =C-c C-M-l= | | [[doc::org-insert-all-links][org-insert-all-links]] |
| =C-c C-x C-M-v= | | [[doc::org-redisplay-inline-images][org-redisplay-inline-images]] |
| =C-c C-x E= | =E= | [[doc::org-inc-effort][org-inc-effort]] |
| | =#= | [[doc::org-toggle-comment][org-toggle-comment]] |
| | =:= | [[doc::org-columns][org-columns]] |
| | =W= | Set =APPT_WARNTIME= |
| =k= | | [[doc::org-agenda-capture][org-agenda-capture]] |
| C-c , | , | [[doc::org-priority][org-priority]] |
** New package and Babel language
*** =org-eshell.el= by Konrad Hinsen is now in Org
=org-eshell.el= allows you to create links from [[https://www.gnu.org/software/emacs/manual/html_node/eshell/index.html][Eshell]].
*** Support for execution of Scala code blocks (see ob-scala.el)
*** Support for execution of IO code blocks (see ob-io.el)
** Incompatible changes
- If your code relies on =org-write-agenda=, please use
[[doc::org-agenda-write][org-agenda-write]] from now on.
- If your code relies on =org-make-link=, please use =concat=
instead.
- =org-link-to-org-use-id= has been renamed to
=org-id-link-to-org-use-id= and its default value is nil. The
previous default was =create-if-interactive-and-no-custom-id=.
** New features and user-visible changes
*** Org Element
=org-element.el= is a toolbox for parsing and analyzing "elements"
in an Org-mode buffer. This has been written by Nicolas Goaziou
and has been tested for quite some time. It is now part of Org's
core and many core functions rely on this package.
Two functions might be particularly handy for users:
=org-element-at-point= and =org-element-context=.
See the docstrings for more details.
Below is a list of editing and navigating commands that now rely
on =org-element.el=.
**** [[doc::org-fill-paragraph][org-fill-paragraph]] has been completely rewritten
The filling mechanisms now rely on org-element, trying to do the
right thing on each element in various contexts. E.g. filling in
a list item will preserve indentation; filling in message-mode
will fall back on the relevant filling functions; etc.
**** [[doc::org-metaup][org-metaup]] and [[doc::org-metadown][org-metadown]] will drag the element backward/forward
If you want to get the old behavior (i.e. moving a line up and
down), you can first select the line as an active region, then
=org-metaup= or =org-metadown= to move the region backward or
forward. This also works with regions bigger than just one line.
**** [[doc::org-up-element][org-up-element]] and [[doc::org-down-element][org-down-element]] (respectively =C-c C-^= and =C-c C-_=)
This will move the point up/down in the hierarchy of elements.
**** [[doc::org-backward-element][org-backward-element]] and [[doc::org-forward-element][org-forward-element]] (respectively =M-{= and =M-}=)
This will move the point backward/forward in the hierarchy of
elements.
**** [[doc::org-narrow-to-element][org-narrow-to-element]] will narrow to the element at point
**** [[doc::org-mark-element][org-mark-element]] will mark the element at point
This command is bound to =M-h= and will mark the element at
point. If the point is at a paragraph, it will mark the
paragraph. If the point is at a list item, it will mark the list
item. Etc.
Note that if point is at the beginning of a list, it will mark
the whole list.
To mark a subtree, you can either use =M-h= on the headline
(since there is no ambiguity about the element you're at) or
[[doc::org-mark-subtree][org-mark-subtree]] (=C-c @=) anywhere in the subtree.
Invoking [[doc::org-mark-element][org-mark-element]] repeatedly will try to mark the next
element on top of the previous one(s). E.g. hitting =M-h= twice
on a headline will mark the current subtree and the next one on
the same level.
*** Org Agenda
**** New option [[doc::org-agenda-sticky][org-agenda-sticky]]
There is a new option =org-agenda-sticky= which enables "sticky"
agendas. Sticky agendas remain opened in the background so that
you don't need to regenerate them each time you hit the
corresponding keystroke. This is a big time saver.
When [[doc::org-agenda-sticky][org-agenda-sticky]] is =non-nil=, the agenda buffer will be
named using the agenda key and its description. In sticky
agendas, the =q= key will just bury the agenda buffers and
further agenda commands will show existing buffer instead of
generating new ones.
If [[doc::org-agenda-sticky][org-agenda-sticky]] is set to =nil=, =q= will kill the single
agenda buffer.
**** New option [[doc::org-agenda-custom-commands-contexts][org-agenda-custom-commands-contexts]]
Setting this option allows you to define specific context where
agenda commands should be available from. For example, when set
to this value
#+BEGIN_SRC emacs-lisp
(setq org-agenda-custom-commands-contexts
'(("p" (in-file . "\\.txt"))))
#+END_SRC
then the =p= agenda command will only be available from buffers
visiting *.txt files. See the docstring and the manual for more
details on how to use this.
**** Changes in bulk actions
The set of commands starting with =k ...= as been deleted and the
features have been merged into the "bulk action" feature.
After you marked some entries in the agenda, if you call =B s=,
the agenda entries will be rescheduled using the date at point if
on a date header. If you are on an entry with a timestamp, you
will be prompted for a date to reschedule your marked entries to,
using the timestamp at point as the default prompt.
You can now use =k= to capture the marked entry and use the date
at point as an overriding date for the capture template.
To bind this behavior to =M-x org-capture RET= (or its
keybinding), set the new option [[doc::org-capture-use-agenda-date][org-capture-use-agenda-date]] to
=t=.
**** =N= and =P= in the agenda will move to the next/previous item
**** New command [[doc::org-agenda-bulk-mark-all][org-agenda-bulk-mark-all]] to mark all items
This new command is bound to =*= in agenda mode.
There is also a new option [[doc::org-agenda-bulk-mark-char][org-agenda-bulk-mark-char]] to set the
character to use as a mark for bulk actions.
**** New option [[doc::org-agenda-persistent-marks][org-agenda-persistent-marks]]
When set to =non-nil=, marks will remain visible after a bulk
action. You can temporarily toggle this by pressing =p= when
invoking [[doc::org-agenda-bulk-action][org-agenda-bulk-action]]. Marks are deleted if your
rebuild the agenda buffer or move to another date/span (e.g. with
=f= or =w=).
**** New option [[doc::org-agenda-skip-timestamp-if-deadline-is-shown][org-agenda-skip-timestamp-if-deadline-is-shown]]
=Non-nil= means skip timestamp line if same entry shows because
of deadline.
In the agenda of today, an entry can show up multiple times
because it has both a plain timestamp and has a nearby deadline.
When this variable is t, then only the deadline is shown and the
fact that the entry has a timestamp for or including today is not
shown. When this variable is =nil=, the entry will be shown
several times.
**** New =todo-unblocked= and =nottodo-unblocked= skip conditions
See the [[https://orgmode.org/cgit.cgi/org-mode.git/commit/?id=f426da][git commit]] for more explanations.
**** Allow category filtering in the agenda
You can now filter the agenda by category. Pressing "<" will
filter by the category of the item on the current line, and
pressing "<" again will remove the filter. You can combine tag
filters and category filters.
You can use =org-agenda-category-filter= in your custom agenda
views and =org-agenda-category-filter-preset= in your main
configuration.
See also the new command [[doc::org-agenda-filter-by-top-category][org-agenda-filter-by-top-category]]:
hitting =^= will filter by "Top" category: only show entries that
are of the same category than the Top category of the entry at
point.
*** Org Links
**** Inserting links
When inserting links through [[doc::org-insert-link][org-insert-link]], the description is
now displayed first, followed by the literal link, as the
description is often more useful when you look for the link you
want to insert.
Completion now complete both literal links and description. If
you complete a description, the literal link and its description
will be inserted directly, whereas when you complete the literal
link, you will be prompted for a description (as with Org 7.8.)
In the completion buffer, links to the current buffer are now
highlighted.
**** New templates =%h= and =%(sexp)= for abbreviated links
On top of =%s= template, which is replaced by the link tag in
abbreviated links, you can now use =%h= (which does the same than =%s=
but does not hexify the tag) and =%(sexp)= (which can run a function
that takes the tag as its own argument.)
**** New link type =help=
You can now create links from =help= buffers.
For example, if you request help for the command [[doc::org-agenda][org-agenda]] with
=C-h f org-agenda RET=, creating a link from this buffer will let
you go back to the same buffer.
**** New command [[doc::org-insert-all-links][org-insert-all-links]]
This will insert all links as list items. With a universal
prefix argument, links will not be deleted from the variable
=org-stored-links=.
This new command is bound to =C-c C-M-l=.
**** New option [[doc::org-url-hexify-p][org-url-hexify-p]]
When set to =nil=, the =URL= part of a link will not be hexified.
**** Org can now open multiple shell links
**** New option [[doc::org-doi-server-url][org-doi-server-url]] to specify an alternate DOI server
**** RET now follows time stamps links
*** Org Editing
**** [[doc::org-todo][org-todo]] and =org-archive-*= can now loop in the active region
When [[doc::org-loop-over-headlines-in-active-region][org-loop-over-headlines-in-active-region]] is =non-nil=, using
[[doc::org-todo][org-todo]] or =org-archive-*= commands in the active region will
loop over headlines. This is handy if you want to set the TODO
keyword for several items, or archive them quickly.
**** You can now set tags for headlines in a region
If [[doc::org-loop-over-headlines-in-active-region][org-loop-over-headlines-in-active-region]] is =non-nil=, then
selecting the region and hitting =C-c C-q= will set the tags for
all headlines in the region.
**** New command [[doc::org-insert-drawer][org-insert-drawer]] to insert a drawer interactively
**** Comments start with "^[ \t]*# " anywhere on a line
Note that the space after the hashtag is mandatory. Comments
with "^#+" are not supported anymore.
**** New speed key =#= to toggle the COMMENT cookie on a headline
**** =indent-region-function= is now set to [[doc::org-indent-region][org-indent-region]]
=C-M-\= should now produce useful results.
You can unindent the buffer with [[doc::org-unindent-buffer][org-unindent-buffer]].
**** New option [[doc::org-allow-promoting-top-level-subtree][org-allow-promoting-top-level-subtree]]
When =non-nil=, =S-M-= will promote level-1 subtrees
containing other subtrees. The level-1 headline will be
commented out. You can revert to the previous state with =M-x
undo RET=.
*** Org Clock
**** New keybinding =C-c C-x C-z= for [[doc::org-clock-resolve][org-clock-resolve]]
**** New keybinding =C-c C-x C-q= for [[doc::org-clock-cancel][org-clock-cancel]]
**** New command [[doc::org-clock-in-last][org-clock-in-last]] to clock in the last clocked item
This command is bound to =C-c C-x C-x= and will clock in the last
clocked entry, if any.
**** =C-u M-x= [[doc::org-clock-out][org-clock-out]] =RET= now prompts for a state to switch to
**** =S-M-= on a clock timestamps adjusts the previous/next clock
**** New option [[doc::org-clock-continuously][org-clock-continuously]]
When set to =nil=, clocking in a task will first try to find the
last clocked out task and restart from when that task was clocked
out.
You can temporarily activate continuous clocking with =C-u C-u
C-u M-x= [[doc::org-clock-in][org-clock-in]] =RET= (three universal prefix arguments)
and =C-u C-u M-x= [[doc::org-clock-in-last][org-clock-in-last]] =RET= (two universal prefix
arguments).
**** New option [[doc::org-clock-frame-title-format][org-clock-frame-title-format]]
This option sets the value of =frame-title-format= when clocking
in.
**** New options for controlling the clockreport display
[[doc::org-clock-file-time-cell-format][org-clock-file-time-cell-format]]: Format string for the file time
cells in clockreport.
[[doc::org-clock-total-time-cell-format][org-clock-total-time-cell-format]]: Format string for the total
time cells in clockreport.
**** New options for controlling the clock/timer display
[[doc::org-clock-clocked-in-display][org-clock-clocked-in-display]]: control whether the current clock
is displayed in the mode line and/or frame title.
[[doc::org-timer-display][org-timer-display]]: control whether the current timer is displayed
in the mode line and/or frame title.
This allows the clock and timer to be displayed in the frame
title instead of, or as well as, the mode line. This is useful
for people with limited space in the mode line but with ample
space in the frame title.
*** Org Appearance
**** New option [[doc::org-custom-properties][org-custom-properties]]
The visibility of properties listed in this options can be turn
on/off with [[doc::org-toggle-custom-properties-visibility][org-toggle-custom-properties-visibility]]. This might
be useful for properties used by third-part tools or that you
don't want to see temporarily.
**** New command [[doc::org-redisplay-inline-images][org-redisplay-inline-images]]
This will redisplay all images. It is bound to =C-c C-x C-M-v=.
**** New entities in =org-entities.el=
There are these new entities:
: ("tilde" "\\~{}" nil "˜" "~" "~" "~")
: ("slash" "/" nil "/" "/" "/" "/")
: ("plus" "+" nil "+" "+" "+" "+")
: ("under" "\\_" nil "_" "_" "_" "_")
: ("equal" "=" nil "=" "=" "=" "=")
: ("asciicirc" "\\textasciicircum{}" nil "^" "^" "^" "^")
**** New face =org-list-dt= for definition terms
**** New face =org-date-selected= for the selected calendar day
**** New face value for =org-document-title=
The face is back to a normal height.
*** Org Columns
**** New speed command =:= to activate the column view
**** New special property =CLOCKSUM_T= to display today's clocked time
You can use =CLOCKSUM_T= the same way you use =CLOCKSUM=. It
will display the time spent on tasks for today only.
**** Use the =:COLUMNS:= property in columnview dynamic blocks
If the =:COLUMNS:= is set in a subtree, the columnview dynamic
block will use its value as the column format.
**** Consider inline tasks when computing a sum
*** Org Dates and Time Stamps
**** Enhanced [[doc::org-sparse-tree][org-sparse-tree]]
=C-c /= can now check for time ranges.
When checking for dates with =C-c /= it is useful to change the
type of dates that you are interested in. You can now do this
interactively with =c= after =C-c /= and/or by setting
[[doc::org-sparse-tree-default-date-type][org-sparse-tree-default-date-type]] to the default value you want.
**** Support for hourly repeat cookies
You can now use
: SCHEDULED: <2012-08-20 lun. 08:00 +1h>
if you want to add an hourly repeater to an entry.
**** =C-u C-u C-c .= inserts a time-stamp with no prompt
**** When (setq [[doc::org-read-date-prefer-future][org-read-date-prefer-future]] 'time), accept days in the prompt
"8am Wed" and "Wed 8am" are now acceptable values when entering a
date from the prompt. If [[doc::org-read-date-prefer-future][org-read-date-prefer-future]] is set to
=time=, this will produce the expected prompt indication.
**** New option [[doc::org-datetree-add-timestamp][org-datetree-add-timestamp]]
When set to =non-nil=, datetree entries will also have a
timestamp. This is useful if you want to see these entries in a
sparse tree with =C-c /=.
*** Org Capture
**** New command [[doc::org-capture-string][org-capture-string]]
M-x [[doc::org-capture-string][org-capture-string]] RET will prompt for a string and a capture
template. The string will be used as an annotation for the
template. This is useful when capturing in batch mode as it lets
you define the content of the template without being in Emacs.
**** New option [[doc::org-capture-templates-contexts][org-capture-templates-contexts]]
Setting this option allows you to define specific context where
capture templates should be available from. For example, when
set to this value
#+BEGIN_SRC emacs-lisp
(setq org-capture-templates-contexts
'(("c" (in-mode . "message-mode"))))
#+END_SRC
then the =c= capture template will only be available from
=message-mode= buffers. See the docstring and the manual for
more details on how to use this.
**** New =%l= template to insert the literal link
**** New option [[doc::org-capture-bookmark][org-capture-bookmark]]
Org used to automatically add a bookmark with capture a note.
You can now turn this on by setting [[doc::org-capture-bookmark][org-capture-bookmark]] to
=nil=.
**** Expand =%= escape sequences into text entered for 'th =%^{PROMPT}= escape
See the manual for more explanations.
**** More control over empty lines
You can use =:empty-lines-before= and =:empty-lines-after= to
control the insertion of empty lines. Check the manual for more
explanations.
**** New hook [[doc::org-capture-prepare-finalize-hook][org-capture-prepare-finalize-hook]]
This new hook runs before the finalization process starts.
*** Org Export
**** New functions =orgtbl-to-table.el= and =orgtbl-to-unicode=
=orgtbl-to-table.el= convert the table to a =table.el= table, and
=orgtbl-to-unicode= will use =ascii-art-to-unicode.el= (when
available) to print beautiful tables.
**** [[doc::org-table-export][org-table-export]] now a bit clever about the target format
When you specify a file name like =table.csv=, [[doc::org-table-export][org-table-export]]
will now suggest =orgtbl-to-csv= the default method for exporting
the table.
**** New option [[doc::org-export-date-timestamp-format][org-export-date-timestamp-format]]
The option allows to set a time string format for Org timestamps
in the #+DATE option.
**** LaTeX: New options for exporting table rules :tstart, :hline and :tend
See [[doc::org-export-latex-tables-hline][org-export-latex-tables-hline]] and [[doc::org-export-latex-tables-tend][org-export-latex-tables-tend]].
**** LaTeX: You can now set =:hfmt= from =#+ATTR_LaTeX=
**** Beamer: Add support and keybinding for the =exampleblock= environment
Add support for these languages in [[doc::org-export-language-setup][org-export-language-setup]].
More languages are always welcome.
**** Beamer: New option [[doc::org-beamer-inherited-properties][org-beamer-inherited-properties]]
This option allows Beamer export to inherit some properties.
Thanks to Carsten for implementing this.
**** ODT: Add support for ODT export in org-bbdb.el
**** ODT: Add support for indented tables (see [[https://orgmode.org/cgit.cgi/org-mode.git/commit/?id=e9fd33][this commit]] for details)
**** ODT: Improve the conversion from ODT to other formats
**** ASCII: Swap the level-1/level-2 characters to underline the headlines
**** Support for Chinese, simplified Chinese, Russian, Ukrainian and Japanese
**** HTML: New option [[doc::org-export-html-date-format-string][org-export-html-date-format-string]]
Format string to format the date and time in HTML export. Thanks
to Sébastien Vauban for this patch.
*** Org Babel
**** New =:results drawer= parameter
=:results drawer= replaces =:results wrap=, which is deprecated but still
supported.
**** =:results org= now put results in a =#+BEGIN_SRC org= block
=:results org= used to put results in a =#+BEGIN_ORG= block but it now puts
results in a =#+BEGIN_SRC org= block, with comma-escaped lines.
=#+BEGIN_ORG= blocks are obsolete.
**** Exporting =#+BEGIN_SRC org= blocks exports the code
It used to exports the results of the code.
*** Miscellaneous
**** New menu entry for [[doc::org-refile][org-refile]]
**** Allow capturing to encrypted entries
If you capture to an encrypted entry, it will be decrypted before
inserting the template then re-encrypted after finalizing the capture.
**** Inactive timestamps are now handled in tables
Calc can do computation on active time-stamps like <2012-09-29 sat.>.
Inactive time-stamps in a table's cell are now internally deactivated so
that Calc formulas can operate on them.
**** [[doc::org-table-number-regexp][org-table-number-regexp]] can now accept comma as decimal mark
**** Org allows a new property =APPT_WARNTIME=
You can set it with the =W= speedy key or set it manually. When
set, exporting to iCalendar and [[doc::org-agenda-to-appt][org-agenda-to-appt]] will use the
value of this property as the number of minutes for the warning
alarm.
**** New command [[doc::org-inc-effort][org-inc-effort]]
This will increment the effort value.
It is bound to =C-c C-x E= and to =E= as a speedy command.
**** Attach: Add support for creating symbolic links
=org-attach-method= now supports a new method =lns=, allowing to
attach symbolic links.
**** Archive: you can now archive to a datetree
**** New option [[doc::org-inlinetask-show-first-star][org-inlinetask-show-first-star]]
=Non-nil= means display the first star of an inline task as
additional marker. When =nil=, the first star is not shown.
**** New option [[doc::org-latex-preview-ltxpng-directory][org-latex-preview-ltxpng-directory]]
This lets you define the path for the =ltxpng/= directory.
**** You can now use imagemagick instead of dvipng to preview LaTeX fragments
**** You can now turn off [[doc::orgstruct++-mode][orgstruct++-mode]] safely
**** =C-u C-c C-c= on list items to add check boxes
=C-u C-c C-c= will add an empty check box on a list item.
When hit from the top of the list, it will add check boxes for
all top level list items.
**** =org-list-ending-method= and =org-list-end-regexp= are now obsolete
Fall back on using =org-list-end-re= only, which see.
**** org-feed.el now expands =%(sexp)= templates
**** New option [[doc::org-protocol-data-separator][org-protocol-data-separator]]
**** New option [[doc::org-ditaa-jar-option][org-ditaa-jar-option]] to specify the ditaa jar file
**** New possible value for [[doc::org-loop-over-headlines-in-active-region][org-loop-over-headlines-in-active-region]]
When [[doc::org-loop-over-headlines-in-active-region][org-loop-over-headlines-in-active-region]] is set to
=start-level=, the command will loop over the active region but
will only act upon entries that are of the same level than the
first headline in the region.
**** New option [[doc::org-habit-show-all-today][org-habit-show-all-today]]
When set to =t=, show all (even unscheduled) habits on today's
agenda.
** Important bug fixes
*** M-TAB on options keywords perform completion correctly again
If you hit =M-TAB= on keywords like =#+TITLE=, Org will try to
perform completion with meaningful values.
*** Add licenses to javascript embedded and external code snippets
Embedded javascript code produced when exporting an Org file to
HTML is now licensed under GPLv3 (or later), and the copyright is
owned by the Free Software Foundation, Inc.
The javascript code for embedding MathJax in the browser mentions
the MathJax copyright and the Apache 2.0 license.
The javascript code for embedding =org-injo.js= in the browser
mentions the copyright of Sebastian Rose and the GPLv3 (or later)
license.
=org-export-html-scripts= is now a variable, so that you can adapt
the code and the license to your needs.
See https://www.gnu.org/philosophy/javascript-trap.html for
explanations on why these changes were necessary.
* Version 7.8.11
** Incompatible changes
*** Emacs 21 support has been dropped
Do not use Org mode 7.xx with Emacs 21, use [[https://orgmode.org/org-6.36c.zip][version 6.36c]] instead.
*** XEmacs support requires the XEmacs development version
To use Org mode 7.xx with XEmacs, you need to run the developer
version of XEmacs. We were about to drop XEmacs support entirely,
but Michael Sperber stepped in and made changes to XEmacs that
made it easier to keep the support. Thanks to Michael for this
last-minute save.
*** New keys for TODO sparse trees
The key =C-c C-v= is now reserved for Org Babel action. TODO
sparse trees can still be made with =C-c / t= (all not-done
states) and =C-c / T= (specific states).
*** The Agenda =org-agenda-ndays= is now obsolete
The variable =org-agenda-ndays= is obsolete - please use
=org-agenda-span= instead.
Thanks to Julien Danjou for this.
*** Changes to the intended use of =org-export-latex-classes=
So far this variable has been used to specify the complete header
of the LaTeX document, including all the =\usepackage= calls
necessary for the document. This setup makes it difficult to
maintain the list of packages that Org itself would like to call,
for example for the special symbol support it needs.
First of all, you can *opt out of this change* in the following
way: You can say: /I want to have full control over headers, and I
will take responsibility to include the packages Org needs/. If
that is what you want, add this to your configuration and skip the
rest of this section (except maybe for the description of the
=[EXTRA]= place holder):
#+begin_src emacs-lisp
(setq org-export-latex-default-packages-alist nil
org-export-latex-packages-alist nil)
#+end_src
/Continue to read here if you want to go along with the modified
setup./
There are now two variables that should be used to list the LaTeX
packages that need to be included in all classes. The header
definition in =org-export-latex-classes= should then not contain
the corresponding =\usepackage= calls (see below).
The two new variables are:
1. =org-export-latex-default-packages-alist= :: This is the
variable where Org-mode itself puts the packages it needs.
Normally you should not change this variable. The only
reason to change it anyway is when one of these packages
causes a conflict with another package you want to use. Then
you can remove that packages and hope that you are not using
Org-mode functionality that needs it.
2. =org-export-latex-packages-alist= :: This is the variable where
you can put the packages that you'd like to use across all
classes.
The sequence how these customizations will show up in the LaTeX
document are:
1. Header from =org-export-latex-classes=
2. =org-export-latex-default-packages-alist=
3. =org-export-latex-packages-alist=
4. Buffer-specific things set with =#+LaTeX_HEADER:=
If you want more control about which segment is placed where, or
if you want, for a specific class, have full control over the
header and exclude some of the automatic building blocks, you can
put the following macro-like place holders into the header:
#+begin_example
[DEFAULT-PACKAGES] \usepackage statements for default packages
[NO-DEFAULT-PACKAGES] do not include any of the default packages
[PACKAGES] \usepackage statements for packages
[NO-PACKAGES] do not include the packages
[EXTRA] the stuff from #+LaTeX_HEADER
[NO-EXTRA] do not include #+LaTeX_HEADER stuff
#+end_example
If you have currently customized =org-export-latex-classes=, you
should revise that customization and remove any package calls that
are covered by =org-export-latex-default-packages-alist=. This
applies to the following packages:
- inputenc
- fontenc
- fixltx2e
- graphicx
- longtable
- float
- wrapfig
- soul
- t1enc
- textcomp
- marvosym
- wasysym
- latexsym
- amssymb
- hyperref
If one of these packages creates a conflict with another package
you are using, you can remove it from
=org-export-latex-default-packages-alist=. But then you risk that
some of the advertised export features of Org will not work
properly.
You can also consider moving packages that you use in all classes
to =org-export-latex-packages-alist=. If necessary, put the place
holders so that the packages get loaded in the right sequence. As
said above, for backward compatibility, if you omit the place
holders, all the variables will dump their content at the end of
the header.
*** The constant =org-html-entities= is obsolete
Its content is now part of the new constant =org-entities=, which
is defined in the file org-entities.el. =org-html-entities= was
an internal variable, but it is possible that some users did write
code using it.
*** =org-bbdb-anniversary-format-alist= has changed
Please check the docstring and update your settings accordingly.
*** Deleted =org-mode-p=
This function has been deleted: please update your code.
** Important new features
*** New Org to ODT exporter
Jambunathan's Org to ODT exporter is now part of Org.
To use it, it `C-c C-e o' in an Org file. See the documentation
for more information on how to customize it.
*** org-capture.el is now the default capture system
This replaces the earlier system org-remember. The manual only
describes org-capture, but for people who prefer to continue to
use org-remember, we keep a static copy of the former manual
section [[https://orgmode.org/org-remember.pdf][chapter about remember]].
The new system has a technically cleaner implementation and more
possibilities for capturing different types of data. See
[[msg:C46F10DC-DE51-43D4-AFFE-F71E440D1E1F@gmail.com][Carsten's announcement]] for more details.
To switch over to the new system:
1. Run
: M-x org-capture-import-remember-templates RET
to get a translated version of your remember templates into the
new variable =org-capture-templates=. This will "mostly" work,
but maybe not for all cases. At least it will give you a good
place to modify your templates. After running this command,
enter the customize buffer for this variable with
: M-x customize-variable RET org-capture-templates RET
and convince yourself that everything is OK. Then save the
customization.
2. Bind the command =org-capture= to a key, similar to what you did
with org-remember:
: (define-key global-map "\C-cc" 'org-capture)
If your fingers prefer =C-c r=, you can also use this key once
you have decided to move over completely to the new
implementation. During a test time, there is nothing wrong
with using both system in parallel.
** New libraries
*** New Org libraries
**** org-eshell.el (Konrad Hinsen)
Implement links to eshell buffers.
**** org-special-blocks (Carsten Dominik)
This package generalizes the #+begin_foo and #+end_foo tokens.
To use, put the following in your init file:
#+BEGIN_EXAMPLE
(require 'org-special-blocks)
#+END_EXAMPLE
The tokens #+begin_center, #+begin_verse, etc. existed
previously. This package generalizes them (at least for the
LaTeX and html exporters). When a #+begin_foo token is
encountered by the LaTeX exporter, it is expanded
into \begin{foo}. The text inside the environment is not
protected, as text inside environments generally is.
When #+begin_foo is encountered by the html exporter, a div with
class foo is inserted into the HTML file. It is up to the user
to add this class to his or her stylesheet if this div is to mean
anything.
**** org-taskjuggler.el (Christian Egli)
Christian Egli's /org-taskjuggler.el/ module is now part of Org.
He also wrote a [[https://orgmode.org/worg/org-tutorials/org-taskjuggler.php][tutorial]] for it.
**** org-ctags.el (Paul Sexton)
Targets like =<>= can now be found by Emacs's etag
functionality, and Org-mode links can be used to link to
etags, also in non-Org-mode files. For details, see the file
/org-ctags.el/.
This feature uses a new hook =org-open-link-functions= which will
call function to do something special with text links.
Thanks to Paul Sexton for this contribution.
**** org-docview.el (Jan Böcker)
This new module allows links to various file types using docview, where
Emacs displays images of document pages. Docview link types can point
to a specific page in a document, for example to page 131 of the
Org-mode manual:
: [[docview:~/.elisp/org/doc/org.pdf::131][Org-Mode Manual]]
Thanks to Jan Böcker for this contribution.
*** New Babel libraries
- ob-picolisp.el (Thorsten Jolitz)
- ob-fortran.el (Sergey Litvinov)
- ob-shen.el (Eric Schulte)
- ob-maxima.el (Eric S Fraga)
- ob-java.el (Eric Schulte)
- ob-lilypond.el (Martyn Jago)
- ob-awk.el (Eric Schulte)
** Other new features and various enhancements
*** Hyperlinks
**** Org-BibTeX -- major improvements
Provides support for managing bibtex bibliographical references
data in headline properties. Each headline corresponds to a
single reference and the relevant bibliographic meta-data is
stored in headline properties, leaving the body of the headline
free to hold notes and comments. Org-bibtex is aware of all
standard bibtex reference types and fields.
The key new functions are
- org-bibtex-check :: queries the user to flesh out all required
(and with prefix argument optional) bibtex fields available
for the specific reference =type= of the current headline.
- org-bibtex-create :: Create a new entry at the given level,
using org-bibtex-check to flesh out the relevant fields.
- org-bibtex-yank :: Yank a bibtex entry on the kill ring as a
formatted Org-mode headline into the current buffer
- org-bibtex-export-to-kill-ring :: Export the current headline
to the kill ring as a formatted bibtex entry.
**** org-gnus.el now allows link creation from messages
You can now create links from messages. This is particularly
useful when the user wants to stored messages that he sends, for
later check. Thanks to Ulf Stegemann for the patch.
**** Modified link escaping
David Maus worked on `org-link-escape'. See [[msg:87k4gysacq.wl%dmaus@ictsoc.de][his message]]:
: Percent escaping is used in Org mode to escape certain characters
: in links that would either break the parser (e.g. square brackets
: in link target or description) or are not allowed to appear in
: a particular link type (e.g. non-ascii characters in a http:
: link).
:
: With this change in place Org will apply percent escaping and
: unescaping more consistently especially for non-ascii characters.
: Additionally some of the outstanding bugs or glitches concerning
: percent escaped links are solved.
Thanks a lot to David for this work.
**** Make =org-store-link= point to directory in a dired buffer
When, in a dired buffer, the cursor is not in a line listing a
file, `org-store-link' will store a link to the directory.
Patch by Stephen Eglen.
**** Allow regexps in =org-file-apps= to capture link parameters
The way extension regexps in =org-file-apps= are handled has
changed. Instead of matching against the file name, the regexps
are now matched against the whole link, and you can use grouping
to extract link parameters which you can then use in a command
string to be executed.
For example, to allow linking to PDF files using the syntax
=file:/doc.pdf::=, you can add the following entry
to org-file-apps:
#+begin_example
Extension: \.pdf::\([0-9]+\)\'
Command: evince "%s" -p %1
#+end_example
Thanks to Jan Böcker for a patch to this effect.
*** Dates and time
**** Allow relative time when scheduling/adding a deadline
You can now use relative duration strings like "-2d" or "++3w"
when calling =org-schedule= or =org-deadline=: it will schedule
(or set the deadline for) the item respectively two days before
today and three weeks after the current timestamp, if any.
You can use this programmatically: =(org-schedule nil "+2d")=
will work on the current entry.
You can also use this while (bulk-)rescheduling and
(bulk-)resetting the deadline of (several) items from the agenda.
Thanks to Memnon Anon for a heads up about this!
**** American-style dates are now understood by =org-read-date=
So when you are prompted for a date, you can now answer like this
#+begin_example
2/5/3 --> 2003-02-05
2/5 --> -02-05
#+end_example
*** Agenda
**** =org-agenda-custom-commands= has a default value
This option used to be `nil' by default. This now has a default
value, displaying an agenda and all TODOs. See the docstring for
details. Thanks to Carsten for this.
**** Improved filtering through =org-agenda-to-appt=
The new function allows the user to refine the scope of entries
to pass to =org-agenda-get-day-entries= and allows to filter out
entries using a function.
Thanks to Peter Münster for raising a related issue and to
Tassilo Horn for this idea. Also thanks to Peter Münster for
[[git:68ffb7a7][fixing a small bug]] in the final implementation.
**** Allow ap/pm times in agenda time grid
Times in the agenda can now be displayed in am/pm format. See
the new variable =org-agenda-timegrid-use-ampm=. Thanks to
C. A. Webber for a patch to this effect.
**** Agenda: Added a bulk "scattering" command
=B S= in the agenda buffer will cause tasks to be rescheduled a
random number of days into the future, with 7 as the default.
This is useful if you've got a ton of tasks scheduled for today,
you realize you'll never deal with them all, and you just want
them to be distributed across the next N days. When called with
a prefix arg, rescheduling will avoid weekend days.
Thanks to John Wiegley for this.
*** Exporting
**** Simplification of org-export-html-preamble/postamble
When set to `t', export the preamble/postamble as usual, honoring
the =org-export-email/author/creator-info= variables.
When set to a formatting string, insert this string. See the
docstring of these variable for details about available
%-sequences.
You can set =:html-preamble= in publishing project in the same
way: `t' means to honor =:email/creator/author-info=, and a
formatting string will insert a string.
**** New exporters to Latin-1 and UTF-8
While Ulf Stegemann was going through the entities list to
improve the LaTeX export, he had the great idea to provide
representations for many of the entities in Latin-1, and for all
of them in UTF-8. This means that we can now export files rich
in special symbols to Latin-1 and to UTF-8 files. These new
exporters can be reached with the commands =C-c C-e n= and =C-c
C-e u=, respectively.
When there is no representation for a given symbol in the
targeted coding system, you can choose to keep the TeX-macro-like
representation, or to get an "explanatory" representation. For
example, =\simeq= could be represented as "[approx. equal to]".
Please use the variable =org-entities-ascii-explanatory= to state
your preference.
**** HTML export: Add class to outline containers using property
The =HTML_CONTAINER_CLASS= property can now be used to add a
class name to the outline container of a node in HTML export.
**** Throw an error when creating an image from a LaTeX snippet fails
This behavior can be configured with the new option variable
=org-format-latex-signal-error=.
**** Support for creating BEAMER presentations from Org-mode documents
Org-mode documents or subtrees can now be converted directly in
to BEAMER presentation. Turning a tree into a simple
presentations is straight forward, and there is also quite some
support to make richer presentations as well. See the [[https://orgmode.org/manual/Beamer-class-export.html#Beamer-class-export][BEAMER
section]] in the manual for more details.
Thanks to everyone who has contributed to the discussion about
BEAMER support and how it should work. This was a great example
for how this community can achieve a much better result than any
individual could.
*** Refiling
**** Refile targets can now be cached
You can turn on caching of refile targets by setting the variable
=org-refile-use-cache=. This should speed up refiling if you
have many eligible targets in many files. If you need to update
the cache because Org misses a newly created entry or still
offers a deleted one, press =C-0 C-c C-w=.
**** New logging support for refiling
Whenever you refile an item, a time stamp and even a note can be
added to this entry. For details, see the new option
=org-log-refile=.
Thanks to Charles Cave for this idea.
*** Completion
**** In-buffer completion is now done using John Wiegley's pcomplete.el
Thanks to John Wiegley for much of this code.
*** Tables
**** New command =org-table-transpose-table-at-point=
See the docstring. This hack from Juan Pechiar is now part of
Org's core. Thanks to Juan!
**** Display field's coordinates when editing it with =C-c `=
When editing a field with =C-c `=, the field's coordinate will
the displayed in the buffer.
Thanks to Michael Brand for a patch to this effect.
**** Spreadsheet computation of durations and time values
If you want to compute time values use the =T= flag, either in
Calc formulas or Elisp formulas:
| Task 1 | Task 2 | Total |
|--------+--------+---------|
| 35:00 | 35:00 | 1:10:00 |
#+TBLFM: @2$3=$1+$2;T
Values must be of the form =[HH:]MM:SS=, where hours are
optional.
Thanks to Martin Halder, Eric Schulte and Carsten for code and
feedback on this.
**** Implement formulas applying to field ranges
Carsten implemented this field-ranges formulas.
: A frequently requested feature for tables has been to be able to define
: row formulas in a way similar to column formulas. The patch below allows
: things like
:
: @3=
: @2$2..@5$7=
: @I$2..@II$4=
:
: as the left hand side for table formulas in order to write a formula that
: is valid for an entire column or for a rectangular section in a
: table.
Thanks a lot to Carsten for this.
**** Sending radio tables from org buffers is now allowed
Org radio tables can no also be sent inside Org buffers. Also,
there is a new hook which get called after a table has been sent.
Thanks to Seweryn Kokot.
*** Lists
**** Improved handling of lists
Nicolas Goaziou extended and improved the way Org handles lists.
1. Indentation of text determines again end of items in
lists. So, some text less indented than the previous item
doesn't close the whole list anymore, only all items more
indented than it.
2. Alphabetical bullets are implemented, through the use of the
variable `org-alphabetical-lists'. This also adds alphabetical
counters like [@c] or [@W].
3. Lists can now safely contain drawers, inline tasks, or various
blocks, themselves containing lists. Two variables are
controlling this: `org-list-forbidden-blocks', and
`org-list-export-context'.
4. Improve `newline-and-indent' (C-j): used in an item, it will
keep text from moving at column 0. This allows to split text
and make paragraphs and still not break the list.
5. Improve `org-toggle-item' (C-c -): used on a region with
standard text, it will change the region into one item. With a
prefix argument, it will fallback to the previous behavior and
make every line in region an item. It permits to easily
integrate paragraphs inside a list.
6. `fill-paragraph' (M-q) now understands lists. It can freely be
used inside items, or on text just after a list, even with no
blank line around, without breaking list structure.
Thanks a lot to Nicolas for all this!
*** Inline display of linked images
Images can now be displayed inline. The key C-c C-x C-v does
toggle the display of such images. Note that only image links
that have no description part will be inlined.
*** Implement offsets for ordered lists
If you want to start an ordered plain list with a number different
from 1, you can now do it like this:
: 1. [@start:12] will star a lit a number 12
*** Babel: code block body expansion for table and preview
In org-babel, code is "expanded" prior to evaluation. I.e. the
code that is actually evaluated comprises the code block contents,
augmented with the extra code which assigns the referenced data to
variables. It is now possible to preview expanded contents, and
also to expand code during tangling. This expansion takes
into account all header arguments, and variables.
A new keybinding `C-c M-b p' bound to `org-babel-expand-src-block'
can be used from inside of a source code block to preview its
expanded contents (which can be very useful for debugging).
tangling
The expanded body can now be tangled, this includes variable
values which may be the results of other source-code blocks, or
stored in headline properties or tables. One possible use for this
is to allow those using org-babel for their emacs initialization
to store values (e.g. usernames, passwords, etc...) in headline
properties or in tables.
Org-babel now supports three new header arguments, and new default
behavior for handling horizontal lines in tables (hlines), column
names, and rownames across all languages.
*** Editing Convenience and Appearance
**** New command =org-copy-visible= (=C-c C-x v=)
This command will copy the visible text in the region into the
kill ring. Thanks to Florian Beck for this function and to
Carsten for adding it to org.el and documenting it!
**** Make it possible to protect hidden subtrees from being killed by =C-k=
See the new variable =org-ctrl-k-protect-subtree=. This was a
request by Scott Otterson.
**** Implement pretty display of entities, sub-, and superscripts.
The command =C-c C-x \= toggles the display of Org's special
entities like =\alpha= as pretty unicode characters. Also, sub
and superscripts are displayed in a pretty way (raised/lower
display, in a smaller font). If you want to exclude sub- and
superscripts, see the variable
=org-pretty-entities-include-sub-superscripts=.
Thanks to Eric Schulte and Ulf Stegeman for making this possible.
**** New faces for title, date, author and email address lines
The keywords in these lines are now dimmed out, and the title is
displayed in a larger font, and a special font is also used for
author, date, and email information. This is implemented by the
following new faces:
=org-document-title=
=org-document-info=
=org-document-info-keyword=
In addition, the variable =org-hidden-keywords= can be used to
make the corresponding keywords disappear.
Thanks to Dan Davison for this feature.
**** Simpler way to specify faces for tags and todo keywords
The variables =org-todo-keyword-faces=, =org-tag-faces=, and
=org-priority-faces= now accept simple color names as
specifications. The colors will be used as either foreground or
background color for the corresponding keyword. See also the
variable =org-faces-easy-properties=, which governs which face
property is affected by this setting.
This is really a great simplification for setting keyword faces.
The change is based on an idea and patch by Ryan Thompson.
**** in tables now means fixed width, not maximum width
Requested by Michael Brand.
**** Better level cycling function
=TAB= in an empty headline cycles the level of that headline
through likely states. Ryan Thompson implemented an improved
version of this function, which does not depend upon when exactly
this command is used. Thanks to Ryan for this improvement.
**** Adaptive filling
For paragraph text, =org-adaptive-fill-function= did not handle
the base case of regular text which needed to be filled. This is
now fixed. Among other things, it allows email-style ">"
comments to be filled correctly.
Thanks to Dan Hackney for this patch.
**** `org-reveal' (=C-c C-r=) also decrypts encrypted entries (org-crypt.el)
Thanks to Richard Riley for triggering this change.
**** Better automatic letter selection for TODO keywords
When all first letters of keywords have been used, Org now
assigns more meaningful characters based on the keywords.
Thanks to Mikael Fornius for this patch.
*** Clocking
**** Clock: Allow synchronous update of timestamps in CLOCK log
Using =S-M-= on CLOCK log timestamps will
increase/decrease the two timestamps on this line so that
duration will keep the same. Note that duration can still be
slightly modified in case a timestamp needs some rounding.
Thanks to Rainer Stengele for this idea.
**** Localized clock tables
Clock tables now support a new =:lang= parameter, allowing
the user to customize the localization of the table headers. See
the variable =org-clock-clocktable-language-setup= which controls
available translated strings.
**** Show clock overruns in mode line
When clocking an item with a planned effort, overrunning the
planned time is now made visible in the mode line, for example
using the new face =org-mode-line-clock-overrun=, or by adding an
extra string given by =org-task-overrun-text=.
Thanks to Richard Riley for a patch to this effect.
**** Clock reports can now include the running, incomplete clock
If you have a clock running, and the entry being clocked falls
into the scope when creating a clock table, the time so far spent
can be added to the total. This behavior depends on the setting
of =org-clock-report-include-clocking-task=. The default is
=nil=.
Thanks to Bernt Hansen for this useful addition.
*** Misc
**** Improvements with inline tasks and indentation
There is now a configurable way on how to export inline tasks.
See the new variable =org-inlinetask-export-templates=.
Thanks to Nicolas Goaziou for coding these changes.
**** A property value of =nil= now means to unset a property
This can be useful in particular with property inheritance, if
some upper level has the property, and some grandchild of it
would like to have the default settings (i.e. not overruled by a
property) back.
Thanks to Robert Goldman and Bernt Hansen for suggesting this
change.
**** New helper functions in org-table.el
There are new functions to access and write to a specific table field.
This is for hackers, and maybe for the org-babel people.
#+begin_example
org-table-get
org-table-put
org-table-current-line
org-table-goto-line
#+end_example
**** Archiving: Allow to reverse order in target node
The new option =org-archive-reversed-order= allows to have
archived entries inserted in a last-on-top fashion in the target
node.
This was requested by Tom.
**** Org-reveal: Double prefix arg shows the entire subtree of the parent
This can help to get out of an inconsistent state produced for
example by viewing from the agenda.
This was a request by Matt Lundin.
* License
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
Andrew Dunning
Sebastian Karcher
Rintze M. Zelle
This work is licensed under a Creative Commons Attribution-ShareAlike 3.0 License
2015-10-10T23:31:02+00:00
accessed
and
and others
anonymous
anon.
at
available at
by
circa
c.
cited
edition
editions
ed.
et al.
forthcoming
from
ibid.
in
in press
internet
interview
letter
no date
n.d.
online
presented at the
reference
references
ref.
refs.
retrieved
scale
version
AD
BC
“
”
‘
’
–
th
st
nd
rd
th
th
th
first
second
third
fourth
fifth
sixth
seventh
eighth
ninth
tenth
book
books
chapter
chapters
column
columns
figure
figures
folio
folios
number
numbers
line
lines
note
notes
opus
opera
page
pages
page
pages
paragraph
paragraphs
part
parts
section
sections
sub verbo
sub verbis
verse
verses
volume
volumes
bk.
bks.
chap.
chaps.
col.
cols.
fig.
figs.
fol.
fols.
no.
nos.
l.
ll.
n.
nn.
op.
opp.
p.
pp.
p.
pp.
para.
paras.
pt.
pts.
sec.
secs.
s.v.
s.vv.
v.
vv.
vol.
vols.
¶
¶¶
§
§§
director
directors
editor
editors
editor
editors
illustrator
illustrators
translator
translators
editor & translator
editors & translators
dir.
dirs.
ed.
eds.
ed.
eds.
ill.
ills.
tran.
trans.
ed. & tran.
eds. & trans.
by
directed by
edited by
edited by
illustrated by
interview by
to
by
translated by
edited & translated by
dir. by
ed. by
ed. by
illus. by
trans. by
ed. & trans. by
January
February
March
April
May
June
July
August
September
October
November
December
Jan.
Feb.
Mar.
Apr.
May
Jun.
Jul.
Aug.
Sep.
Oct.
Nov.
Dec.
Spring
Summer
Autumn
Winter
org-mode-9.7.29+dfsg/etc/styles/ 0000775 0000000 0000000 00000000000 15004304337 0016347 5 ustar 00root root 0000000 0000000 org-mode-9.7.29+dfsg/etc/styles/OrgOdtContentTemplate.xml 0000664 0000000 0000000 00000050746 15004304337 0023332 0 ustar 00root root 0000000 0000000
org-mode-9.7.29+dfsg/etc/styles/OrgOdtStyles.xml 0000664 0000000 0000000 00000212052 15004304337 0021475 0 ustar 00root root 0000000 0000000
/
/
org-mode-9.7.29+dfsg/etc/styles/README 0000664 0000000 0000000 00000002505 15004304337 0017231 0 ustar 00root root 0000000 0000000 The files OrgOdtContentTemplate.xml and OrgOdtStyles.xml have the
following copyright information:
Copyright (C) 2010-2025 Free Software Foundation, Inc.
These files are 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
Keywords: outlines, hypermedia, calendar, wp
URL: https://orgmode.org
Commentary:
These files are part of Org-mode's OpenDocument export module.
OrgOdtContentTemplate.xml provides a template within which the content
of an exported document is enclosed. This file contributes to
"content.xml" file within an exported document and acts as a
repository of automatic styles.
OrgOdtStyles.xml contributes to "styles.xml" file within an exported
document and acts as a repository of custom styles.
org-mode-9.7.29+dfsg/lisp/ 0000775 0000000 0000000 00000000000 15004304337 0015220 5 ustar 00root root 0000000 0000000 org-mode-9.7.29+dfsg/lisp/Makefile 0000664 0000000 0000000 00000004615 15004304337 0016666 0 ustar 00root root 0000000 0000000 .SUFFIXES: # we don't need default suffix rules
ifeq ($(MAKELEVEL), 0)
$(error This make needs to be started as a sub-make from the toplevel directory.)
endif
LISPV := org-version.el
LISPI := org-loaddefs.el
LISPA := $(LISPV) $(LISPI)
LISPB := $(LISPA:%el=%elc) org-install.elc
LISPF := $(filter-out $(LISPA),$(sort $(wildcard *.el)))
LISPC := $(filter-out $(LISPB) $(LISPN:%el=%elc),$(LISPF:%el=%elc))
LISPN := $(filter-out $(LISPB) $(LISPN:%el=%eln),$(LISPF:%el=%eln))
_ORGCM_ := dirall single native source slint1 slint2
-include local.mk
.PHONY: all compile compile-dirty \
$(_ORGCM_) $(_ORGCM_:%=compile-%) \
autoloads \
install clean cleanauto cleanall cleanelc clean-install
# do not clean here, done in toplevel make
all compile compile-dirty:: | autoloads
ifeq ($(filter-out $(_ORGCM_),$(ORGCM)),)
$(MAKE) compile-$(ORGCM)
else
$(error ORGCM has illegal value $(ORGCM) (valid: $(_ORGCM_)))
endif
compile-dirall: dirall
compile-single: $(LISPC) | single
compile-native: $(LISPN) | native
compile-source: | source dirall
compile-slint1: | dirall slint1
compile-slint2: | source dirall slint1
# internal
dirall:
@$(info ==================== $@ ====================)
@$(ELCDIR)
single:
@$(info ==================== $@ ====================)
native:
@$(info ==================== $@ ====================)
source: cleanelc
@$(info ==================== $@ ====================)
@$(foreach elc,$(LISPC),$(MAKE) $(elc) && $(RM) $(elc);)
slint1:
@$(info ==================== $@ ====================)
@$(foreach elc,$(LISPC),$(RM) $(elc); $(MAKE) $(elc);)
%.elc: %.el
@$(info Compiling single $(abspath $<)...)
-@$(ELC) $<
%.eln: %.el
@$(info Native compiling single $(abspath $<)...)
-@$(ELN) $<
autoloads: cleanauto $(LISPI) $(LISPV)
$(LISPV): $(LISPF)
@echo "org-version: $(ORGVERSION) ($(GITVERSION))"
@$(RM) $(@)
@$(MAKE_ORG_VERSION)
$(LISPI): $(LISPV) $(LISPF)
@echo "org-loaddefs: $(ORGVERSION) ($(GITVERSION))"
@$(RM) $(@)
@$(MAKE_ORG_INSTALL)
install: compile $(LISPF)
if [ ! -d $(DESTDIR)$(lispdir) ] ; then \
$(MKDIR) $(DESTDIR)$(lispdir) ; \
fi ;
$(CP) $(LISPC) $(LISPF) $(LISPA) $(DESTDIR)$(lispdir)
cleanauto clean cleanall::
$(RM) $(LISPA) $(LISPB)
clean cleanall cleanelc::
$(RM) *.elc
clean-install:
if [ -d $(DESTDIR)$(lispdir) ] ; then \
$(RM) $(DESTDIR)$(lispdir)/org*.el* $(DESTDIR)$(lispdir)/ob*.el* $(DESTDIR)$(lispdir)/ol*.el* $(DESTDIR)$(lispdir)/ox*.el* ; \
fi ;
org-mode-9.7.29+dfsg/lisp/ob-C.el 0000664 0000000 0000000 00000042424 15004304337 0016330 0 ustar 00root root 0000000 0000000 ;;; ob-C.el --- Babel Functions for C and Similar Languages -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2025 Free Software Foundation, Inc.
;; Author: Eric Schulte
;; Thierry Banel
;; Maintainer: Thierry Banel
;; Keywords: literate programming, reproducible research
;; URL: https://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 ) gives us a list of
;; symbols; convert those to strings.
(when (symbolp inc) (setq inc (symbol-name inc)))
(if (string-prefix-p "<" inc)
(format "#include %s" inc)
(format "#include \"%s\"" inc)))
includes "\n")
;; defines
(mapconcat
(lambda (inc) (format "#define %s" inc))
(if (listp defines) defines (list defines)) "\n")
;; namespaces
(mapconcat
(lambda (inc) (format "using namespace %s;" inc))
namespaces
"\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 (lambda (head)
(let* ((tblnm (car head))
(tbl (cdr (car (let* ((el vars))
(while (not (or (equal tblnm (caar el)) (not el)))
(setq el (cdr el)))
el))))
(type (org-babel-C-val-to-base-type tbl)))
(org-babel-C-header-to-C head type))) 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 D BODY according to its header arguments PARAMS."
(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 (lambda (head)
(let* ((tblnm (car head))
(tbl (cdr (car (let* ((el vars))
(while (not (or (equal tblnm (caar el)) (not el)))
(setq el (cdr el)))
el))))
(type (org-babel-C-val-to-base-type tbl)))
(org-babel-C-header-to-C head type))) colnames "\n")
;; body
(if main-p
(org-babel-C-ensure-main-wrap body)
body) "\n") "\n")))
(defun org-babel-C-ensure-main-wrap (body)
"Wrap BODY in a \"main\" function call if none exists."
(if (string-match "^[ \t]*[intvod]+[ \t\n\r]*main[ \t]*(.*)" body)
body
(format "int main() {\n%s\nreturn 0;\n}\n" body)))
(defun org-babel-prep-session:C (_session _params)
"Throw and error that sessions are not supported.
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)
"Throw and error that sessions are not supported.
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"))
;; helper functions
(defun org-babel-C-format-val (type val)
"Handle the FORMAT part of TYPE with the data from VAL."
(let ((format-data (cadr type)))
(if (stringp format-data)
(cons "" (format format-data val))
(funcall format-data val))))
(defun org-babel-C-val-to-C-type (val)
"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."
(let* ((basetype (org-babel-C-val-to-base-type val))
(type
(pcase basetype
(`integerp '("int" "%d"))
(`floatp '("double" "%s")) ;; %f rounds, use %s to print the float literally
(`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
(pcase org-babel-c-variant
((or `c `cpp) (format "[%d][%d]" (length val) (length (car val))))
(`d (format "[%d][%d]" (length (car val)) (length 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-base-type (val)
"Determine the base type of VAL.
The type is:
- `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
(when (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 PAIR of (var . val) C variable assignment."
;; TODO list support
(let ((var (car pair))
(val (cdr pair)))
(when (symbolp val)
(setq val (symbol-name val))
(when (= (length val) 1)
(setq val (string-to-char val))))
(let* ((type-data (org-babel-C-val-to-C-type val))
(type (car type-data))
(formatted (org-babel-C-format-val type-data val))
(suffix (car formatted))
(data (cdr formatted)))
(pcase org-babel-c-variant
((or `c `cpp)
(format "%s %s%s = %s;"
type
var
suffix
data))
(`d
(format "%s%s %s = %s;"
type
suffix
var
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)
(concat
"
#ifndef _STRING_H
#include
#endif
int get_column_num (int nbcols, const char** header, const char* column)
{
int c;
for (c=0; c
;; Keywords: literate programming, reproducible research, R, statistics
;; URL: https://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
;; Keywords: literate programming, reproducible research
;; URL: https://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
;; Keywords: literate programming, reproducible research
;; URL: https://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
;;
;; Keywords: literate programming, reproducible research
;; URL: https://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 \
Require confirmation before interactively evaluating code
blocks in Org buffers. The default value of this variable is t,
meaning confirmation is required for any code block evaluation.
This variable can be set to nil to inhibit any future
confirmation requests. This variable can also be set to a
function which takes two arguments the language of the code block
and the body of the code block. Such a function should then
return a non-nil value if the user should be prompted for
execution or nil if no prompt is required.
Warning: Disabling confirmation may result in accidental
evaluation of potentially harmful code. It may be advisable
remove code block execution from `\\[org-ctrl-c-ctrl-c]' \
as further protection
against accidental code block evaluation. The
`org-babel-no-eval-on-ctrl-c-ctrl-c' variable can be used to
remove code block execution from the `\\[org-ctrl-c-ctrl-c]' keybinding."
:group 'org-babel
:version "24.1"
:type '(choice boolean function))
;; don't allow this variable to be changed through file settings
(put 'org-confirm-babel-evaluate 'safe-local-variable (lambda (x) (eq x t)))
(defcustom org-babel-no-eval-on-ctrl-c-ctrl-c nil
"\\\
Remove code block evaluation from the `\\[org-ctrl-c-ctrl-c]' key binding."
:group 'org-babel
:version "24.1"
:type 'boolean)
(defcustom org-babel-results-keyword "RESULTS"
"Keyword used to name results generated by code blocks.
It should be \"RESULTS\". However any capitalization may be
used."
:group 'org-babel
:version "24.4"
:package-version '(Org . "8.0")
:type 'string
:safe (lambda (v)
(and (stringp v)
(org-string-equal-ignore-case "RESULTS" v))))
(defcustom org-babel-noweb-wrap-start "<<"
"String used to begin a noweb reference in a code block.
See also `org-babel-noweb-wrap-end'."
:group 'org-babel
:type 'string)
(defcustom org-babel-noweb-wrap-end ">>"
"String used to end a noweb reference in a code block.
See also `org-babel-noweb-wrap-start'."
:group 'org-babel
:type 'string)
(defcustom org-babel-inline-result-wrap "=%s="
"Format string used to wrap inline results.
This string must include a \"%s\" which will be replaced by the results."
:group 'org-babel
:type 'string)
(put 'org-babel-inline-result-wrap
'safe-local-variable
(lambda (value)
(and (stringp value)
(string-match-p "%s" value))))
(defcustom org-babel-hash-show-time nil
"Non-nil means show the time the code block was evaluated in the result hash."
:group 'org-babel
:type 'boolean
:package-version '(Org . "9.0")
:safe #'booleanp)
(defcustom org-babel-uppercase-example-markers nil
"When non-nil, begin/end example markers will be inserted in upper case."
:group 'org-babel
:type 'boolean
:version "26.1"
:package-version '(Org . "9.1")
:safe #'booleanp)
(defun org-babel-noweb-wrap (&optional regexp)
"Return regexp matching a Noweb reference.
Match any reference, or only those matching REGEXP, if non-nil.
When matching, reference is stored in match group 1."
(concat (regexp-quote org-babel-noweb-wrap-start)
(or regexp "\\([^ \t\n]\\(?:.*?[^ \t\n]\\)?\\)")
(regexp-quote org-babel-noweb-wrap-end)))
(defvar org-babel-src-name-regexp
"^[ \t]*#\\+name:[ \t]*"
"Regular expression used to match a source name line.")
(defvar org-babel-multi-line-header-regexp
"^[ \t]*#\\+headers?:[ \t]*\\([^\n]*\\)$"
"Regular expression used to match multi-line header arguments.")
(defvar org-babel-src-block-regexp
(concat
;; (1) indentation (2) lang
"^\\([ \t]*\\)#\\+begin_src[ \t]+\\([^ \f\t\n\r\v]+\\)[ \t]*"
;; (3) switches
"\\([^\":\n]*\"[^\"\n*]*\"[^\":\n]*\\|[^\":\n]*\\)"
;; (4) header arguments
"\\([^\n]*\\)\n"
;; (5) body
"\\(\\(?:.\\|\n\\)*?\n\\)??[ \t]*#\\+end_src")
"Regexp used to identify code blocks.")
(defun org-babel--get-vars (params)
"Return the babel variable assignments in PARAMS.
PARAMS is a quasi-alist of header args, which may contain
multiple entries for the key `:var'. This function returns a
list of the cdr of all the `:var' entries."
(mapcar #'cdr
(cl-remove-if-not (lambda (x) (eq (car x) :var)) params)))
(defvar org-babel-exp-reference-buffer nil
"Buffer containing original contents of the exported buffer.
This is used by Babel to resolve references in source blocks.
Its value is dynamically bound during export.")
(defun org-babel-check-confirm-evaluate (info)
"Check whether INFO allows code block evaluation.
Returns nil if evaluation is disallowed, t if it is
unconditionally allowed, and the symbol `query' if the user
should be asked whether to allow evaluation."
(let* ((headers (nth 2 info))
(eval (or (cdr (assq :eval headers))
(when (assq :noeval headers) "no")))
(eval-no (member eval '("no" "never")))
(export org-babel-exp-reference-buffer)
(eval-no-export (and export (member eval '("no-export" "never-export"))))
(noeval (or eval-no eval-no-export))
(query (or (equal eval "query")
(and export (equal eval "query-export"))
(if (functionp org-confirm-babel-evaluate)
(funcall org-confirm-babel-evaluate
;; Language, code block body.
(nth 0 info)
(org-babel--expand-body info))
org-confirm-babel-evaluate))))
(cond
(noeval nil)
(query 'query)
(t t))))
(defun org-babel-check-evaluate (info)
"Check if code block INFO should be evaluated.
Do not query the user, but do display an informative message if
evaluation is blocked. Returns non-nil if evaluation is not blocked."
(let ((confirmed (org-babel-check-confirm-evaluate info)))
(unless confirmed
(message "Evaluation of this %s code block%sis disabled."
(nth 0 info)
(let ((name (nth 4 info)))
(if name (format " (%s) " name) " "))))
confirmed))
;; Dynamically scoped for asynchronous export.
(defvar org-babel-confirm-evaluate-answer-no)
(defun org-babel-confirm-evaluate (info)
"Confirm evaluation of the code block INFO.
This query can also be suppressed by setting the value of
`org-confirm-babel-evaluate' to nil, in which case all future
interactive code block evaluations will proceed without any
confirmation from the user.
Note disabling confirmation may result in accidental evaluation
of potentially harmful code.
The variable `org-babel-confirm-evaluate-answer-no' is used by
the async export process, which requires a non-interactive
environment, to override this check."
(let* ((evalp (org-babel-check-confirm-evaluate info))
(lang (nth 0 info))
(name (nth 4 info))
(name-string (if name (format " (%s) " name) " ")))
(pcase evalp
(`nil nil)
(`t t)
(`query (or
(and (not (bound-and-true-p
org-babel-confirm-evaluate-answer-no))
(yes-or-no-p
(format "Evaluate this %s code block%son your system? "
lang name-string)))
(progn
(message "Evaluation of this %s code block%sis aborted."
lang name-string)
nil)))
(x (error "Unexpected value `%s' from `org-babel-check-confirm-evaluate'" x)))))
;;;###autoload
(defun org-babel-execute-safely-maybe ()
"Maybe `org-babel-execute-maybe'.
This function does nothing unless `org-babel-no-eval-on-ctrl-c-ctrl-c'
is non-nil."
(unless org-babel-no-eval-on-ctrl-c-ctrl-c
(org-babel-execute-maybe)))
;;;###autoload
(defun org-babel-execute-maybe ()
"Execute src block or babel call at point."
(interactive)
(or (org-babel-execute-src-block-maybe)
(org-babel-lob-execute-maybe)))
(defmacro org-babel-when-in-src-block (&rest body)
"Execute BODY if point is in a source block and return t.
Otherwise do nothing and return nil."
`(if (org-element-type-p (org-element-context) '(inline-src-block src-block))
(progn
,@body
t)
nil))
(defun org-babel-execute-src-block-maybe ()
"Conditionally execute a source block.
Detect if this is context for a Babel src-block and if so
then run `org-babel-execute-src-block'."
(interactive)
(org-babel-when-in-src-block
(org-babel-eval-wipe-error-buffer)
(org-babel-execute-src-block current-prefix-arg)))
;;;###autoload
(defun org-babel-view-src-block-info ()
"Display information on the current source block.
This includes header arguments, language and name, and is largely
a window into the `org-babel-get-src-block-info' function."
(interactive)
(let ((info (org-babel-get-src-block-info 'no-eval))
(full (lambda (it) (> (length it) 0)))
(printf (lambda (fmt &rest args) (princ (apply #'format fmt args)))))
(when info
(let* ((name (nth 4 info))
(language (nth 0 info))
(switches (nth 3 info))
(header-args (nth 2 info))
(property-header-args
(org-entry-get (point) "header-args" t))
(property-header-args-language
(org-entry-get (point) (concat "header-args:" language) t)))
(with-help-window (help-buffer)
(when name (funcall printf "Name: %s\n" name))
(when language (funcall printf "Language: %s\n" language))
;; Show header arguments that have been set through
;; properties (i.e. in property drawers or through
;; #+PROPERTY)
(funcall printf "Properties:\n")
(funcall printf "\t:header-args \t%s\n" property-header-args)
(funcall printf "\t:header-args:%s \t%s\n" language property-header-args-language)
;; Show switches
(when (funcall full switches) (funcall printf "Switches: %s\n" switches))
;; Show default header arguments and header arguments that
;; have been explicitly set in the current code block.
(funcall printf "Header Arguments:\n")
(dolist (pair (sort header-args
(lambda (a b) (string< (symbol-name (car a))
(symbol-name (car b))))))
(when (funcall full (format "%s" (cdr pair)))
(funcall printf "\t%S%s\t%s\n"
(car pair)
(if (> (length (format "%S" (car pair))) 7) "" "\t")
(cdr pair)))))))))
;;;###autoload
(defun org-babel-expand-src-block-maybe ()
"Conditionally expand a source block.
Detect if this is context for an org-babel src-block and if so
then run `org-babel-expand-src-block'."
(interactive)
(org-babel-when-in-src-block
(org-babel-expand-src-block current-prefix-arg)))
;;;###autoload
(defun org-babel-load-in-session-maybe ()
"Conditionally load a source block in a session.
Detect if this is context for an org-babel src-block and if so
then run `org-babel-load-in-session'."
(interactive)
(org-babel-when-in-src-block
(org-babel-load-in-session current-prefix-arg)))
(add-hook 'org-metaup-hook 'org-babel-load-in-session-maybe)
;;;###autoload
(defun org-babel-pop-to-session-maybe ()
"Conditionally pop to a session.
Detect if this is context for an org-babel src-block and if so
then run `org-babel-switch-to-session'."
(interactive)
(org-babel-when-in-src-block
(org-babel-switch-to-session current-prefix-arg)))
(add-hook 'org-metadown-hook 'org-babel-pop-to-session-maybe)
(defconst org-babel-common-header-args-w-values
'((cache . ((no yes)))
(cmdline . :any)
(colnames . ((nil no yes)))
(comments . ((no link yes org both noweb)))
(dir . :any)
(eval . ((yes no no-export strip-export never-export eval never
query)))
(exports . ((code results both none)))
(epilogue . :any)
(file . :any)
(file-desc . :any)
(file-ext . :any)
(file-mode . ((#o755 #o555 #o444 :any)))
(hlines . ((no yes)))
(mkdirp . ((yes no)))
(no-expand)
(noeval)
(noweb . ((yes no tangle strip-tangle no-export strip-export)))
(noweb-ref . :any)
(noweb-sep . :any)
(noweb-prefix . ((no yes)))
(output-dir . :any)
(padline . ((yes no)))
(post . :any)
(prologue . :any)
(results . ((file list vector table scalar verbatim)
(raw html latex org code pp drawer link graphics)
(replace silent none discard append prepend)
(output value)))
(rownames . ((no yes)))
(sep . :any)
(session . :any)
(shebang . :any)
(tangle . ((tangle yes no :any)))
(tangle-mode . ((#o755 #o555 #o444 :any)))
(var . :any)
(wrap . :any))
"Alist defining common header args and their allowed values.
Keys of the alist are header arg symbols.
Values of the alist are either a symbol `:any' or a list of allowed
values as symbols:
(header-name . :any)
(header-name . ((value1 value2 value3 ...))
(header-name . ((value1 value2 value3 ... :any))
When Org considers header-arg property inheritance, the innermost
value from the list is considered.
Symbol `:any' in the value list implies that any value is allowed.
Yet the explicitly listed values from the list will be offered as
completion candidates.
FIXME: This is currently just supported for `results' and `exports'.
Values in the alist can also be a list of lists. The inner lists
define exclusive groups of values that can be set at the same time for
a given header argument.
(results . ((file list ...)
(raw html ...))
The above example allows multi-component header arguments like
#+begin_src bash :results file raw
<:results will combine the two values \"file raw\".>
#+begin_src bash :results file list
<:results will only use the last value \"list\".>
#+property: header-args :results file html
...
#+begin_src bash :results list
<:results will inherit with partial override \"list html\".>
See info node `(org)Results of evaluation' for more details.")
(defconst org-babel-header-arg-names
(mapcar #'car org-babel-common-header-args-w-values)
"Common header arguments used by org-babel.
Note that individual languages may define their own language
specific header arguments as well.")
(defconst org-babel-safe-header-args
'(:cache :colnames :comments :exports :epilogue :hlines :noeval
:noweb :noweb-ref :noweb-sep :noweb-prefix :padline
:prologue :rownames :sep :session :tangle :wrap
(:eval . ("never" "query"))
(:results . (lambda (str) (not (string-match "file" str)))))
"A list of safe header arguments for babel source blocks.
The list can have entries of the following forms:
- :ARG -> :ARG is always a safe header arg
- (:ARG . (VAL1 VAL2 ...)) -> :ARG is safe as a header arg if it is
`equal' to one of the VALs.
- (:ARG . FN) -> :ARG is safe as a header arg if the function FN
returns non-nil. FN is passed one
argument, the value of the header arg
(as a string).")
(defmacro org-babel-header-args-safe-fn (safe-list)
"Return a function that determines whether a list of header args are safe.
Intended usage is:
\(put \\='org-babel-default-header-args \\='safe-local-variable
(org-babel-header-args-safe-p org-babel-safe-header-args)
This allows org-babel languages to extend the list of safe values for
their `org-babel-default-header-args:foo' variable.
For the format of SAFE-LIST, see `org-babel-safe-header-args'."
`(lambda (value)
(and (listp value)
(cl-every
(lambda (pair)
(and (consp pair)
(org-babel-one-header-arg-safe-p pair ,safe-list)))
value))))
(defvar org-babel-default-header-args
'((:session . "none") (:results . "replace") (:exports . "code")
(:cache . "no") (:noweb . "no") (:hlines . "no") (:tangle . "no"))
"Default arguments to use when evaluating a source block.
This is a list in which each element is an alist. Each key
corresponds to a header argument, and each value to that header's
value. The value can either be a string or a closure that
evaluates to a string.
A closure is evaluated when the source block is being
evaluated (e.g. during execution or export), with point at the
source block. It is not possible to use an arbitrary function
symbol (e.g. `some-func'), since org uses lexical binding. To
achieve the same functionality, call the function within a
closure (e.g. (lambda () (some-func))).
To understand how closures can be used as default header
arguments, imagine you'd like to set the file name output of a
latex source block to a sha1 of its contents. We could achieve
this with:
(defun org-src-sha ()
(let ((elem (org-element-at-point)))
(concat (sha1 (org-element-property :value elem)) \".svg\")))
(setq org-babel-default-header-args:latex
`((:results . \"file link replace\")
(:file . (lambda () (org-src-sha)))))
Because the closure is evaluated with point at the source block,
the call to `org-element-at-point' above will always retrieve
information about the current source block.
Some header arguments can be provided multiple times for a source
block. An example of such a header argument is :var. This
functionality is also supported for default header arguments by
providing the header argument multiple times in the alist. For
example:
((:var . \"foo=\\\"bar\\\"\")
(:var . \"bar=\\\"foo\\\"\"))")
(put 'org-babel-default-header-args 'safe-local-variable
(org-babel-header-args-safe-fn org-babel-safe-header-args))
(defvar org-babel-default-inline-header-args
'((:session . "none") (:results . "replace")
(:exports . "results") (:hlines . "yes"))
"Default arguments to use when evaluating an inline source block.")
(put 'org-babel-default-inline-header-args 'safe-local-variable
(org-babel-header-args-safe-fn org-babel-safe-header-args))
(defconst org-babel-name-regexp
(format "^[ \t]*#\\+%s:[ \t]*"
;; FIXME: TBLNAME is for backward compatibility.
(regexp-opt '("NAME" "TBLNAME")))
"Regexp matching a NAME keyword.")
(defconst org-babel-result-regexp
(rx (seq bol
(zero-or-more (any "\t "))
"#+results"
(opt "["
;; Time stamp part.
(opt "("
(= 4 digit) (= 2 "-" (= 2 digit))
" "
(= 2 digit) (= 2 ":" (= 2 digit))
") ")
;; SHA1 hash.
(group (one-or-more hex-digit))
"]")
":"
(zero-or-more (any "\t "))))
"Regular expression used to match result lines.
If the results are associated with a hash key then the hash will
be saved in match group 1.")
(defconst org-babel-result-w-name-regexp
(concat org-babel-result-regexp "\\(?9:[^ \t\n\r\v\f]+\\)")
"Regexp matching a RESULTS keyword with a name.
Name is saved in match group 9.")
(defvar org-babel-min-lines-for-block-output 10
"The minimum number of lines for block output.
If number of lines of output is equal to or exceeds this
value, the output is placed in a #+begin_example...#+end_example
block. Otherwise the output is marked as literal by inserting
colons at the starts of the lines. This variable only takes
effect if the :results output option is in effect.")
(defvar org-babel-noweb-error-all-langs nil
"Raise errors when noweb references don't resolve.
Also see `org-babel-noweb-error-langs' to control noweb errors on
a language by language bases.")
(defvar org-babel-noweb-error-langs nil
"Languages for which Babel will raise literate programming errors.
List of languages for which errors should be raised when the
source code block satisfying a noweb reference in this language
can not be resolved. Also see `org-babel-noweb-error-all-langs'
to raise errors for all languages.")
(defvar org-babel-hash-show 4
"Number of initial characters to show of a hidden results hash.")
(defvar org-babel-after-execute-hook nil
"Hook for functions to be called after `org-babel-execute-src-block'.")
(defun org-babel-named-src-block-regexp-for-name (&optional name)
"Generate a regexp used to match a source block named NAME.
If NAME is nil, match any name. Matched name is then put in
match group 9. Other match groups are defined in
`org-babel-src-block-regexp'."
(concat org-babel-src-name-regexp
(concat (if name (regexp-quote name) "\\(?9:.*?\\)") "[ \t]*" )
"\\(?:\n[ \t]*#\\+\\S-+:.*\\)*?"
"\n"
(substring org-babel-src-block-regexp 1)))
(defun org-babel-named-data-regexp-for-name (name)
"Generate a regexp used to match data named NAME."
(concat org-babel-name-regexp (regexp-quote name) "[ \t]*$"))
(defun org-babel--normalize-body (datum)
"Normalize body for element or object DATUM.
DATUM is a source block element or an inline source block object.
Remove final newline character and spurious indentation."
(let* ((value (org-element-property :value datum))
(body (if (string-suffix-p "\n" value)
(substring value 0 -1)
value)))
(cond ((org-element-type-p datum 'inline-src-block)
;; Newline characters and indentation in an inline
;; src-block are not meaningful, since they could come from
;; some paragraph filling. Treat them as a white space.
(replace-regexp-in-string "\n[ \t]*" " " body))
((org-src-preserve-indentation-p datum) body)
(t (org-remove-indentation body)))))
;;; functions
(defvar org-babel-current-src-block-location nil
"Marker pointing to the source block currently being executed.
This may also point to a call line or an inline code block. If
multiple blocks are being executed (e.g., in chained execution
through use of the :var header argument) this marker points to
the outer-most code block.")
(defun org-babel-eval-headers (headers)
"Compute header list set with HEADERS.
Evaluate all header arguments set to functions prior to returning
the list of header arguments."
(let ((lst nil))
(dolist (elem headers)
(if (and (cdr elem) (functionp (cdr elem)))
(push `(,(car elem) . ,(funcall (cdr elem))) lst)
(push elem lst)))
(reverse lst)))
(defun org-babel-get-src-block-info (&optional no-eval datum)
"Extract information from a source block or inline source block.
When optional argument NO-EVAL is non-nil, Babel does not resolve
remote variable references; a process which could likely result
in the execution of other code blocks, and do not evaluate Lisp
values in parameters.
By default, consider the block at point. However, when optional
argument DATUM is provided, extract information from that parsed
object instead.
Return nil if point is not on a source block (blank lines after a
source block are considered a part of that source block).
Otherwise, return a list with the following pattern:
(language body arguments switches name start coderef)"
(let* ((datum (or datum (org-element-context)))
(type (org-element-type datum))
(inline (eq type 'inline-src-block)))
(when (memq type '(inline-src-block src-block))
(let* ((lang (org-element-property :language datum))
(lang-headers (intern
(concat "org-babel-default-header-args:" lang)))
(name (org-element-property :name datum))
(info
(list
lang
(org-babel--normalize-body datum)
(apply #'org-babel-merge-params
;; Use `copy-tree' to avoid creating shared structure
;; with the `org-babel-default-header-args-*' variables:
;; modifications by `org-babel-generate-file-param'
;; below would modify the shared structure, thereby
;; modifying the variables.
(copy-tree
(if inline org-babel-default-inline-header-args
org-babel-default-header-args)
t)
(and (boundp lang-headers)
(copy-tree (eval lang-headers t) t))
(append
;; If DATUM is provided, make sure we get node
;; properties applicable to its location within
;; the document.
(org-with-point-at (org-element-begin datum)
(org-babel-params-from-properties lang no-eval))
(mapcar (lambda (h)
(org-babel-parse-header-arguments h no-eval))
(cons (org-element-property :parameters datum)
(org-element-property :header datum)))))
(or (org-element-property :switches datum) "")
name
(org-element-property (if inline :begin :post-affiliated)
datum)
(and (not inline) (org-src-coderef-format datum)))))
(unless no-eval
(setf (nth 2 info) (org-babel-process-params (nth 2 info))))
(setf (nth 2 info) (org-babel-generate-file-param name (nth 2 info)))
info))))
(defun org-babel--expand-body (info)
"Expand noweb references in src block and remove any coderefs.
The src block is defined by its INFO, as returned by
`org-babel-get-src-block-info'."
(let ((coderef (nth 6 info))
(expand
(if (org-babel-noweb-p (nth 2 info) :eval)
(org-babel-expand-noweb-references info)
(nth 1 info))))
(if (not coderef) expand
(replace-regexp-in-string
(org-src-coderef-regexp coderef) "" expand nil nil 1))))
(defun org-babel--file-desc (params result)
"Retrieve description for file link result of evaluation.
PARAMS is header argument values. RESULT is the file link as returned
by the code block.
When `:file-desc' header argument is provided use its value or
duplicate RESULT in the description.
When `:file-desc' is missing, return nil."
(pcase (assq :file-desc params)
(`nil nil)
(`(:file-desc) result)
(`(:file-desc . ,(and (pred stringp) val)) val)))
(defvar *this*)
;; Dynamically bound in `org-babel-execute-src-block'
;; and `org-babel-read'
(defun org-babel-session-buffer (&optional info)
"Return buffer name for session associated with current code block.
Return nil when no such live buffer with process exists.
When INFO is non-nil, it should be a list returned by
`org-babel-get-src-block-info'.
This function uses org-babel-session-buffer: function to
retrieve backend-specific session buffer name."
(declare-function org-babel-comint-buffer-livep "ob-comint" (buffer))
(when-let* ((info (or info (org-babel-get-src-block-info 'no-eval)))
(lang (nth 0 info))
(session (cdr (assq :session (nth 2 info))))
(cmd (intern (concat "org-babel-session-buffer:" lang)))
(buffer-name
(if (fboundp cmd)
(funcall cmd session info)
;; Use session name as buffer name by default.
session)))
(require 'ob-comint)
(when (org-babel-comint-buffer-livep buffer-name)
buffer-name)))
;;;###autoload
(defun org-babel-execute-src-block (&optional arg info params executor-type)
"Execute the current source code block and return the result.
Insert the results of execution into the buffer. Source code
execution and the collection and formatting of results can be
controlled through a variety of header arguments.
With prefix argument ARG, force re-execution even if an existing
result cached in the buffer would otherwise have been returned.
Optionally supply a value for INFO in the form returned by
`org-babel-get-src-block-info'.
Optionally supply a value for PARAMS which will be merged with
the header arguments specified at the front of the source code
block.
EXECUTOR-TYPE is the type of the org element responsible for the
execution of the source block. If not provided then informed
guess will be made."
(interactive)
(let* ((org-babel-current-src-block-location
(or org-babel-current-src-block-location
(nth 5 info)
(org-babel-where-is-src-block-head)))
(info (if info (copy-tree info) (org-babel-get-src-block-info)))
(executor-type
(or executor-type
;; If `executor-type' is unset, then we will make an
;; informed guess.
(pcase (and
;; When executing virtual src block, no location
;; is known.
org-babel-current-src-block-location
(char-after org-babel-current-src-block-location))
(?s 'inline-src-block)
(?c 'inline-babel-call)
(?# (pcase (char-after (+ 2 org-babel-current-src-block-location))
(?b 'src-block)
(?c 'call-block)
(_ 'unknown)))
(_ 'unknown)))))
;; Merge PARAMS with INFO before considering source block
;; evaluation since both could disagree.
(cl-callf org-babel-merge-params (nth 2 info) params)
(when (org-babel-check-evaluate info)
(cl-callf org-babel-process-params (nth 2 info))
(let* ((params (nth 2 info))
(cache (let ((c (cdr (assq :cache params))))
(and (not arg) c (string= "yes" c))))
(new-hash (and cache (org-babel-sha1-hash info :eval)))
(old-hash (and cache (org-babel-current-result-hash)))
(current-cache (and new-hash (equal new-hash old-hash))))
(cond
(current-cache
(save-excursion ;Return cached result.
(goto-char (org-babel-where-is-src-block-result nil info))
(forward-line)
(skip-chars-forward " \t")
(let ((result (org-babel-read-result)))
(unless noninteractive
(message (format "Cached: %s"
(replace-regexp-in-string "%" "%%" (format "%S" result)))))
result)))
((org-babel-confirm-evaluate info)
(let* ((lang (nth 0 info))
(result-params (cdr (assq :result-params params)))
(body (org-babel--expand-body info))
(dir (cdr (assq :dir params)))
(mkdirp (cdr (assq :mkdirp params)))
(default-directory
(cond
((not dir) default-directory)
((when-let* ((session (org-babel-session-buffer info)))
(buffer-local-value 'default-directory (get-buffer session))))
((member mkdirp '("no" "nil" nil))
(file-name-as-directory (expand-file-name dir)))
(t
(let ((d (file-name-as-directory (expand-file-name dir))))
(make-directory d 'parents)
d))))
(cmd (intern (concat "org-babel-execute:" lang)))
result exec-start-time)
(unless (fboundp cmd)
(error "No org-babel-execute function for %s!" lang))
(unless noninteractive
(message "Executing %s %s %s..."
(capitalize lang)
(pcase executor-type
('src-block "code block")
('inline-src-block "inline code block")
('babel-call "call")
('inline-babel-call "inline call")
(e (symbol-name e)))
(let ((name (nth 4 info)))
(if name
(format "(%s)" name)
(format "at position %S" (nth 5 info))))))
(setq exec-start-time (current-time)
result
(let ((r
;; Code block may move point in the buffer.
;; Make sure that the point remains on the
;; code block.
(save-excursion (funcall cmd body params))))
(if (and (eq (cdr (assq :result-type params)) 'value)
(or (member "vector" result-params)
(member "table" result-params))
(not (listp r)))
(list (list r))
r)))
(let ((file (and (member "file" result-params)
(cdr (assq :file params)))))
;; If non-empty result and :file then write to :file.
(when file
;; If `:results' are special types like `link' or
;; `graphics', don't write result to `:file'. Only
;; insert a link to `:file'.
(when (and result
(not (or (member "link" result-params)
(member "graphics" result-params))))
(with-temp-file file
(insert (org-babel-format-result
result
(cdr (assq :sep params)))))
;; Set file permissions if header argument
;; `:file-mode' is provided.
(when (assq :file-mode params)
(set-file-modes file (cdr (assq :file-mode params)))))
(setq result file))
;; Possibly perform post process provided its
;; appropriate. Dynamically bind "*this*" to the
;; actual results of the block.
(let ((post (cdr (assq :post params))))
(when post
(let ((*this* (if (not file) result
(org-babel-result-to-file
file
(org-babel--file-desc params result)
'attachment))))
(setq result (org-babel-ref-resolve post))
(when file
(setq result-params (remove "file" result-params))))))
(unless (member "none" result-params)
(org-babel-insert-result
result result-params info
;; append/prepend cannot handle hash as we accumulate
;; multiple outputs together.
(when (member "replace" result-params) new-hash)
lang
(time-subtract (current-time) exec-start-time))))
(run-hooks 'org-babel-after-execute-hook)
result)))))))
(defun org-babel-expand-body:generic (body params &optional var-lines)
"Expand BODY with PARAMS.
Expand a block of code with org-babel according to its header
arguments. This generic implementation of body expansion is
called for languages which have not defined their own specific
org-babel-expand-body:lang function.
VAR-LINES is a list of lines that define variable environment. These
lines will be added after `:prologue' parameter and before BODY."
(let ((pro (cdr (assq :prologue params)))
(epi (cdr (assq :epilogue params))))
(mapconcat #'identity
(append (when pro (list pro))
var-lines
(list body)
(when epi (list epi)))
"\n")))
;;;###autoload
(defun org-babel-expand-src-block (&optional _arg info params)
"Expand the current source code block or block specified by INFO.
INFO is the output of `org-babel-get-src-block-info'.
PARAMS defines inherited header arguments.
Expand according to the source code block's header
arguments and pop open the results in a preview buffer."
(interactive)
(let* ((info (or info (org-babel-get-src-block-info)))
(lang (nth 0 info))
(params (setf (nth 2 info)
(sort (org-babel-merge-params (nth 2 info) params)
(lambda (el1 el2) (string< (symbol-name (car el1))
(symbol-name (car el2)))))))
(body (setf (nth 1 info)
(if (org-babel-noweb-p params :eval)
(org-babel-expand-noweb-references info) (nth 1 info))))
(expand-cmd (intern (concat "org-babel-expand-body:" lang)))
(assignments-cmd (intern (concat "org-babel-variable-assignments:"
lang)))
(expanded
(if (fboundp expand-cmd) (funcall expand-cmd body params)
(org-babel-expand-body:generic
body params (and (fboundp assignments-cmd)
(funcall assignments-cmd params))))))
(if (called-interactively-p 'any)
(org-edit-src-code
expanded (concat "*Org-Babel Preview " (buffer-name) "[ " lang " ]*"))
expanded)))
(defun org-babel-combine-header-arg-lists (original &rest others)
"Combine ORIGINAL and OTHERS lists of header argument names and arguments."
(let ((results (copy-sequence original)))
(dolist (new-list others)
(dolist (arg-pair new-list)
(let ((header (car arg-pair)))
(setq results
(cons arg-pair (cl-remove-if
(lambda (pair) (equal header (car pair)))
results))))))
results))
;;;###autoload
(defun org-babel-check-src-block ()
"Check for misspelled header arguments in the current code block."
(interactive)
;; TODO: report malformed code block
;; TODO: report incompatible combinations of header arguments
;; TODO: report uninitialized variables
(let ((too-close 2) ;; <- control closeness to report potential match
(names (mapcar #'symbol-name org-babel-header-arg-names)))
(dolist (header (mapcar (lambda (arg) (substring (symbol-name (car arg)) 1))
(and (org-babel-where-is-src-block-head)
(org-babel-parse-header-arguments
(org-no-properties
(match-string 4))))))
(dolist (name names)
(when (and (not (string= header name))
(<= (org-string-distance header name) too-close)
(not (member header names)))
(error "Supplied header \"%S\" is suspiciously close to \"%S\""
header name))))
(message "No suspicious header arguments found.")))
;;;###autoload
(defun org-babel-insert-header-arg (&optional header-arg value)
"Insert a header argument and its value.
HEADER-ARG and VALUE, when provided, are the header argument name and
its value. When HEADER-ARG or VALUE are nil, offer interactive
completion from lists of common args and values."
(interactive)
(let* ((info (org-babel-get-src-block-info 'no-eval))
(lang (car info))
(begin (nth 5 info))
(lang-headers (intern (concat "org-babel-header-args:" lang)))
(headers (org-babel-combine-header-arg-lists
org-babel-common-header-args-w-values
(when (boundp lang-headers) (eval lang-headers t))))
(header-arg (or header-arg
(completing-read
"Header Arg: "
(mapcar
(lambda (header-spec) (symbol-name (car header-spec)))
headers))))
(vals (cdr (assoc (intern header-arg) headers)))
(value (or value
(cond
((eq vals :any)
(read-from-minibuffer "value: "))
((listp vals)
(mapconcat
(lambda (group)
(let ((arg (completing-read
"Value: "
(cons "default"
(mapcar #'symbol-name group)))))
(if (and arg (not (string= "default" arg)))
(concat arg " ")
"")))
vals ""))))))
(save-excursion
(goto-char begin)
(goto-char (line-end-position))
(unless (= (char-before (point)) ?\ ) (insert " "))
(insert ":" header-arg) (when value (insert " " value)))))
;; Add support for completing-read insertion of header arguments after ":"
(defun org-babel-header-arg-expand ()
"Call `org-babel-enter-header-arg-w-completion' in appropriate contexts."
(when (and (equal (char-before) ?\:) (org-babel-where-is-src-block-head))
(org-babel-enter-header-arg-w-completion (match-string 2))))
(defun org-babel-enter-header-arg-w-completion (&optional lang)
"Insert header argument appropriate for LANG with completion."
(let* ((lang-headers-var (intern (concat "org-babel-header-args:" lang)))
(lang-headers (when (boundp lang-headers-var) (eval lang-headers-var t)))
(headers-w-values (org-babel-combine-header-arg-lists
org-babel-common-header-args-w-values lang-headers))
(headers (mapcar #'symbol-name (mapcar #'car headers-w-values)))
(header (org-completing-read "Header Arg: " headers))
(args (cdr (assoc (intern header) headers-w-values)))
(arg (when (and args (listp args))
(org-completing-read
(format "%s: " header)
(mapcar #'symbol-name (apply #'append args))))))
(insert (concat header " " (or arg "")))
(cons header arg)))
(add-hook 'org-cycle-tab-first-hook 'org-babel-header-arg-expand)
;;;###autoload
(defun org-babel-load-in-session (&optional _arg info)
"Load the body of the current source-code block.
When optional argument INFO is non-nil, use source block defined in
INFO, as returned by `org-babel-get-src-block-info'.
Evaluate the header arguments for the source block before
entering the session. After loading the body this pops open the
session."
(interactive)
(let* ((info (or info (org-babel-get-src-block-info)))
(lang (nth 0 info))
(params (nth 2 info))
(body (if (not info)
(user-error "No src code block at point")
(setf (nth 1 info)
(if (org-babel-noweb-p params :eval)
(org-babel-expand-noweb-references info)
(nth 1 info)))))
(session (cdr (assq :session params)))
(dir (cdr (assq :dir params)))
(default-directory
(or (and dir (file-name-as-directory dir)) default-directory))
(cmd (intern (concat "org-babel-load-session:" lang))))
(unless (fboundp cmd)
(error "No org-babel-load-session function for %s!" lang))
(pop-to-buffer (funcall cmd session body params))
(end-of-line 1)))
;;;###autoload
(defun org-babel-initiate-session (&optional arg info)
"Initiate session for current code block or the block defined by INFO.
If called with a prefix argument ARG, then resolve any variable
references in the header arguments and assign these variables in
the session. Copy the body of the code block to the kill ring."
(interactive "P")
(let* ((info (or info (org-babel-get-src-block-info (not arg))))
(lang (nth 0 info))
(body (nth 1 info))
(params (nth 2 info))
(session (cdr (assq :session params)))
(dir (cdr (assq :dir params)))
(default-directory
(or (and dir (file-name-as-directory dir)) default-directory))
(init-cmd (intern (format "org-babel-%s-initiate-session" lang)))
(prep-cmd (intern (concat "org-babel-prep-session:" lang))))
(when (and (stringp session) (string= session "none"))
(error "This block is not using a session!"))
(unless (fboundp init-cmd)
(error "No org-babel-initiate-session function for %s!" lang))
(with-temp-buffer (insert (org-trim body))
(copy-region-as-kill (point-min) (point-max)))
(when arg
(unless (fboundp prep-cmd)
(error "No org-babel-prep-session function for %s!" lang))
(funcall prep-cmd session params))
(funcall init-cmd session params)))
;;;###autoload
(defun org-babel-switch-to-session (&optional arg info)
"Switch to the session of the current code block or block defined by INFO.
Uses `org-babel-initiate-session' to start the session. If called
with a prefix argument ARG, then this is passed on to
`org-babel-initiate-session'."
(interactive "P")
(pop-to-buffer (org-babel-initiate-session arg info))
(end-of-line 1))
(defalias 'org-babel-pop-to-session 'org-babel-switch-to-session)
(defvar org-src-window-setup)
;;;###autoload
(defun org-babel-switch-to-session-with-code (&optional arg _info)
"Switch to code buffer and display session.
Prefix argument ARG is passed to `org-babel-switch-to-session'."
(interactive "P")
(let ((swap-windows
(lambda ()
(let ((other-window-buffer (window-buffer (next-window))))
(set-window-buffer (next-window) (current-buffer))
(set-window-buffer (selected-window) other-window-buffer))
(other-window 1)))
(info (org-babel-get-src-block-info))
(org-src-window-setup 'reorganize-frame))
(save-excursion
(org-babel-switch-to-session arg info))
(org-edit-src-code)
(funcall swap-windows)))
;;;###autoload
(defmacro org-babel-do-in-edit-buffer (&rest body)
"Evaluate BODY in edit buffer if there is a code block at point.
Return t if a code block was found at point, nil otherwise."
(declare (debug (body)))
`(let* ((element (org-element-at-point))
;; This function is not supposed to move point. However,
;; `org-edit-src-code' always moves point back into the
;; source block. It is problematic if the point was before
;; the code, e.g., on block's opening line. In this case,
;; we want to restore this location after executing BODY.
(outside-position
(and (<= (line-beginning-position)
(org-element-post-affiliated element))
(point-marker)))
(org-src-window-setup 'switch-invisibly))
(when (and (org-babel-where-is-src-block-head element)
(condition-case nil
(org-edit-src-code)
(t
(org-edit-src-exit)
(when outside-position (goto-char outside-position))
nil)))
(unwind-protect (progn ,@body)
(org-edit-src-exit)
(when outside-position (goto-char outside-position)))
t)))
(defun org-babel-do-key-sequence-in-edit-buffer (key)
"Read key sequence KEY and execute the command in edit buffer.
Enter a key sequence to be executed in the language major-mode
edit buffer. For example, TAB will alter the contents of the
Org code block according to the effect of TAB in the language
major mode buffer. For languages that support interactive
sessions, this can be used to send code from the Org buffer
to the session for evaluation using the native major mode
evaluation mechanisms."
(interactive "kEnter key-sequence to execute in edit buffer: ")
(org-babel-do-in-edit-buffer
(call-interactively
(key-binding (or key (read-key-sequence nil))))))
(defvar org-link-bracket-re)
(defun org-babel-active-location-p ()
"Return non-nil, when at executable element."
(org-element-type-p
(save-match-data (org-element-context))
'(babel-call inline-babel-call inline-src-block src-block)))
;;;###autoload
(defun org-babel-open-src-block-result (&optional re-run)
"Open results of source block at point.
If `point' is on a source block then open the results of the source
code block, otherwise return nil. With optional prefix argument
RE-RUN the source-code block is evaluated even if results already
exist."
(interactive "P")
(pcase (org-babel-get-src-block-info 'no-eval)
(`(,_ ,_ ,arguments ,_ ,_ ,start ,_)
(save-excursion
;; Go to the results, if there aren't any then run the block.
(goto-char start)
(goto-char (or (and (not re-run) (org-babel-where-is-src-block-result))
(progn (org-babel-execute-src-block)
(org-babel-where-is-src-block-result))))
(end-of-line)
(skip-chars-forward " \r\t\n")
;; Open the results.
(if (looking-at org-link-bracket-re) (org-open-at-point)
(let ((r (org-babel-format-result (org-babel-read-result)
(cdr (assq :sep arguments)))))
(pop-to-buffer (get-buffer-create "*Org Babel Results*"))
(erase-buffer)
(insert r)))
t))
(_ nil)))
;;;###autoload
(defmacro org-babel-map-src-blocks (file &rest body)
"Evaluate BODY forms on each source-block in FILE.
If FILE is nil evaluate BODY forms on source blocks in current
buffer. During evaluation of BODY the following local variables
are set relative to the currently matched code block.
full-block ------- string holding the entirety of the code block
beg-block -------- point at the beginning of the code block
end-block -------- point at the end of the matched code block
lang ------------- string holding the language of the code block
beg-lang --------- point at the beginning of the lang
end-lang --------- point at the end of the lang
switches --------- string holding the switches
beg-switches ----- point at the beginning of the switches
end-switches ----- point at the end of the switches
header-args ------ string holding the header-args
beg-header-args -- point at the beginning of the header-args
end-header-args -- point at the end of the header-args
body ------------- string holding the body of the code block
beg-body --------- point at the beginning of the body
end-body --------- point at the end of the body"
(declare (indent 1) (debug t))
(let ((tempvar (make-symbol "file")))
`(let* ((case-fold-search t)
(,tempvar ,file)
(visited-p (or (null ,tempvar)
(get-file-buffer (expand-file-name ,tempvar))))
(point (point)) to-be-removed)
(save-window-excursion
(when ,tempvar (find-file ,tempvar))
(setq to-be-removed (current-buffer))
(goto-char (point-min))
(while (re-search-forward org-babel-src-block-regexp nil t)
(when (org-babel-active-location-p)
(goto-char (match-beginning 0))
(let ((full-block (match-string 0))
(beg-block (match-beginning 0))
(end-block (match-end 0))
(lang (match-string 2))
(beg-lang (match-beginning 2))
(end-lang (match-end 2))
(switches (match-string 3))
(beg-switches (match-beginning 3))
(end-switches (match-end 3))
(header-args (match-string 4))
(beg-header-args (match-beginning 4))
(end-header-args (match-end 4))
(body (match-string 5))
(beg-body (match-beginning 5))
(end-body (match-end 5)))
;; Silence byte-compiler in case `body' doesn't use all
;; those variables.
(ignore full-block beg-block end-block lang
beg-lang end-lang switches beg-switches
end-switches header-args beg-header-args
end-header-args body beg-body end-body)
,@body
(goto-char end-block)))))
(unless visited-p (kill-buffer to-be-removed))
(goto-char point))))
;;;###autoload
(defmacro org-babel-map-inline-src-blocks (file &rest body)
"Evaluate BODY forms on each inline source block in FILE.
If FILE is nil evaluate BODY forms on source blocks in current
buffer."
(declare (indent 1) (debug (form body)))
(org-with-gensyms (datum end point tempvar to-be-removed visitedp)
`(let* ((case-fold-search t)
(,tempvar ,file)
(,visitedp (or (null ,tempvar)
(get-file-buffer (expand-file-name ,tempvar))))
(,point (point))
,to-be-removed)
(save-window-excursion
(when ,tempvar (find-file ,tempvar))
(setq ,to-be-removed (current-buffer))
(goto-char (point-min))
(while (re-search-forward "src_\\S-" nil t)
(let ((,datum (org-element-context)))
(when (org-element-type-p ,datum 'inline-src-block)
(goto-char (org-element-begin ,datum))
(let ((,end (copy-marker (org-element-end ,datum))))
,@body
(goto-char ,end)
(set-marker ,end nil))))))
(unless ,visitedp (kill-buffer ,to-be-removed))
(goto-char ,point))))
;;;###autoload
(defmacro org-babel-map-call-lines (file &rest body)
"Evaluate BODY forms on each call line in FILE.
If FILE is nil evaluate BODY forms on source blocks in current
buffer."
(declare (indent 1) (debug (form body)))
(org-with-gensyms (datum end point tempvar to-be-removed visitedp)
`(let* ((case-fold-search t)
(,tempvar ,file)
(,visitedp (or (null ,tempvar)
(get-file-buffer (expand-file-name ,tempvar))))
(,point (point))
,to-be-removed)
(save-window-excursion
(when ,tempvar (find-file ,tempvar))
(setq ,to-be-removed (current-buffer))
(goto-char (point-min))
(while (re-search-forward "call_\\S-\\|^[ \t]*#\\+CALL:" nil t)
(let ((,datum (org-element-context)))
(when (org-element-type-p ,datum '(babel-call inline-babel-call))
(goto-char (or (org-element-post-affiliated datum)
(org-element-begin datum)))
(let ((,end (copy-marker (org-element-end ,datum))))
,@body
(goto-char ,end)
(set-marker ,end nil))))))
(unless ,visitedp (kill-buffer ,to-be-removed))
(goto-char ,point))))
;;;###autoload
(defmacro org-babel-map-executables (file &rest body)
"Evaluate BODY forms on each active Babel code in FILE.
If FILE is nil evaluate BODY forms on source blocks in current
buffer."
(declare (indent 1) (debug (form body)))
(org-with-gensyms (datum end point tempvar to-be-removed visitedp)
`(let* ((case-fold-search t)
(,tempvar ,file)
(,visitedp (or (null ,tempvar)
(get-file-buffer (expand-file-name ,tempvar))))
(,point (point))
,to-be-removed)
(save-window-excursion
(when ,tempvar (find-file ,tempvar))
(setq ,to-be-removed (current-buffer))
(goto-char (point-min))
(while (re-search-forward
"\\(call\\|src\\)_\\|^[ \t]*#\\+\\(BEGIN_SRC\\|CALL:\\)" nil t)
(let ((,datum (org-element-context)))
(when (org-element-type-p
,datum
'(babel-call inline-babel-call inline-src-block src-block))
(goto-char (or (org-element-post-affiliated ,datum)
(org-element-begin ,datum)))
(let ((,end (copy-marker (org-element-end ,datum))))
,@body
(goto-char ,end)
(set-marker ,end nil))))))
(unless ,visitedp (kill-buffer ,to-be-removed))
(goto-char ,point))))
;;;###autoload
(defun org-babel-execute-buffer (&optional arg)
"Execute source code blocks in a buffer.
Prefix argument ARG is passed to `org-babel-execute-src-block'.
Call `org-babel-execute-src-block' on every source block in
the current buffer."
(interactive "P")
(org-babel-eval-wipe-error-buffer)
(org-save-outline-visibility t
(org-babel-map-executables nil
(if (org-element-type-p
(org-element-context) '(babel-call inline-babel-call))
(org-babel-lob-execute-maybe)
(org-babel-execute-src-block arg)))))
;;;###autoload
(defun org-babel-execute-subtree (&optional arg)
"Execute source code blocks in a subtree.
Call `org-babel-execute-src-block' on every source block in
the current subtree, passing over the prefix argument ARG."
(interactive "P")
(save-restriction
(save-excursion
(org-narrow-to-subtree)
(org-babel-execute-buffer arg)
(widen))))
;;;###autoload
(defun org-babel-sha1-hash (&optional info context)
"Generate a sha1 hash based on the value of INFO.
CONTEXT specifies the context of evaluation. It can be `:eval',
`:export', `:tangle'. A nil value means `:eval'."
(interactive)
(let ((print-level nil)
(info (or info (org-babel-get-src-block-info)))
(context (or context :eval)))
(setf (nth 2 info)
(sort (copy-sequence (nth 2 info))
(lambda (a b) (string< (car a) (car b)))))
(let* ((rm (lambda (lst)
(dolist (p '("replace" "silent" "none"
"discard" "append" "prepend"))
(setq lst (remove p lst)))
lst))
(norm (lambda (arg)
(let ((v (if (and (listp (cdr arg)) (null (cddr arg)))
(copy-sequence (cdr arg))
(cdr arg))))
(when (and v (not (and (sequencep v)
(not (consp v))
(= (length v) 0))))
(cond
((and (listp v) ; lists are sorted
(member (car arg) '(:result-params)))
(sort (funcall rm v) #'string<))
((and (stringp v) ; strings are sorted
(member (car arg) '(:results :exports)))
(mapconcat #'identity (sort (funcall rm (split-string v))
#'string<) " "))
(t v))))))
;; expanded body
(lang (nth 0 info))
(params (nth 2 info))
(body (if (org-babel-noweb-p params context)
(org-babel-expand-noweb-references info)
(nth 1 info)))
(expand-cmd (intern (concat "org-babel-expand-body:" lang)))
(assignments-cmd (intern (concat "org-babel-variable-assignments:"
lang)))
(expanded
(if (fboundp expand-cmd) (funcall expand-cmd body params)
(org-babel-expand-body:generic
body params (and (fboundp assignments-cmd)
(funcall assignments-cmd params))))))
(let* ((it (format "%s-%s"
(mapconcat
#'identity
(delq nil (mapcar (lambda (arg)
(let ((normalized (funcall norm arg)))
(when normalized
(format "%S" normalized))))
(nth 2 info))) ":")
expanded))
(hash (sha1 it)))
(when (called-interactively-p 'interactive) (message hash))
hash))))
(defun org-babel-current-result-hash (&optional _info)
"Return the current in-buffer hash."
(let ((result (org-babel-where-is-src-block-result nil)))
(when result
(org-with-point-at result
(let ((case-fold-search t)) (looking-at org-babel-result-regexp))
(match-string-no-properties 1)))))
(defun org-babel-hide-hash ()
"Hide the hash in the current results line.
Only the initial `org-babel-hash-show' characters of the hash
will remain visible."
(add-to-invisibility-spec '(org-babel-hide-hash . t))
(save-excursion
(when (and (let ((case-fold-search t))
(re-search-forward org-babel-result-regexp nil t))
(match-string 1))
(let* ((start (match-beginning 1))
(hide-start (+ org-babel-hash-show start))
(end (match-end 1))
(hash (match-string 1))
ov1 ov2)
(setq ov1 (make-overlay start hide-start))
(setq ov2 (make-overlay hide-start end))
(overlay-put ov2 'invisible 'org-babel-hide-hash)
(overlay-put ov1 'babel-hash hash)))))
(defun org-babel-hide-all-hashes ()
"Hide the hash in the current buffer.
Only the initial `org-babel-hash-show' characters of each hash
will remain visible. This function should be called as part of
the `org-mode-hook'."
(save-excursion
(let ((case-fold-search t))
(while (and (not org-babel-hash-show-time)
(re-search-forward org-babel-result-regexp nil t))
(goto-char (match-beginning 0))
(org-babel-hide-hash)
(goto-char (match-end 0))))))
(add-hook 'org-mode-hook #'org-babel-hide-all-hashes)
(defun org-babel-hash-at-point (&optional point)
"Return the value of the hash at POINT.
\\\
The hash is also added as the last element of the kill ring.
This can be called with `\\[org-ctrl-c-ctrl-c]'."
(interactive)
(let ((hash (car (delq nil (mapcar
(lambda (ol) (overlay-get ol 'babel-hash))
(overlays-at (or point (point))))))))
(when hash (kill-new hash) (message hash))))
(defun org-babel-result-hide-spec ()
"Hide portions of results lines.
Add `org-babel-hide-result' as an invisibility spec for hiding
portions of results lines."
(add-to-invisibility-spec '(org-babel-hide-result . t)))
(add-hook 'org-mode-hook #'org-babel-result-hide-spec)
(defvar org-babel-hide-result-overlays nil
"Overlays hiding results.")
(defun org-babel-result-hide-all ()
"Fold all results in the current buffer."
(interactive)
(org-babel-show-result-all)
(save-excursion
(let ((case-fold-search t))
(while (re-search-forward org-babel-result-regexp nil t)
(save-excursion (goto-char (match-beginning 0))
(org-babel-hide-result-toggle-maybe))))))
(defun org-babel-show-result-all ()
"Unfold all results in the current buffer."
(mapc 'delete-overlay org-babel-hide-result-overlays)
(setq org-babel-hide-result-overlays nil))
;;;###autoload
(defun org-babel-hide-result-toggle-maybe ()
"Toggle visibility of result at point."
(interactive)
(let ((case-fold-search t))
(and (org-match-line org-babel-result-regexp)
(progn (org-babel-hide-result-toggle) t))))
(defun org-babel-hide-result-toggle (&optional force)
"Toggle the visibility of the current result.
When FORCE is symbol `off', unconditionally display the result.
Otherwise, when FORCE is non-nil, unconditionally hide the result."
(interactive)
(save-excursion
(forward-line 0)
(let ((case-fold-search t))
(unless (re-search-forward org-babel-result-regexp nil t)
(error "Not looking at a result line")))
(let ((start (progn (forward-line 1) (1- (point))))
(end (progn
(while (looking-at org-babel-multi-line-header-regexp)
(forward-line 1))
(goto-char (1- (org-babel-result-end)))
(point)))
ov)
(if (memq t (mapcar (lambda (overlay)
(eq (overlay-get overlay 'invisible)
'org-babel-hide-result))
(overlays-at start)))
(when (or (not force) (eq force 'off))
(mapc (lambda (ov)
(when (member ov org-babel-hide-result-overlays)
(setq org-babel-hide-result-overlays
(delq ov org-babel-hide-result-overlays)))
(when (eq (overlay-get ov 'invisible)
'org-babel-hide-result)
(delete-overlay ov)))
(overlays-at start)))
(setq ov (make-overlay start end))
(overlay-put ov 'invisible 'org-babel-hide-result)
;; make the block accessible to isearch
(overlay-put
ov 'isearch-open-invisible
(lambda (ov)
(when (member ov org-babel-hide-result-overlays)
(setq org-babel-hide-result-overlays
(delq ov org-babel-hide-result-overlays)))
(when (eq (overlay-get ov 'invisible)
'org-babel-hide-result)
(delete-overlay ov))))
(push ov org-babel-hide-result-overlays)))))
;; org-tab-after-check-for-cycling-hook
(add-hook 'org-cycle-tab-first-hook #'org-babel-hide-result-toggle-maybe)
;; Remove overlays when changing major mode
(add-hook 'org-mode-hook
(lambda () (add-hook 'change-major-mode-hook
#'org-babel-show-result-all 'append 'local)))
(defun org-babel-params-from-properties (&optional lang no-eval)
"Retrieve source block parameters specified as properties.
LANG is the language of the source block, as a string. When
optional argument NO-EVAL is non-nil, do not evaluate Lisp values
in parameters.
Return a list of association lists of source block parameters
specified in the properties of the current outline entry."
(save-match-data
(list
;; Header arguments specified with the header-args property at
;; point of call.
(org-babel-parse-header-arguments
(org-entry-get (point) "header-args" 'inherit)
no-eval)
;; Language-specific header arguments at point of call.
(and lang
(org-babel-parse-header-arguments
(org-entry-get (point) (concat "header-args:" lang) 'inherit)
no-eval)))))
(defun org-babel-balanced-split (string alts)
"Split STRING on instances of ALTS.
ALTS is a character, or cons of two character options where each
option may be either the numeric code of a single character or
a list of character alternatives. For example, to split on
balanced instances of \"[ \t]:\", set ALTS to ((32 9) . 58)."
(with-temp-buffer
(insert string)
(goto-char (point-min))
(let ((splitp (lambda (past next)
;; Non-nil when there should be a split after NEXT
;; character. PAST is the character before NEXT.
(pcase alts
(`(,(and first (pred consp)) . ,(and second (pred consp)))
(and (memq past first) (memq next second)))
(`(,first . ,(and second (pred consp)))
(and (eq past first) (memq next second)))
(`(,(and first (pred consp)) . ,second)
(and (memq past first) (eq next second)))
(`(,first . ,second)
(and (eq past first) (eq next second)))
((pred (eq next)) t)
(_ nil))))
(partial nil)
(result nil))
(while (not (eobp))
(cond
((funcall splitp (char-before) (char-after))
;; There is a split after point. If ALTS is two-folds,
;; remove last parsed character as it belongs to ALTS.
(when (consp alts) (pop partial))
;; Include elements parsed so far in RESULTS and flush
;; partial parsing.
(when partial
(push (apply #'string (nreverse partial)) result)
(setq partial nil))
(forward-char))
((memq (char-after) '(?\( ?\[))
;; Include everything between balanced brackets.
(let* ((origin (point))
(after (char-after))
(openings (list after)))
(forward-char)
(while (and openings (re-search-forward "[]()]" nil t))
(pcase (char-before)
((and match (or ?\[ ?\()) (push match openings))
(?\] (when (eq ?\[ (car openings)) (pop openings)))
(_ (when (eq ?\( (car openings)) (pop openings)))))
(if (null openings)
(setq partial
(nconc (nreverse (string-to-list
(buffer-substring origin (point))))
partial))
;; Un-balanced bracket. Backtrack.
(push after partial)
(goto-char (1+ origin)))))
((and (eq ?\" (char-after)) (not (eq ?\\ (char-before))))
;; Include everything from current double quote to next
;; non-escaped double quote.
(let ((origin (point)))
(if (re-search-forward "[^\\]\"" nil t)
(setq partial
(nconc (nreverse (string-to-list
(buffer-substring origin (point))))
partial))
;; No closing double quote. Backtrack.
(push ?\" partial)
(forward-char))))
(t (push (char-after) partial)
(forward-char))))
;; Add pending parsing and return result.
(when partial (push (apply #'string (nreverse partial)) result))
(nreverse result))))
(defun org-babel-join-splits-near-ch (ch list)
"Join strings in LIST where CH is on either end of the strings.
This function will join list elements like \"a=\" \"2\" into \"a=2\"."
(let ((last= (lambda (str) (= ch (aref str (1- (length str))))))
(first= (lambda (str) (= ch (aref str 0)))))
(reverse
(cl-reduce (lambda (acc el)
(let ((head (car acc)))
(if (and head (or (funcall last= head) (funcall first= el)))
(cons (concat head el) (cdr acc))
(cons el acc))))
list :initial-value nil))))
(defun org-babel-parse-header-arguments (string &optional no-eval)
"Parse header arguments in STRING.
When optional argument NO-EVAL is non-nil, do not evaluate Lisp
in parameters. Return an alist."
(when (org-string-nw-p string)
(org-babel-parse-multiple-vars
(delq nil
(mapcar
(lambda (arg)
(if (string-match
"\\([^ \f\t\n\r\v]+\\)[ \f\t\n\r\v]+\\([^ \f\t\n\r\v]+.*\\)"
arg)
(cons (intern (match-string 1 arg))
(org-babel-read (org-babel-chomp (match-string 2 arg))
no-eval))
(cons (intern (org-babel-chomp arg)) nil)))
(let ((raw (org-babel-balanced-split string '((32 9) . 58))))
(cons (car raw)
(mapcar (lambda (r) (concat ":" r)) (cdr raw)))))))))
(defun org-babel-parse-multiple-vars (header-arguments)
"Expand multiple variable assignments behind a single :var keyword.
This allows expression of multiple variables with one :var as
shown below.
#+PROPERTY: var foo=1, bar=2
HEADER-ARGUMENTS is an alist of all the arguments."
(let (results)
(mapc (lambda (pair)
(if (eq (car pair) :var)
(or
(mapcar (lambda (v) (push (cons :var (org-trim v)) results))
(org-babel-join-splits-near-ch
61 (org-babel-balanced-split (or (cdr pair) "") 32)))
(push `(:var) results))
(push pair results)))
header-arguments)
(nreverse results)))
(defun org-babel-process-params (params)
"Expand variables in PARAMS and add summary parameters."
(let* ((processed-vars (mapcar (lambda (el)
(if (consp el)
el
(org-babel-ref-parse el)))
(org-babel--get-vars params)))
(vars-and-names (if (and (assq :colname-names params)
(assq :rowname-names params))
(list processed-vars)
(org-babel-disassemble-tables
processed-vars
(cdr (assq :hlines params))
(cdr (assq :colnames params))
(cdr (assq :rownames params)))))
(raw-result (or (cdr (assq :results params)) ""))
(result-params (delete-dups
(append
(split-string (if (stringp raw-result)
raw-result
;; FIXME: Arbitrary code evaluation.
(eval raw-result t)))
(cdr (assq :result-params params))))))
(append
(mapcar (lambda (var) (cons :var var)) (car vars-and-names))
(list
(cons :colname-names (or (cdr (assq :colname-names params))
(cadr vars-and-names)))
(cons :rowname-names (or (cdr (assq :rowname-names params))
(cl-caddr vars-and-names)))
(cons :result-params result-params)
(cons :result-type (cond ((member "output" result-params) 'output)
((member "value" result-params) 'value)
(t 'value))))
(cl-remove-if
(lambda (x) (memq (car x) '(:colname-names :rowname-names :result-params
:result-type :var)))
params))))
;; row and column names
(defun org-babel-del-hlines (table)
"Remove all `hline's from TABLE."
(remq 'hline table))
(defun org-babel-get-colnames (table)
"Return the column names of TABLE.
Return a cons cell, the `car' of which contains the TABLE less
colnames, and the `cdr' of which contains a list of the column
names."
;; Skip over leading hlines.
(while (eq 'hline (car table)) (pop table))
(if (eq 'hline (nth 1 table))
(cons (cddr table) (car table))
(cons (cdr table) (car table))))
(defun org-babel-get-rownames (table)
"Return the row names of TABLE.
Return a cons cell, the `car' of which contains the TABLE less
rownames, and the `cdr' of which contains a list of the rownames.
Note: this function removes any hlines in TABLE."
(let* ((table (org-babel-del-hlines table))
(rownames (funcall (lambda ()
(let ((tp table))
(mapcar
(lambda (_row)
(prog1
(pop (car tp))
(setq tp (cdr tp))))
table))))))
(cons table rownames)))
(defun org-babel-put-colnames (table colnames)
"Add COLNAMES to TABLE if they exist."
(if colnames (apply 'list colnames 'hline table) table))
(defun org-babel-put-rownames (table rownames)
"Add ROWNAMES to TABLE if they exist."
(if rownames
(mapcar (lambda (row)
(if (listp row)
(cons (or (pop rownames) "") row)
row))
table)
table))
(defun org-babel-pick-name (names selector)
"Select one out of an alist of row or column names.
SELECTOR can be either a list of names in which case those names
will be returned directly, or an index into the list NAMES in
which case the indexed names will be return."
(if (listp selector)
selector
(when names
(if (and selector (symbolp selector) (not (equal t selector)))
(cdr (assoc selector names))
(if (integerp selector)
(nth (- selector 1) names)
(cdr (car (last names))))))))
(defun org-babel-disassemble-tables (vars hlines colnames rownames)
"Parse tables for further processing.
Process the variables in VARS according to the HLINES,
ROWNAMES and COLNAMES header arguments. Return a list consisting
of the vars, cnames and rnames."
(let (cnames rnames)
(list
(mapcar
(lambda (var)
(when (proper-list-p (cdr var))
(when (and (not (equal colnames "no"))
;; Compatibility note: avoid `length>', which
;; isn't available until Emacs 28.
(or colnames
;; :colnames nil (default)
;; Auto-assign column names when the table
;; has hline as the second line after
;; non-hline row.
(and (> (length (cdr var)) 1)
(not (eq (car (cdr var)) 'hline)) ; first row
(eq (nth 1 (cdr var)) 'hline) ; second row
(not (member 'hline (cddr (cdr var)))) ; other rows
)))
(let ((both (org-babel-get-colnames (cdr var))))
(setq cnames (cons (cons (car var) (cdr both))
cnames))
(setq var (cons (car var) (car both)))))
(when (and rownames (not (equal rownames "no")))
(let ((both (org-babel-get-rownames (cdr var))))
(setq rnames (cons (cons (car var) (cdr both))
rnames))
(setq var (cons (car var) (car both)))))
(when (and hlines (not (equal hlines "yes")))
(setq var (cons (car var) (org-babel-del-hlines (cdr var))))))
var)
vars)
(reverse cnames) (reverse rnames))))
(defun org-babel-reassemble-table (table colnames rownames)
"Add column and row names to a table.
Given a TABLE and set of COLNAMES and ROWNAMES add the names
to the table for reinsertion to `org-mode'."
(if (listp table)
(let ((table (if (and rownames (= (length table) (length rownames)))
(org-babel-put-rownames table rownames) table)))
(if (and colnames (listp (car table)) (= (length (car table))
(length colnames)))
(org-babel-put-colnames table colnames) table))
table))
(defun org-babel-where-is-src-block-head (&optional src-block)
"Find where the current source block begins.
If optional argument SRC-BLOCK is `src-block' type element, find
its current beginning instead.
Return the point at the beginning of the current source block.
Specifically at the beginning of the #+BEGIN_SRC line. Also set
`match-data' relatively to `org-babel-src-block-regexp', which see.
If the point is not on a source block or within blank lines after an
src block, then return nil."
(let ((element (or src-block (org-element-at-point))))
(when (org-element-type-p element 'src-block)
(let ((end (org-element-end element)))
(org-with-wide-buffer
;; Ensure point is not on a blank line after the block.
(forward-line 0)
(skip-chars-forward " \r\t\n" end)
(when (< (point) end)
(prog1 (goto-char (org-element-post-affiliated element))
(looking-at org-babel-src-block-regexp))))))))
;;;###autoload
(defun org-babel-goto-src-block-head ()
"Go to the beginning of the current code block."
(interactive)
(let ((head (org-babel-where-is-src-block-head)))
(if head (goto-char head) (error "Not currently in a code block"))))
;;;###autoload
(defun org-babel-goto-named-src-block (name)
"Go to a source-code block with NAME."
(interactive
(let ((completion-ignore-case t)
(case-fold-search t)
(all-block-names (org-babel-src-block-names)))
(list (completing-read
"source-block name: " all-block-names nil t
(let* ((context (org-element-context))
(type (org-element-type context))
(noweb-ref
(and (memq type '(inline-src-block src-block))
(org-in-regexp (org-babel-noweb-wrap)))))
(cond
(noweb-ref
(buffer-substring
(+ (car noweb-ref) (length org-babel-noweb-wrap-start))
(- (cdr noweb-ref) (length org-babel-noweb-wrap-end))))
((memq type '(babel-call inline-babel-call)) ;#+CALL:
(org-element-property :call context))
((car (org-element-property :results context))) ;#+RESULTS:
((let ((symbol (thing-at-point 'symbol))) ;Symbol.
(and symbol
(member-ignore-case symbol all-block-names)
symbol)))
(t "")))))))
(let ((point (org-babel-find-named-block name)))
(if point
;; Taken from `org-open-at-point'.
(progn (org-mark-ring-push) (goto-char point) (org-fold-show-context))
(message "source-code block `%s' not found in this buffer" name))))
(defun org-babel-find-named-block (name)
"Find a named source-code block.
Return the location of the source block identified by source
NAME, or nil if no such block exists. Set match data according
to `org-babel-named-src-block-regexp'."
(save-excursion
(goto-char (point-min))
(let ((regexp (org-babel-named-src-block-regexp-for-name name)))
(or (and (looking-at regexp)
(progn (goto-char (match-beginning 1))
(line-beginning-position)))
(ignore-errors (org-next-block 1 nil regexp))))))
(defun org-babel-src-block-names (&optional file)
"Return the names of source blocks in FILE or the current buffer."
(with-current-buffer (if file (find-file-noselect file) (current-buffer))
(org-with-point-at 1
(let ((regexp "^[ \t]*#\\+begin_src ")
(case-fold-search t)
(names nil))
(while (re-search-forward regexp nil t)
(let ((element (org-element-at-point)))
(when (org-element-type-p element 'src-block)
(let ((name (org-element-property :name element)))
(when name (push name names))))))
names))))
;;;###autoload
(defun org-babel-goto-named-result (name)
"Go to a result with NAME."
(interactive
(let ((completion-ignore-case t))
(list (completing-read "Source-block name: "
(org-babel-result-names) nil t))))
(let ((point (org-babel-find-named-result name)))
(if point
;; taken from `org-open-at-point'
(progn (goto-char point) (org-fold-show-context))
(message "result `%s' not found in this buffer" name))))
(defun org-babel-find-named-result (name)
"Find a named result.
Return the location of the result named NAME in the current
buffer or nil if no such result exists."
(save-excursion
(goto-char (point-min))
(let ((case-fold-search t)
(re (format "^[ \t]*#\\+%s.*?:[ \t]*%s[ \t]*$"
org-babel-results-keyword
(regexp-quote name))))
(catch :found
(while (re-search-forward re nil t)
(let ((element (org-element-at-point)))
(when (or (org-element-type-p element 'keyword)
(< (point)
(org-element-post-affiliated element)))
(throw :found (line-beginning-position)))))))))
(defun org-babel-result-names (&optional file)
"Return the names of results in FILE or the current buffer."
(with-current-buffer (if file (find-file-noselect file) (current-buffer))
(org-with-point-at 1
(let ((case-fold-search t) names)
(while (re-search-forward org-babel-result-w-name-regexp nil t)
(setq names (cons (match-string-no-properties 9) names)))
names))))
;;;###autoload
(defun org-babel-next-src-block (&optional arg)
"Jump to the next source block.
With optional prefix argument ARG, jump forward ARG many source blocks."
(interactive "p")
(org-next-block arg nil org-babel-src-block-regexp))
;;;###autoload
(defun org-babel-previous-src-block (&optional arg)
"Jump to the previous source block.
With optional prefix argument ARG, jump backward ARG many source blocks."
(interactive "p")
(org-previous-block arg org-babel-src-block-regexp))
(defvar org-babel-load-languages)
;;;###autoload
(defun org-babel-mark-block ()
"Mark current source block."
(interactive)
(let ((head (org-babel-where-is-src-block-head)))
(when head
(save-excursion
(goto-char head)
(looking-at org-babel-src-block-regexp))
(push-mark (match-end 5) nil t)
(goto-char (match-beginning 5)))))
(defun org-babel-demarcate-block (&optional arg)
"Wrap or split the code in an active region or at point.
With prefix argument ARG, also create a new heading at point.
When called from inside of a code block the current block is
split. When called from outside of a code block a new code block
is created. In both cases if the region is demarcated and if the
region is not active then the point is demarcated.
When called within blank lines after a code block, create a new code
block of the same language as the previous."
(interactive "P")
(let* ((info (org-babel-get-src-block-info 'no-eval))
(start (org-babel-where-is-src-block-head))
;; `start' will be nil when within space lines after src block.
(block (and start (match-string 0)))
(body-beg (and start (match-beginning 5)))
(body-end (and start (match-end 5)))
(stars (concat (make-string (or (org-current-level) 1) ?*) " "))
(upper-case-p (and block
(let (case-fold-search)
(string-match-p "#\\+BEGIN_SRC" block)))))
(if (and info start) ;; At src block, but not within blank lines after it.
(let* ((copy (org-element-copy (org-element-at-point)))
(before (org-element-begin copy))
(beyond (org-element-end copy))
(parts
(if (org-region-active-p)
(list body-beg (region-beginning) (region-end) body-end)
(list body-beg (point) body-end)))
(pads ;; To calculate left-side white-space padding.
(if (org-region-active-p)
(list (region-beginning) (region-end))
(list (point))))
(n (- (length parts) 2)) ;; 1 or 2 parts in `dolist' below.
;; `post-blank' caches the property before setting it to 0.
(post-blank (org-element-property :post-blank copy)))
;; Point or region are within body when parts is in increasing order.
(unless (apply #'<= parts)
(user-error "Select within the source block body to split it"))
(setq parts (mapcar (lambda (p) (buffer-substring (car p) (cdr p)))
(seq-mapn #'cons parts (cdr parts))))
;; Map positions to columns for white-space padding.
(setq pads (mapcar (lambda (p) (save-excursion
(goto-char p)
(current-column)))
pads))
(push 0 pads) ;; The 1st part never requires white-space padding.
(setq parts (mapcar (lambda (p) (string-join
(list (make-string (car p) ?\s)
(cdr p))))
(seq-mapn #'cons pads parts)))
(delete-region before beyond)
;; Set `:post-blank' to 0. We take care of spacing between blocks.
(org-element-put-property copy :post-blank 0)
(org-element-put-property copy :value (car parts))
(insert (org-element-interpret-data copy))
;; `org-indent-block' may see another `org-element' (e.g. paragraph)
;; immediately after the block. Ensure to indent the inserted block
;; and move point to its end.
(org-babel-previous-src-block 1)
(org-indent-block)
(goto-char (org-element-end (org-element-at-point)))
(org-element-put-property copy :caption nil)
(org-element-put-property copy :name nil)
;; Insert the 2nd block, and the 3rd block when region is active.
(dolist (part (cdr parts))
(org-element-put-property copy :value part)
(insert (if arg (concat stars "\n") "\n"))
(cl-decf n)
(when (= n 0)
;; Use `post-blank' to reset the property of the last block.
(org-element-put-property copy :post-blank post-blank))
(insert (org-element-interpret-data copy))
;; Ensure to indent the inserted block and move point to its end.
(org-babel-previous-src-block 1)
(org-indent-block)
(goto-char (org-element-end (org-element-at-point))))
;; Leave point at the last inserted block.
(goto-char (org-babel-previous-src-block 1)))
(let ((start (point))
(lang (or (car info) ; Reuse language from previous block.
(completing-read
"Lang: "
(mapcar #'symbol-name
(delete-dups
(append (mapcar #'car org-babel-load-languages)
(mapcar (lambda (el) (intern (car el)))
org-src-lang-modes)))))))
(body (delete-and-extract-region
(if (org-region-active-p) (mark) (point)) (point))))
(insert (concat (if (looking-at "^") "" "\n")
(if arg (concat stars "\n") "")
(if upper-case-p "#+BEGIN_SRC " "#+begin_src ")
lang "\n" body
(if (or (= (length body) 0)
(string-suffix-p "\r" body)
(string-suffix-p "\n" body))
""
"\n")
(if upper-case-p "#+END_SRC\n" "#+end_src\n")))
(goto-char start)
(move-end-of-line 1)))))
(defun org-babel--insert-results-keyword (name hash)
"Insert RESULTS keyword with NAME value at point.
If NAME is nil, results are anonymous. HASH is a string used as
the results hash, or nil. Leave point before the keyword."
(save-excursion (insert "\n")) ;open line to indent.
(org-indent-line)
(delete-char 1)
(insert (concat "#+" org-babel-results-keyword
(cond ((not hash) nil)
(org-babel-hash-show-time
(format "[%s %s]"
(format-time-string "(%F %T)")
hash))
(t (format "[%s]" hash)))
":"
(when name (concat " " name))
"\n"))
;; Make sure results are going to be followed by at least one blank
;; line so they do not get merged with the next element, e.g.,
;;
;; #+results:
;; : 1
;;
;; : fixed-width area, unrelated to the above.
(unless (looking-at "^[ \t]*$") (save-excursion (insert "\n")))
(forward-line -1)
(when hash (org-babel-hide-hash)))
(defun org-babel--clear-results-maybe (hash)
"Clear results when hash doesn't match HASH.
When results hash does not match HASH, remove RESULTS keyword at
point, along with related contents. Do nothing if HASH is nil.
Return a non-nil value if results were cleared. In this case,
leave point where new results should be inserted."
(when hash
(let ((case-fold-search t)) (looking-at org-babel-result-regexp))
(unless (string= (match-string 1) hash)
(let* ((e (org-element-at-point))
(post (copy-marker (org-element-post-affiliated e))))
;; Delete contents.
(delete-region post
(save-excursion
(goto-char (org-element-end e))
(skip-chars-backward " \t\n")
(line-beginning-position 2)))
;; Delete RESULT keyword. However, if RESULTS keyword is
;; orphaned, ignore this part. The deletion above already
;; took care of it.
(unless (= (point) post)
(delete-region (line-beginning-position)
(line-beginning-position 2)))
(goto-char post)
(set-marker post nil)
t))))
(defun org-babel-where-is-src-block-result (&optional insert _info hash)
"Find where the current source block results begin.
Return the point at the beginning of the result of the current
source block, specifically at the beginning of the results line.
If no result exists for this block return nil, unless optional
argument INSERT is non-nil. In this case, create a results line
following the source block and return the position at its
beginning. In the case of inline code, remove the results part
instead.
If optional argument HASH is a string, remove contents related to
RESULTS keyword if its hash is different. Then update the latter
to HASH."
(let ((context (org-element-context)))
(catch :found
(org-with-wide-buffer
(pcase (org-element-type context)
((or `inline-babel-call `inline-src-block)
;; Results for inline objects are located right after them.
;; There is no RESULTS line to insert either.
(let ((limit (or (org-element-contents-end (org-element-parent context))
(org-element-end (org-element-parent context)))))
(goto-char (org-element-end context))
(skip-chars-forward " \t\n" limit)
(throw :found
(and
(< (point) limit)
(let ((result (org-element-context)))
(and (org-element-type-p result 'macro)
(string= (org-element-property :key result)
"results")
(if (not insert) (point)
(delete-region
(point)
(progn
(goto-char (org-element-end result))
(skip-chars-backward " \t")
(point)))
(point))))))))
((or `babel-call `src-block)
(let* ((name (org-element-property :name context))
(named-results (and name (org-babel-find-named-result name))))
(goto-char (or named-results (org-element-end context)))
(cond
;; Existing results named after the current source.
(named-results
(when (org-babel--clear-results-maybe hash)
(org-babel--insert-results-keyword name hash))
(throw :found (point)))
;; Named results expect but none to be found.
(name)
;; No possible anonymous results at the very end of
;; buffer or outside CONTEXT parent.
((eq (point)
(or (pcase (org-element-type (org-element-parent context))
((or `section `org-data)
(org-element-end (org-element-parent context)))
(_ (org-element-contents-end
(org-element-parent context))))
(point-max))))
;; Check if next element is an anonymous result below
;; the current block.
((let* ((next (org-element-at-point))
(end (save-excursion
(goto-char
(org-element-post-affiliated next))
(line-end-position)))
(empty-result-re (concat org-babel-result-regexp "$"))
(case-fold-search t))
(re-search-forward empty-result-re end t))
(forward-line 0)
(when (org-babel--clear-results-maybe hash)
(org-babel--insert-results-keyword nil hash))
(throw :found (point))))))
;; Ignore other elements.
(_ (throw :found nil))))
;; No result found. Insert a RESULTS keyword below element, if
;; appropriate. In this case, ensure there is an empty line
;; after the previous element.
(when insert
(save-excursion
(goto-char (min (org-element-end context) (point-max)))
(skip-chars-backward " \t\n")
(forward-line)
(unless (bolp) (insert "\n"))
(insert "\n")
(org-babel--insert-results-keyword
(org-element-property :name context) hash)
(point))))))
(defun org-babel-read-element (element)
"Read ELEMENT into emacs-lisp.
Return nil if ELEMENT cannot be read."
(org-with-wide-buffer
(goto-char (org-element-post-affiliated element))
(pcase (org-element-type element)
(`fixed-width
(let ((v (org-trim (org-element-property :value element))))
(or (org-babel--string-to-number v) v)))
(`table (org-babel-read-table))
(`plain-list (org-babel-read-list))
((or `example-block `src-block)
(let ((v (org-element-property :value element)))
(if (org-src-preserve-indentation-p element) v
(org-remove-indentation v))))
(`export-block
(org-remove-indentation (org-element-property :value element)))
(`paragraph
;; Treat paragraphs containing a single link specially.
(skip-chars-forward " \t")
(if (and (looking-at org-link-bracket-re)
(save-excursion
(goto-char (match-end 0))
(skip-chars-forward " \r\t\n")
(<= (org-element-end element)
(point))))
(org-babel-read-link)
(buffer-substring-no-properties
(org-element-contents-begin element)
(org-element-contents-end element))))
((or `center-block `quote-block `verse-block `special-block)
(org-remove-indentation
(buffer-substring-no-properties
(org-element-contents-begin element)
(org-element-contents-end element))))
(_ nil))))
(defun org-babel-read-result ()
"Read the result at point into emacs-lisp."
(and (not (save-excursion
(forward-line 0)
(looking-at-p "[ \t]*$")))
(org-babel-read-element (org-element-at-point))))
(defun org-babel-read-table ()
"Read the table at point into emacs-lisp."
(mapcar (lambda (row)
(if (and (symbolp row) (equal row 'hline)) row
(mapcar (lambda (el) (org-babel-read el 'inhibit-lisp-eval)) row)))
(org-table-to-lisp)))
(defun org-babel-read-list ()
"Read the list at point into emacs-lisp.
Return the list of strings representing top level items:
(item1 item2 ...)
Only consider top level items. See Info node
`(org)Environment of a Code Block'."
(mapcar (lambda (el) (org-babel-read (car el) 'inhibit-lisp-eval))
(cdr (org-list-to-lisp))))
(defvar org-link-types-re)
(defun org-babel-read-link ()
"Read the link at point into emacs-lisp.
If the path of the link is a file path it is expanded using
`expand-file-name'."
(let* ((case-fold-search t)
(raw (and (looking-at org-link-bracket-re)
(org-no-properties (match-string 1))))
(type (and (string-match org-link-types-re raw)
(match-string 1 raw))))
(cond
((not type) (expand-file-name raw))
((string= type "file")
(and (string-match "file\\(.*\\):\\(.+\\)" raw)
(expand-file-name (match-string 2 raw))))
(t raw))))
(defun org-babel-format-result (result &optional sep)
"Format RESULT for writing to file.
When RESULT is a list, write it as a table, use tab or SEP as column
separator."
(let ((echo-res (lambda (r) (if (stringp r) r (format "%S" r)))))
(if (listp result)
;; table result
(orgtbl-to-generic
result (list :sep (or sep "\t") :fmt echo-res))
;; scalar result
(funcall echo-res result))))
(defun org-babel-insert-result (result &optional result-params info hash lang exec-time)
"Insert RESULT into the current buffer.
By default RESULT is inserted after the end of the current source
block. The RESULT of an inline source block usually will be
wrapped inside a `results' macro and placed on the same line as
the inline source block. The macro is stripped upon export.
Multiline and non-scalar RESULTS from inline source blocks are
not allowed. When EXEC-TIME is provided it may be included in a
generated message. With optional argument RESULT-PARAMS controls
insertion of results in the Org mode file. RESULT-PARAMS is a list
that can contain the following values:
replace - (default option) insert results after the source block
or inline source block replacing any previously
inserted results.
silent -- no results are inserted into the Org buffer but
the results are echoed to the minibuffer and are
ingested by Emacs (a potentially time consuming
process).
none ---- no results are inserted into the Org buffer nor
echoed to the minibuffer. They are not processed into
Emacs-lisp objects at all.
file ---- the results are interpreted as a file path, and are
inserted into the buffer using the Org file syntax.
list ---- the results are interpreted as an Org list.
raw ----- results are added directly to the Org file. This is
a good option if you code block will output Org
formatted text.
drawer -- results are added directly to the Org file as with
\"raw\", but are wrapped in a RESULTS drawer or results
macro, allowing them to later be replaced or removed
automatically.
org ----- results are added inside of a \"src_org{}\" or \"#+BEGIN_SRC
org\" block depending on whether the current source block is
inline or not. They are not comma-escaped when inserted,
but Org syntax here will be discarded when exporting the
file.
html ---- results are added inside of a #+BEGIN_EXPORT HTML block
or html export snippet depending on whether the current
source block is inline or not. This is a good option
if your code block will output html formatted text.
latex --- results are added inside of a #+BEGIN_EXPORT LATEX
block or latex export snippet depending on whether the
current source block is inline or not. This is a good
option if your code block will output latex formatted
text.
code ---- the results are extracted in the syntax of the source
code of the language being evaluated and are added
inside of a source block with the source-code language
set appropriately. Also, source block inlining is
preserved in this case. Note this relies on the
optional LANG argument.
list ---- the results are rendered as a list. This option not
allowed for inline source blocks.
table --- the results are rendered as a table. This option not
allowed for inline source blocks.
INFO is the src block info, as returned by
`org-babel-get-src-block-info' (which see). Some values from its
PARAMETERS part (header argument alist) can affect the inserted
result:
:file-desc - when RESULT-PARAMS contains \"file\", use it as
description of the inserted link.
:wrap the effect is similar to `latex' in RESULT-PARAMS but
using the argument supplied to specify the export block
or snippet type."
(cond ((stringp result)
(setq result (substring-no-properties result))
(when (member "file" result-params)
(setq result
(org-babel-result-to-file
result
(org-babel--file-desc (nth 2 info) result)
'attachment))))
((listp result))
(t (setq result (format "%S" result))))
(if (and result-params (member "silent" result-params))
(progn (message (replace-regexp-in-string "%" "%%" (format "%S" result)))
result)
(let ((inline (let ((context (org-element-context)))
(and (org-element-type-p
context '(inline-babel-call inline-src-block))
context))))
(when inline
(let ((warning
(or (and (member "table" result-params) "`:results table'")
(and (member "drawer" result-params) "`:results drawer'")
(and result (listp result) "list result")
(and result (string-match-p "\n." result) "multiline result")
(and (member "list" result-params) "`:results list'"))))
(when warning
(user-error "Inline error: %s cannot be used" warning))))
(save-excursion
(let* ((visible-beg (point-min-marker))
(visible-end (copy-marker (point-max) t))
(existing-result (org-babel-where-is-src-block-result t nil hash))
(results-switches (cdr (assq :results_switches (nth 2 info))))
;; When results exist outside of the current visible
;; region of the buffer, be sure to widen buffer to
;; update them.
(outside-scope (and existing-result
(buffer-narrowed-p)
(or (> visible-beg existing-result)
(<= visible-end existing-result))))
beg end indent)
;; Ensure non-inline results end in a newline.
(when (and (org-string-nw-p result)
(not inline)
(not (string-equal (substring result -1) "\n")))
(setq result (concat result "\n")))
(unwind-protect
(progn
(when outside-scope (widen))
(if existing-result (goto-char existing-result)
(goto-char (org-element-end inline))
(skip-chars-backward " \t"))
(unless inline
(setq indent (current-indentation))
(forward-line 1))
(setq beg (point))
(cond
(inline
;; Make sure new results are separated from the
;; source code by one space.
(unless existing-result
(insert " ")
(setq beg (point))))
((member "replace" result-params)
(delete-region (point) (org-babel-result-end)))
((member "append" result-params)
(goto-char (org-babel-result-end)) (setq beg (point-marker)))
;; ((member "prepend" result-params)) ; already there
)
(setq results-switches
(if results-switches (concat " " results-switches) ""))
(let ((wrap
(lambda (start finish &optional no-escape no-newlines
inline-start inline-finish)
(when inline
(setq start inline-start)
(setq finish inline-finish)
(setq no-newlines t))
(let ((before-finish (copy-marker end)))
(goto-char end)
(insert (concat finish (unless no-newlines "\n")))
(goto-char beg)
(insert (concat start (unless no-newlines "\n")))
(unless no-escape
(org-escape-code-in-region
(min (point) before-finish) before-finish))
(goto-char end))))
(tabulablep
(lambda (r)
;; Non-nil when result R can be turned into
;; a table.
(and (proper-list-p r)
(cl-every
(lambda (e) (or (atom e) (proper-list-p e)))
result)))))
;; insert results based on type
(cond
;; Do nothing for an empty result.
((null result))
;; Insert a list if preferred.
((member "list" result-params)
(insert
(org-trim
(org-list-to-org
;; We arbitrarily choose to format non-strings
;; as %S.
(cons 'unordered
(mapcar
(lambda (e)
(cond
((stringp e) (list e))
((listp e)
(mapcar
(lambda (x)
(if (stringp x) x (format "%S" x)))
e))
(t (list (format "%S" e)))))
(if (listp result) result
(split-string result "\n" t))))
'(:splicep nil :istart "- " :iend "\n")))
"\n"))
;; Try hard to print RESULT as a table. Give up if
;; it contains an improper list.
((funcall tabulablep result)
(goto-char beg)
(insert (concat (orgtbl-to-orgtbl
(if (cl-every
(lambda (e)
(or (eq e 'hline) (listp e)))
result)
result
(list result))
nil)
"\n"))
(goto-char beg)
(when (org-at-table-p) (org-table-align))
(goto-char (org-table-end)))
;; Print verbatim a list that cannot be turned into
;; a table.
((listp result) (insert (format "%s\n" result)))
((member "file" result-params)
(when inline
(setq result (org-macro-escape-arguments result)))
(insert result))
((and inline (not (member "raw" result-params)))
(insert (org-macro-escape-arguments
(org-babel-chomp result "\n"))))
(t (goto-char beg) (insert result)))
(setq end (copy-marker (point) t))
;; Possibly wrap result.
(cond
((assq :wrap (nth 2 info))
(let* ((full (or (cdr (assq :wrap (nth 2 info))) "results"))
(split (split-string full))
(type (car split))
(opening-line (concat "#+begin_" full))
(closing-line (concat "#+end_" type)))
(cond
;; Escape contents from "export" wrap. Wrap
;; inline results within an export snippet with
;; appropriate value.
((org-string-equal-ignore-case type "export")
(let ((backend (pcase split
(`(,_) "none")
(`(,_ ,b . ,_) b))))
(funcall wrap
opening-line closing-line
nil nil
(format "{{{results(@@%s:"
backend) "@@)}}}")))
;; Escape contents from "example" wrap. Mark
;; inline results as verbatim.
((org-string-equal-ignore-case type "example")
(funcall wrap
opening-line closing-line
nil nil
"{{{results(=" "=)}}}"))
;; Escape contents from "src" wrap. Mark
;; inline results as inline source code.
((org-string-equal-ignore-case type "src")
(let ((inline-open
(pcase split
(`(,_)
"{{{results(src_none{")
(`(,_ ,language)
(format "{{{results(src_%s{" language))
(`(,_ ,language . ,rest)
(let ((r (mapconcat #'identity rest " ")))
(format "{{{results(src_%s[%s]{"
language r))))))
(funcall wrap
opening-line closing-line
nil nil
inline-open "})}}}")))
;; Do not escape contents in non-verbatim
;; blocks. Return plain inline results.
(t
(funcall wrap
opening-line closing-line
t nil
"{{{results(" ")}}}")))))
((member "html" result-params)
(funcall wrap "#+begin_export html" "#+end_export" nil nil
"{{{results(@@html:" "@@)}}}"))
((member "latex" result-params)
(funcall wrap "#+begin_export latex" "#+end_export" nil nil
"{{{results(@@latex:" "@@)}}}"))
((member "org" result-params)
(goto-char beg) (when (org-at-table-p) (org-cycle))
(funcall wrap "#+begin_src org" "#+end_src" nil nil
"{{{results(src_org{" "})}}}"))
((member "code" result-params)
(let ((lang (or lang "none")))
(funcall wrap (format "#+begin_src %s%s" lang results-switches)
"#+end_src" nil nil
(format "{{{results(src_%s[%s]{" lang results-switches)
"})}}}")))
((member "raw" result-params)
(goto-char beg) (when (org-at-table-p) (org-cycle)))
((or (member "drawer" result-params)
;; Stay backward compatible with <7.9.2
(member "wrap" result-params))
(goto-char beg) (when (org-at-table-p) (org-cycle))
(funcall wrap ":results:" ":end:" 'no-escape nil
"{{{results(" ")}}}"))
((and inline (member "file" result-params))
(funcall wrap nil nil nil nil "{{{results(" ")}}}"))
((and (not (funcall tabulablep result))
(not (member "file" result-params)))
(let ((org-babel-inline-result-wrap
;; Hard code {{{results(...)}}} on top of
;; customization.
(format "{{{results(%s)}}}"
org-babel-inline-result-wrap)))
(org-babel-examplify-region
beg end results-switches inline)))))
;; Possibly indent results in par with #+results line.
(when (and (not inline) (numberp indent) (> indent 0)
;; In this case `table-align' does the work
;; for us.
(not (and (listp result)
(member "append" result-params))))
(indent-rigidly beg end indent))
(unless noninteractive
(let ((time-info
;; Only show the time when something other than
;; 0s will be shown, i.e. check if the time is at
;; least half of the displayed precision.
(if (and exec-time (> (float-time exec-time) 0.05))
(format " (took %.1fs)" (float-time exec-time))
"")))
(if (null result)
(if (member "value" result-params)
(message "Code block returned no value%s." time-info)
(message "Code block produced no output%s." time-info))
(message "Code block evaluation complete%s." time-info)))))
(when end (set-marker end nil))
(when outside-scope (narrow-to-region visible-beg visible-end))
(set-marker visible-beg nil)
(set-marker visible-end nil)))))))
(defun org-babel-remove-result (&optional info keep-keyword)
"Remove the result of the current source block.
INFO argument is currently ignored.
When KEEP-KEYWORD is non-nil, keep the #+RESULT keyword and just remove
the rest of the result."
(interactive)
(let ((location (org-babel-where-is-src-block-result nil info))
(case-fold-search t))
(when location
(save-excursion
(goto-char location)
(when (looking-at org-babel-result-regexp)
(delete-region
(if keep-keyword (line-beginning-position 2)
(save-excursion
(skip-chars-backward " \r\t\n")
(line-beginning-position 2)))
(progn (forward-line) (org-babel-result-end))))))))
(defun org-babel-remove-inline-result (&optional datum)
"Remove the result of DATUM or the current inline-src-block or babel call.
The result must be wrapped in a `results' macro to be removed.
Leading white space is trimmed."
(interactive)
(let* ((el (or datum (org-element-context))))
(when (org-element-type-p el '(inline-src-block inline-babel-call))
(org-with-wide-buffer
(goto-char (org-element-end el))
(skip-chars-backward " \t")
(let ((result (save-excursion
(skip-chars-forward
" \t\n"
(org-element-contents-end
(org-element-parent el)))
(org-element-context))))
(when (and (org-element-type-p result 'macro)
(string= (org-element-property :key result) "results"))
(delete-region ; And leading whitespace.
(point)
(progn (goto-char (org-element-end result))
(skip-chars-backward " \t\n")
(point)))))))))
(defun org-babel-remove-result-one-or-many (arg)
"Remove the result of the current source block.
If called with prefix argument ARG, remove all result blocks in the
buffer."
(interactive "P")
(if arg
(progn
(org-babel-map-src-blocks nil (org-babel-remove-result))
(org-babel-map-call-lines nil (org-babel-remove-result)))
(org-babel-remove-result)))
(defun org-babel-result-end ()
"Return the point at the end of the current set of results."
(cond ((looking-at-p "^[ \t]*$") (point)) ;no result
((looking-at-p (format "^[ \t]*%s[ \t]*$" org-link-bracket-re))
(line-beginning-position 2))
(t
(let ((element (org-element-at-point)))
(if (org-element-type-p
element
;; Possible results types.
'(drawer example-block export-block fixed-width
special-block src-block item plain-list table
latex-environment))
(save-excursion
(goto-char (min (point-max) ;for narrowed buffers
(org-element-end element)))
(skip-chars-backward " \r\t\n")
(line-beginning-position 2))
(point))))))
(defun org-babel-result-to-file (result &optional description type)
"Convert RESULT into an Org link with optional DESCRIPTION.
If the `default-directory' is different from the containing
file's directory then expand relative links.
If the optional TYPE is passed as `attachment' and the path is a
descendant of the DEFAULT-DIRECTORY, the generated link will be
specified as an \"attachment:\" style link."
(when (stringp result)
(let* ((result-file-name (expand-file-name result))
(base-file-name (buffer-file-name (buffer-base-buffer)))
(base-directory (and base-file-name
(file-name-directory base-file-name)))
(same-directory?
(and base-file-name
(not (string= (expand-file-name default-directory)
(expand-file-name
base-directory)))))
(request-attachment (eq type 'attachment))
(attach-dir (let* ((default-directory base-directory)
(dir (org-attach-dir nil t)))
(when dir
(expand-file-name dir))))
(in-attach-dir (and request-attachment
attach-dir
(string-prefix-p
attach-dir
result-file-name))))
(format "[[%s:%s]%s]"
(pcase type
((and 'attachment (guard in-attach-dir)) "attachment")
(_ "file"))
(if (and request-attachment in-attach-dir)
(file-relative-name
result-file-name
(file-name-as-directory attach-dir))
(if (and default-directory
base-file-name same-directory?)
(if (eq org-link-file-path-type 'adaptive)
(file-relative-name
result-file-name
(file-name-directory
base-file-name))
result-file-name)
result))
(if description (concat "[" description "]") "")))))
(defun org-babel-examplify-region (beg end &optional results-switches inline)
"Comment out region BEG..END using the inline `==' or `: ' org example quote.
When INLINE is non-nil, use the inline verbatim markup.
When INLINE is nil and RESULTS-SWITCHES is non-nil, RESULTS-SWITCHES is
used as a string to be appended to #+begin_example line."
(interactive "*r")
(let ((maybe-cap
(lambda (str)
(if org-babel-uppercase-example-markers (upcase str) str))))
(if inline
(save-excursion
(goto-char beg)
(insert (format org-babel-inline-result-wrap
(delete-and-extract-region beg end))))
(let ((size (count-lines beg end)))
(save-excursion
(cond ((= size 0)) ; do nothing for an empty result
((< size org-babel-min-lines-for-block-output)
(goto-char beg)
(dotimes (_ size)
(forward-line 0) (insert ": ") (forward-line 1)))
(t
(goto-char beg)
(insert (if results-switches
(format "%s%s\n"
(funcall maybe-cap "#+begin_example")
results-switches)
(funcall maybe-cap "#+begin_example\n")))
(let ((p (point)))
(if (markerp end) (goto-char end) (forward-char (- end beg)))
(org-escape-code-in-region p (point)))
(insert (funcall maybe-cap "#+end_example\n")))))))))
(defun org-babel-update-block-body (new-body)
"Update the body of the current code block to NEW-BODY."
(let ((element (org-element-at-point)))
(unless (org-element-type-p element 'src-block)
(error "Not in a source block"))
(goto-char (org-babel-where-is-src-block-head element))
(let* ((ind (org-current-text-indentation))
(body-start (line-beginning-position 2))
(body (org-element-normalize-string
(if (org-src-preserve-indentation-p element) new-body
(with-temp-buffer
(insert (org-remove-indentation new-body))
(indent-rigidly
(point-min)
(point-max)
(+ ind org-edit-src-content-indentation))
(buffer-string))))))
(delete-region body-start
(org-with-wide-buffer
(goto-char (org-element-end element))
(skip-chars-backward " \t\n")
(line-beginning-position)))
(goto-char body-start)
(insert body))))
(defun org-babel-merge-params (&rest alists)
"Combine all parameter association lists in ALISTS.
Later elements of ALISTS override the values of previous elements.
This takes into account some special considerations for certain
parameters when merging lists."
(let* ((results-exclusive-groups
(mapcar (lambda (group) (mapcar #'symbol-name group))
(cdr (assq 'results org-babel-common-header-args-w-values))))
(exports-exclusive-groups
(mapcar (lambda (group) (mapcar #'symbol-name group))
(cdr (assq 'exports org-babel-common-header-args-w-values))))
(merge
(lambda (exclusive-groups &rest result-params)
;; Maintain exclusivity of mutually exclusive parameters,
;; as defined in EXCLUSIVE-GROUPS while merging lists in
;; RESULT-PARAMS.
(let (output)
(dolist (new-params result-params (delete-dups output))
(dolist (new-param new-params)
(dolist (exclusive-group exclusive-groups)
(when (member new-param exclusive-group)
(setq output (cl-remove-if
(lambda (o) (member o exclusive-group))
output))))
(push new-param output))))))
(variable-index 0) ;Handle positional arguments.
clearnames
params ;Final parameters list.
;; Some keywords accept multiple values. We need to treat
;; them specially.
vars results exports)
(dolist (alist alists)
(dolist (pair alist)
(pcase pair
(`(:var . ,value)
(let ((name (cond
;; Default header arguments can accept lambda
;; functions. We uniquely identify the var
;; according to the full string contents of
;; the lambda function.
((functionp value) value)
((listp value) (car value))
((string-match "^\\([^= \f\t\n\r\v]+\\)[ \t]*=" value)
(intern (match-string 1 value)))
(t nil))))
(cond
(name
(setq vars
(append (if (not (assoc name vars)) vars
(push name clearnames)
(cl-remove-if (lambda (p) (equal name (car p)))
vars))
(list (cons name pair)))))
((and vars (nth variable-index vars))
;; If no name is given and we already have named
;; variables then assign to named variables in order.
(let ((name (car (nth variable-index vars))))
;; Clear out colnames and rownames for replace vars.
(push name clearnames)
(setf (cddr (nth variable-index vars))
(concat (symbol-name name) "=" value))
(cl-incf variable-index)))
(t (error "Variable \"%s\" must be assigned a default value"
(cdr pair))))))
(`(:results . ,value)
(setq results (funcall merge
results-exclusive-groups
results
(split-string
(cond ((stringp value) value)
((functionp value) (funcall value))
;; FIXME: Arbitrary code evaluation.
(t (eval value t)))))))
(`(:exports . ,value)
(setq exports (funcall merge
exports-exclusive-groups
exports
(split-string
(cond ((and value (functionp value)) (funcall value))
(value value)
(t ""))))))
((or '(:dir . attach) '(:dir . "'attach"))
(unless (org-attach-dir nil t)
(error "No attachment directory for element (add :ID: or :DIR: property)"))
(setq params (append
`((:dir . ,(org-attach-dir nil t))
(:mkdirp . "yes"))
(assq-delete-all :dir (assq-delete-all :mkdir params)))))
;; Regular keywords: any value overwrites the previous one.
(_ (setq params (cons pair (assq-delete-all (car pair) params)))))))
;; Handle `:var' and clear out colnames and rownames for replaced
;; variables.
(setq params (nconc (mapcar (lambda (v) (cons :var (cddr v))) vars)
params))
(dolist (name clearnames)
(dolist (param '(:colname-names :rowname-names))
(when (assq param params)
(setf (cdr (assq param params))
(cl-remove-if (lambda (pair) (equal name (car pair)))
(cdr (assq param params))))
(setq params
(cl-remove-if (lambda (pair) (and (equal (car pair) param)
(null (cdr pair))))
params)))))
;; Handle other special keywords, which accept multiple values.
(setq params (nconc (list (cons :results (mapconcat #'identity results " "))
(cons :exports (mapconcat #'identity exports " ")))
params))
;; Return merged params.
(org-babel-eval-headers params)))
(defun org-babel-noweb-p (params context)
"Check if PARAMS require expansion in CONTEXT.
CONTEXT may be one of :tangle, :export or :eval."
(let ((allowed-values (cl-case context
(:tangle '("yes" "tangle" "no-export" "strip-export" "strip-tangle"))
(:eval '("yes" "no-export" "strip-export" "eval" "strip-tangle"))
(:export '("yes" "strip-tangle")))))
(cl-some (lambda (v) (member v allowed-values))
(split-string (or (cdr (assq :noweb params)) "")))))
(defvar org-babel-expand-noweb-references--cache nil
"Noweb reference cache used during expansion.")
(defvar org-babel-expand-noweb-references--cache-buffer nil
"Cons (BUFFER . MODIFIED-TICK) for cached noweb references.
See `org-babel-expand-noweb-references--cache'.")
(defun org-babel-expand-noweb-references (&optional info parent-buffer)
"Expand Noweb references in the body of the current source code block.
When optional argument INFO is non-nil, use the block defined by INFO
instead.
The block is assumed to be located in PARENT-BUFFER or current buffer
\(when PARENT-BUFFER is nil).
For example the following reference would be replaced with the
body of the source-code block named `example-block'.
<>
Note that any text preceding the <> construct on a line will
be interposed between the lines of the replacement text. So for
example if <> is placed behind a comment, then the entire
replacement text will also be commented.
This function must be called from inside of the buffer containing
the source-code block which holds BODY.
In addition the following syntax can be used to insert the
results of evaluating the source-code block named `example-block'.
<>
Any optional arguments can be passed to example-block by placing
the arguments inside the parenthesis following the convention
defined by `org-babel-lob'. For example
<>
would set the value of argument \"a\" equal to \"9\". Note that
these arguments are not evaluated in the current source-code
block but are passed literally to the \"example-block\"."
(let* ((parent-buffer (or parent-buffer (current-buffer)))
(info (or info (org-babel-get-src-block-info 'no-eval)))
(lang (nth 0 info))
(body (nth 1 info))
(comment (string= "noweb" (cdr (assq :comments (nth 2 info)))))
(noweb-prefix (let ((v (assq :noweb-prefix (nth 2 info))))
(or (not v)
(and (org-not-nil (cdr v))
(not (equal (cdr v) "no"))))))
(noweb-re (format "\\(.*?\\)\\(%s\\)"
(with-current-buffer parent-buffer
(org-babel-noweb-wrap)))))
(unless (equal (cons parent-buffer
(with-current-buffer parent-buffer
(buffer-chars-modified-tick)))
org-babel-expand-noweb-references--cache-buffer)
(setq org-babel-expand-noweb-references--cache nil
org-babel-expand-noweb-references--cache-buffer
(cons parent-buffer
(with-current-buffer parent-buffer
(buffer-chars-modified-tick)))))
(cl-macrolet ((c-wrap
(s)
;; Comment string S, according to LANG mode. Return new
;; string.
`(unless org-babel-tangle-uncomment-comments
(with-temp-buffer
(funcall (org-src-get-lang-mode lang))
(comment-region (point)
(progn (insert ,s) (point)))
(org-trim (buffer-string)))))
(expand-body
(i)
;; Expand body of code represented by block info I.
`(let ((b (if (org-babel-noweb-p (nth 2 ,i) :eval)
(org-babel-expand-noweb-references ,i)
(nth 1 ,i))))
(if (not comment) b
(let ((cs (org-babel-tangle-comment-links ,i)))
(concat (c-wrap (car cs)) "\n"
b "\n"
(c-wrap (cadr cs)) "\n")))))
(expand-references
(ref)
`(pcase (gethash ,ref org-babel-expand-noweb-references--cache)
(`(,last . ,previous)
;; Ignore separator for last block.
(let ((strings (list (expand-body last))))
(dolist (i previous)
(let ((parameters (nth 2 i)))
;; Since we're operating in reverse order, first
;; push separator, then body.
(push (or (cdr (assq :noweb-sep parameters)) "\n")
strings)
(push (expand-body i) strings)))
(mapconcat #'identity strings "")))
;; Raise an error about missing reference, or return the
;; empty string.
((guard (or org-babel-noweb-error-all-langs
(member lang org-babel-noweb-error-langs)))
(error "Cannot resolve %s (see `org-babel-noweb-error-langs')"
(org-babel-noweb-wrap ,ref)))
(_ ""))))
(replace-regexp-in-string
noweb-re
(lambda (m)
(with-current-buffer parent-buffer
(save-match-data
(let* ((prefix (match-string 1 m))
(id (match-string 3 m))
(evaluate (string-match-p "(.*)" id))
(expansion
(cond
(evaluate
(prog1
(let ((raw (org-babel-ref-resolve id)))
(if (stringp raw) raw (format "%S" raw)))
;; Evaluation can potentially modify the buffer
;; and invalidate the cache: reset it.
(unless (equal org-babel-expand-noweb-references--cache-buffer
(cons parent-buffer
(buffer-chars-modified-tick)))
(setq org-babel-expand-noweb-references--cache nil
org-babel-expand-noweb-references--cache-buffer
(cons parent-buffer
(with-current-buffer parent-buffer
(buffer-chars-modified-tick)))))))
;; Already cached.
((and (hash-table-p org-babel-expand-noweb-references--cache)
(gethash id org-babel-expand-noweb-references--cache))
(expand-references id))
;; Return the contents of headlines literally.
((org-babel-ref-goto-headline-id id)
(org-babel-ref-headline-body))
;; Look for a source block named SOURCE-NAME. If
;; found, assume it is unique; do not look after
;; `:noweb-ref' header argument.
((org-with-point-at 1
(let ((r (org-babel-named-src-block-regexp-for-name id)))
(and (re-search-forward r nil t)
(not (org-in-commented-heading-p))
(let ((info (org-babel-get-src-block-info t)))
(unless (hash-table-p org-babel-expand-noweb-references--cache)
(setq org-babel-expand-noweb-references--cache (make-hash-table :test #'equal)))
(push info (gethash id org-babel-expand-noweb-references--cache))
(expand-body info))))))
;; Retrieve from the Library of Babel.
((nth 2 (assoc-string id org-babel-library-of-babel)))
;; All Noweb references were cached in a previous
;; run. Yet, ID is not in cache (see the above
;; condition). Process missing reference in
;; `expand-references'.
((and (hash-table-p org-babel-expand-noweb-references--cache)
(gethash 'buffer-processed org-babel-expand-noweb-references--cache))
(expand-references id))
;; Though luck. We go into the long process of
;; checking each source block and expand those
;; with a matching Noweb reference. Since we're
;; going to visit all source blocks in the
;; document, cache information about them as well.
(t
(setq org-babel-expand-noweb-references--cache (make-hash-table :test #'equal))
(org-with-wide-buffer
(org-babel-map-src-blocks nil
(if (org-in-commented-heading-p)
(org-forward-heading-same-level nil t)
(let* ((info (org-babel-get-src-block-info t))
(ref (cdr (assq :noweb-ref (nth 2 info)))))
(push info (gethash ref org-babel-expand-noweb-references--cache))))))
(puthash 'buffer-processed t org-babel-expand-noweb-references--cache)
(expand-references id)))))
;; Interpose PREFIX between every line.
(if noweb-prefix
(mapconcat #'identity
(split-string expansion "[\n\r]")
(concat "\n" prefix))
expansion)))))
body t t 2))))
(defun org-babel--script-escape-inner (str)
(let (in-single in-double backslash out)
(mapc
(lambda (ch)
(setq
out
(if backslash
(progn
(setq backslash nil)
(cond
((and in-single (eq ch ?'))
;; Escaped single quote inside single quoted string:
;; emit just a single quote, since we've changed the
;; outer quotes to double.
(cons ch out))
((eq ch ?\")
;; Escaped double quote
(if in-single
;; This should be interpreted as backslash+quote,
;; not an escape. Emit a three backslashes
;; followed by a quote (because one layer of
;; quoting will be stripped by `org-babel-read').
(append (list ch ?\\ ?\\ ?\\) out)
;; Otherwise we are in a double-quoted string. Emit
;; a single escaped quote
(append (list ch ?\\) out)))
((eq ch ?\\)
;; Escaped backslash: emit a single escaped backslash
(append (list ?\\ ?\\) out))
;; Other: emit a quoted backslash followed by whatever
;; the character was (because one layer of quoting will
;; be stripped by `org-babel-read').
(t (append (list ch ?\\ ?\\) out))))
(cl-case ch
(?\[ (if (or in-double in-single)
(cons ?\[ out)
(cons ?\( out)))
(?\] (if (or in-double in-single)
(cons ?\] out)
(cons ?\) out)))
(?\{ (if (or in-double in-single)
(cons ?\{ out)
(cons ?\( out)))
(?\} (if (or in-double in-single)
(cons ?\} out)
(cons ?\) out)))
(?, (if (or in-double in-single)
(cons ?, out) (cons ?\s out)))
(?\' (if in-double
(cons ?\' out)
(setq in-single (not in-single)) (cons ?\" out)))
(?\" (if in-single
(append (list ?\" ?\\) out)
(setq in-double (not in-double)) (cons ?\" out)))
(?\\ (unless (or in-single in-double)
(error "Can't handle backslash outside string in `org-babel-script-escape'"))
(setq backslash t)
out)
(t (cons ch out))))))
(string-to-list str))
(when (or in-single in-double)
(error "Unterminated string in `org-babel-script-escape'"))
(apply #'string (reverse out))))
(defun org-babel-script-escape (str &optional force)
"Safely convert tables into elisp lists."
(unless (stringp str)
(error "`org-babel-script-escape' expects a string"))
(let ((escaped
(cond
((and (>= (length str) 2)
(or (and (string-equal "[" (substring str 0 1))
(string-equal "]" (substring str -1)))
(and (string-equal "{" (substring str 0 1))
(string-equal "}" (substring str -1)))
(and (string-equal "(" (substring str 0 1))
(string-equal ")" (substring str -1)))))
(concat "'" (org-babel--script-escape-inner str)))
((or force
(and (> (length str) 2)
(or (and (string-equal "'" (substring str 0 1))
(string-equal "'" (substring str -1)))
;; We need to pass double-quoted strings
;; through the backslash-twiddling bits, even
;; though we don't need to change their
;; delimiters.
(and (string-equal "\"" (substring str 0 1))
(string-equal "\"" (substring str -1))))))
(org-babel--script-escape-inner str))
(t str))))
(condition-case nil (org-babel-read escaped) (error escaped))))
(defun org-babel-read (cell &optional inhibit-lisp-eval)
"Convert the string value of CELL to a number if appropriate.
Otherwise if CELL looks like Lisp (meaning it starts with a
\"(\", \"\\='\", \"\\=`\" or a \"[\") then read and evaluate it as
lisp, otherwise return it unmodified as a string. Optional
argument INHIBIT-LISP-EVAL inhibits lisp evaluation for
situations in which is it not appropriate."
(cond ((not (org-string-nw-p cell)) cell)
((org-babel--string-to-number cell))
((and (not inhibit-lisp-eval)
(or (memq (string-to-char cell) '(?\( ?' ?` ?\[))
(string= cell "*this*")))
;; FIXME: Arbitrary code evaluation.
(eval (read cell) t))
((let (read-val)
(and (string-match-p
(rx bos (0+ (any space ?\n))
?\" (0+ anychar) ?\"
(0+ (any space ?\n)) eos)
cell)
;; CELL is a single string
(with-temp-buffer
(insert cell)
(goto-char 1)
(when (setq read-val
(ignore-errors
(read (current-buffer))))
(skip-chars-forward "[:space:]")
(eobp)))
read-val)))
(t (org-no-properties cell))))
(defun org-babel--string-to-number (string)
"If STRING represents a number return its value.
Otherwise return nil."
(unless (or (string-match-p "\\s-" (org-trim string))
(not (string-match-p "^[0-9e.+ -]+$" string)))
(let ((interned-string (ignore-errors (read string))))
(when (numberp interned-string)
interned-string))))
(defun org-babel-import-elisp-from-file (file-name &optional separator)
"Read the results located at FILE-NAME into an elisp table.
If the table is trivial, then return it as a scalar.
SEPARATOR is passed to `org-table-convert-region', which see."
(let ((result
(with-temp-buffer
(condition-case err
(progn
(insert-file-contents file-name)
(delete-file file-name)
(let ((pmax (point-max)))
;; If the file was empty, don't bother trying to
;; convert the table.
(when (> pmax 1)
(org-table-convert-region
(point-min) pmax
(or separator 'babel-auto))
(delq nil
(mapcar (lambda (row)
(and (not (eq row 'hline))
(mapcar #'org-babel-string-read row)))
(org-table-to-lisp))))))
(error
(display-warning 'org-babel
(format "Error reading results: %S" err)
:error)
nil)))))
(pcase result
(`((,scalar)) scalar)
(`((,_ ,_ . ,_)) result)
(`(,scalar) scalar)
(_ result))))
(defun org-babel-string-read (cell)
"Strip nested \"s from around CELL string.
When CELL is not a string, return CELL."
(org-babel-read (or (and (stringp cell)
(string-match "^[[:space:]]*\"\\(.+\\)\"[[:space:]]*$" cell)
(match-string 1 cell))
cell) t))
(defun org-babel-chomp (string &optional regexp)
"Strip a trailing space or carriage return from STRING.
The default regexp used is \"[ \\f\\t\\n\\r\\v]\" but another one
can be specified as the REGEXP argument."
(let ((regexp (or regexp "[ \f\t\n\r\v]")))
(while (and (> (length string) 0)
(string-match regexp (substring string -1)))
(setq string (substring string 0 -1)))
string))
(defun org-babel-process-file-name (name &optional no-quote-p)
"Prepare NAME to be used in an external process.
If NAME specifies a remote location, the remote portion of the
name is removed, since in that case the process will be executing
remotely. The file name is then processed by `expand-file-name'.
Unless second argument NO-QUOTE-P is non-nil, the file name is
additionally processed by `shell-quote-argument'."
(let ((f (org-babel-local-file-name (expand-file-name name))))
(if no-quote-p f (shell-quote-argument f))))
(defvar org-babel-temporary-directory
(unless noninteractive
(make-temp-file "babel-" t))
"Directory to hold temporary files created to execute code blocks.
Used by `org-babel-temp-file'. This directory will be removed on
Emacs shutdown.")
(defvar org-babel-temporary-stable-directory
(unless noninteractive
(let (dir)
(while (or (not dir) (file-exists-p dir))
(setq dir (expand-file-name
(format "babel-stable-%d" (random 1000))
temporary-file-directory)))
(make-directory dir)
dir))
"Directory to hold temporary files created to execute code blocks.
Used by `org-babel-temp-file'. This directory will be removed on
Emacs shutdown.")
(defcustom org-babel-remote-temporary-directory "/tmp/"
"Directory to hold temporary files on remote hosts."
:group 'org-babel
:type 'string)
(defmacro org-babel-result-cond (result-params scalar-form &rest table-forms)
"Call the code to parse raw string results according to RESULT-PARAMS.
Do nothing with :results discard.
Execute SCALAR-FORM when result should be treated as a string.
Execute TABLE-FORMS when result should be considered sexp and parsed."
(declare (indent 1) (debug t))
(org-with-gensyms (params)
`(let ((,params ,result-params))
(unless (member "discard" ,params)
(if (or (member "scalar" ,params)
(member "verbatim" ,params)
(member "html" ,params)
(member "code" ,params)
(member "pp" ,params)
(member "file" ,params)
(and (or (member "output" ,params)
(member "raw" ,params)
(member "org" ,params)
(member "drawer" ,params))
(not (member "table" ,params))))
,scalar-form
,@table-forms)))))
(defmacro org-babel-temp-directory ()
"Return temporary directory suitable for `default-directory'."
`(if (file-remote-p default-directory)
(concat (file-remote-p default-directory)
org-babel-remote-temporary-directory)
(or (and org-babel-temporary-directory
(file-exists-p org-babel-temporary-directory)
org-babel-temporary-directory)
temporary-file-directory)))
(defun org-babel-temp-file (prefix &optional suffix)
"Create a temporary file in the `org-babel-temporary-directory'.
Passes PREFIX and SUFFIX directly to `make-temp-file' with the
value of function `temporary-file-directory' temporarily set to the
value of `org-babel-temporary-directory'."
(make-temp-file
(concat (file-name-as-directory (org-babel-temp-directory)) prefix)
nil
suffix))
(defmacro org-babel-temp-stable-directory ()
"Return temporary stable directory."
`(let ((org-babel-temporary-directory org-babel-temporary-stable-directory))
(org-babel-temp-directory)))
(defun org-babel-temp-stable-file (data prefix &optional suffix)
"Create a temporary file in the `org-babel-remove-temporary-stable-directory'.
The file name is stable with respect to DATA. The file name is
constructed like the following: ."
(let ((path
(format
"%s%s%s%s"
(file-name-as-directory (org-babel-temp-stable-directory))
prefix
(org-sxhash-safe data)
(or suffix ""))))
;; Create file.
(with-temp-file path)
;; Return it.
path))
(defun org-babel-remove-temporary-directory ()
"Remove `org-babel-temporary-directory' on Emacs shutdown."
(when (and org-babel-temporary-directory
(file-exists-p org-babel-temporary-directory))
;; taken from `delete-directory' in files.el
(condition-case nil
(progn
(mapc (lambda (file)
;; This test is equivalent to
;; (and (file-directory-p fn) (not (file-symlink-p fn)))
;; but more efficient
(if (eq t (car (file-attributes file)))
(delete-directory file)
(delete-file file)))
(directory-files org-babel-temporary-directory 'full
directory-files-no-dot-files-regexp))
(delete-directory org-babel-temporary-directory))
(error
(message "Failed to remove temporary Org-babel directory %s"
(or org-babel-temporary-directory
"[directory not defined]"))))))
(defun org-babel-remove-temporary-stable-directory ()
"Remove `org-babel-temporary-stable-directory' and on Emacs shutdown."
(when (and org-babel-temporary-stable-directory
(file-exists-p org-babel-temporary-stable-directory))
(let ((org-babel-temporary-directory
org-babel-temporary-stable-directory))
(org-babel-remove-temporary-directory))))
(add-hook 'kill-emacs-hook #'org-babel-remove-temporary-directory)
(add-hook 'kill-emacs-hook #'org-babel-remove-temporary-stable-directory)
(defun org-babel-one-header-arg-safe-p (pair safe-list)
"Determine if the PAIR is a safe babel header arg according to SAFE-LIST.
For the format of SAFE-LIST, see `org-babel-safe-header-args'."
(and (consp pair)
(keywordp (car pair))
(stringp (cdr pair))
(or
(memq (car pair) safe-list)
(let ((entry (assq (car pair) safe-list)))
(and entry
(consp entry)
(cond ((functionp (cdr entry))
(funcall (cdr entry) (cdr pair)))
((listp (cdr entry))
(member (cdr pair) (cdr entry)))
(t nil)))))))
(defun org-babel-generate-file-param (src-name params)
"Calculate the filename for source block results.
The directory is calculated from the :output-dir property of the
source block; if not specified, use the current directory.
If the source block has a #+NAME and the :file parameter does not
contain any period characters, then the :file parameter is
treated as an extension, and the output file name is the
concatenation of the directory (as calculated above), the block
name, a period, and the parameter value as a file extension.
Otherwise, the :file parameter is treated as a full file name,
and the output file name is the directory (as calculated above)
plus the parameter value."
(let* ((file-cons (assq :file params))
(file-ext-cons (assq :file-ext params))
(file-ext (cdr-safe file-ext-cons))
(dir (cdr-safe (assq :output-dir params)))
fname)
;; create the output-dir if it does not exist
(when dir
(make-directory dir t))
(if file-cons
;; :file given; add :output-dir if given
(when dir
(setcdr file-cons (concat (file-name-as-directory dir) (cdr file-cons))))
;; :file not given; compute from name and :file-ext if possible
(when (and src-name file-ext)
(if dir
(setq fname (concat (file-name-as-directory (or dir ""))
src-name "." file-ext))
(setq fname (concat src-name "." file-ext)))
(setq params (cons (cons :file fname) params))))
params))
(defun org-babel-graphical-output-file (params)
"File where a babel block should send graphical output, per PARAMS.
Return nil if no graphical output is expected. Raise an error if
the output file is ill-defined."
(let ((file (cdr (assq :file params))))
(cond (file (and (member "graphics" (cdr (assq :result-params params)))
file))
((assq :file-ext params)
(user-error ":file-ext given but no :file generated; did you forget \
to name a block?"))
(t (user-error "No :file header argument given; cannot create \
graphical result")))))
(defun org-babel-make-language-alias (new old)
"Make source blocks of type NEW aliases for those of type OLD.
NEW and OLD should be strings. This function should be called
after the babel API for OLD-type source blocks is fully defined.
Callers of this function will probably want to add an entry to
`org-src-lang-modes' as well."
(dolist (fn '("execute" "expand-body" "prep-session"
"variable-assignments" "load-session"
"edit-prep"))
(let ((sym (intern-soft (concat "org-babel-" fn ":" old))))
(when (and sym (fboundp sym))
(defalias (intern (concat "org-babel-" fn ":" new)) sym))))
;; Technically we don't need a `dolist' for just one variable, but
;; we keep it for symmetry/ease of future expansion.
(dolist (var '("default-header-args"))
(let ((sym (intern-soft (concat "org-babel-" var ":" old))))
(when (and sym (boundp sym))
(defvaralias (intern (concat "org-babel-" var ":" new)) sym)))))
(provide 'ob-core)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; ob-core.el ends here
org-mode-9.7.29+dfsg/lisp/ob-css.el 0000664 0000000 0000000 00000002757 15004304337 0016743 0 ustar 00root root 0000000 0000000 ;;; ob-css.el --- Babel Functions for CSS -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2025 Free Software Foundation, Inc.
;; Author: Eric Schulte
;; Keywords: literate programming, reproducible research
;; URL: https://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
;; Keywords: literate programming, reproducible research
;; URL: https://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
;; Maintainer: stardiviner
;; URL: https://github.com/stardiviner/ob-eshell
;; Keywords: literate programming, reproducible research
;; 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
;; Keywords: literate programming, reproducible research
;; URL: https://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
;; Maintainer: Palak Mathur
;; Keywords: literate programming, reproducible research
;; URL: https://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
;; Keywords: literate programming, reproducible research
;; URL: https://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
;; Keywords: literate programming, reproducible research
;; URL: https://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 >" basetype-str)))
((or (listp val) (vectorp val)) ; a list declared in the source block header
(cons basetype (format "List<%s>" basetype-str)))
(t ; return base type
(cons basetype basetype-str)))))
(defun org-babel-java-val-to-base-type (val)
"Determine the base type of VAL.
VAL 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-java-val-to-base-type v)
(`stringp (setq type 'stringp))
(`floatp
(when (or (not type) (eq type 'integerp))
(setq type 'floatp)))
(`integerp
(unless type (setq type 'integerp)))))
val)
type))
(t 'stringp)))
(defun org-babel-java-table-or-string (results)
"Convert RESULTS into an appropriate elisp value.
If the results look like a list or vector, 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 'null el)
org-babel-java-null-to
el))
res)
res)))
(defun org-babel-java-evaluate (cmd result-type result-params result-file)
"Evaluate using an external java process.
CMD the command to execute.
If RESULT-TYPE equals `output' then return standard output as a
string. If RESULT-TYPE equals `value' then return the value
returned by the source block, as elisp.
RESULT-PARAMS input params used to format the response.
RESULT-FILE filename of the tempfile to store the returned value in
for `value' RESULT-TYPE. Not used for `output' RESULT-TYPE."
(let ((raw (pcase result-type
(`output (org-babel-eval cmd ""))
(`value (org-babel-eval cmd "")
(org-babel-eval-read-file result-file)))))
(org-babel-result-cond result-params raw
(org-babel-java-table-or-string raw))))
(provide 'ob-java)
;;; ob-java.el ends here
org-mode-9.7.29+dfsg/lisp/ob-js.el 0000664 0000000 0000000 00000017232 15004304337 0016561 0 ustar 00root root 0000000 0000000 ;;; ob-js.el --- Babel Functions for Javascript -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2025 Free Software Foundation, Inc.
;; Author: Eric Schulte
;; Keywords: literate programming, reproducible research, js
;; URL: https://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
;; Keywords: literate programming, reproducible research, scientific computing
;; URL: https://github.com/phrb/ob-julia
;; 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
;; Keywords: literate programming, reproducible research
;; URL: https://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
;; Keywords: literate programming, reproducible research
;; URL: https://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
;; Keywords: literate programming, reproducible research
;; URL: https://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
;; Keywords: literate programming, reproducible research
;; URL: https://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 ', 'exec'))
__org_babel_python_final = eval(compile(ast.Expression(
__org_babel_python_final.value), '', 'eval'))
else:
exec(compile(__org_babel_python_ast, '', 'exec'))
__org_babel_python_final = None
__org_babel_python_format_value(__org_babel_python_final, '%s', %s)"
(org-babel-process-file-name src-file 'noquote)
(org-babel-process-file-name result-file 'noquote)
(org-babel-python-var-to-python result-params)))
(defun org-babel-python-evaluate
(session body &optional result-type result-params preamble async graphics-file)
"Evaluate BODY as Python code."
(if session
(if async
(org-babel-python-async-evaluate-session
session body result-type result-params graphics-file)
(org-babel-python-evaluate-session
session body result-type result-params graphics-file))
(org-babel-python-evaluate-external-process
body result-type result-params preamble graphics-file)))
(defun org-babel-python--shift-right (body &optional count)
(with-temp-buffer
(python-mode)
(insert body)
(goto-char (point-min))
(while (not (eobp))
(unless (python-syntax-context 'string)
(python-indent-shift-right (line-beginning-position)
(line-end-position)
count))
(forward-line 1))
(buffer-string)))
(defun org-babel-python-evaluate-external-process
(body &optional result-type result-params preamble graphics-file)
"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 last statement in BODY, as elisp. If GRAPHICS-FILE is
non-nil, then save graphical results to that file instead."
(let ((raw
(pcase result-type
(`output (org-babel-eval (org-babel-python--command nil)
(concat preamble (and preamble "\n")
(if graphics-file
(format org-babel-python--output-graphics-wrapper
body graphics-file)
body))))
(`value (let ((results-file (or graphics-file
(org-babel-temp-file "python-"))))
(org-babel-eval (org-babel-python--command nil)
(concat
preamble (and preamble "\n")
(format
(concat org-babel-python--def-format-value "
def main():
%s
__org_babel_python_format_value(main(), '%s', %s)")
(org-babel-python--shift-right body)
(org-babel-process-file-name results-file 'noquote)
(org-babel-python-var-to-python result-params))))
(org-babel-eval-read-file results-file))))))
(org-babel-result-cond result-params
raw
(org-babel-python-table-or-string raw))))
(defun org-babel-python-send-string (session body)
"Pass BODY to the Python process in SESSION.
Return output."
(with-current-buffer session
(let* ((string-buffer "")
(comint-output-filter-functions
(cons (lambda (text) (setq string-buffer
(concat string-buffer text)))
comint-output-filter-functions))
(body (format "\
try:
%s
except:
raise
finally:
print('%s')"
(org-babel-python--shift-right body 4)
org-babel-python-eoe-indicator)))
(let ((python-shell-buffer-name
(org-babel-python-without-earmuffs session)))
(python-shell-send-string body))
;; same as `python-shell-comint-end-of-output-p' in emacs-25.1+
(while (not (and (python-shell-comint-end-of-output-p string-buffer)
(string-match
org-babel-python-eoe-indicator
string-buffer)))
(accept-process-output (get-buffer-process (current-buffer))))
(org-babel-chomp (substring string-buffer 0 (match-beginning 0))))))
(defun org-babel-python-evaluate-session
(session body &optional result-type result-params graphics-file)
"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 last statement in BODY, as elisp. If GRAPHICS-FILE is
non-nil, then save graphical results to that file instead."
(let* ((tmp-src-file (org-babel-temp-file "python-"))
(results
(progn
(with-temp-file tmp-src-file
(insert (if (and graphics-file (eq result-type 'output))
(format org-babel-python--output-graphics-wrapper
body graphics-file)
body)))
(pcase result-type
(`output
(let ((body (format "\
with open('%s') as f:
exec(compile(f.read(), f.name, 'exec'))"
(org-babel-process-file-name
tmp-src-file 'noquote))))
(org-babel-python-send-string session body)))
(`value
(let* ((results-file (or graphics-file
(org-babel-temp-file "python-")))
(body (org-babel-python-format-session-value
tmp-src-file results-file result-params)))
(org-babel-python-send-string session body)
(sleep-for 0.010)
(org-babel-eval-read-file results-file)))))))
(org-babel-result-cond result-params
results
(org-babel-python-table-or-string results))))
(defun org-babel-python-read-string (string)
"Strip \\='s from around Python STRING."
(if (and (string-prefix-p "'" string)
(string-suffix-p "'" string))
(substring string 1 -1)
string))
;; Async session eval
(defconst org-babel-python-async-indicator "print ('ob_comint_async_python_%s_%s')")
(defun org-babel-python-async-value-callback (params tmp-file)
(let ((result-params (cdr (assq :result-params params)))
(results (org-babel-eval-read-file tmp-file)))
(org-babel-result-cond result-params
results
(org-babel-python-table-or-string results))))
(defun org-babel-python-async-evaluate-session
(session body &optional result-type result-params graphics-file)
"Asynchronously evaluate BODY in SESSION.
Returns a placeholder string for insertion, to later be replaced
by `org-babel-comint-async-filter'."
(org-babel-comint-async-register
session (current-buffer)
"ob_comint_async_python_\\(start\\|end\\|file\\)_\\(.+\\)"
'org-babel-chomp 'org-babel-python-async-value-callback
'disable-prompt-filtering)
(pcase result-type
(`output
(let ((uuid (org-id-uuid)))
(with-temp-buffer
(insert (format org-babel-python-async-indicator "start" uuid))
(insert "\n")
(insert (if graphics-file
(format org-babel-python--output-graphics-wrapper
body graphics-file)
body))
(insert "\n")
(insert (format org-babel-python-async-indicator "end" uuid))
(let ((python-shell-buffer-name
(org-babel-python-without-earmuffs session)))
(python-shell-send-buffer)))
uuid))
(`value
(let ((results-file (or graphics-file
(org-babel-temp-file "python-")))
(tmp-src-file (org-babel-temp-file "python-")))
(with-temp-file tmp-src-file (insert body))
(with-temp-buffer
(insert (org-babel-python-format-session-value
tmp-src-file results-file result-params))
(insert "\n")
(unless graphics-file
(insert (format org-babel-python-async-indicator "file" results-file)))
(let ((python-shell-buffer-name
(org-babel-python-without-earmuffs session)))
(python-shell-send-buffer)))
results-file))))
(provide 'ob-python)
;;; ob-python.el ends here
org-mode-9.7.29+dfsg/lisp/ob-ref.el 0000664 0000000 0000000 00000022645 15004304337 0016725 0 ustar 00root root 0000000 0000000 ;;; ob-ref.el --- Babel Functions for Referencing External Data -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2025 Free Software Foundation, Inc.
;; Authors: Eric Schulte
;; Dan Davison
;; Keywords: literate programming, reproducible research
;; URL: https://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
;; Keywords: literate programming, interactive shell
;; URL: https://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
;; Keywords: literate programming, reproducible research
;; URL: https://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
;; Keywords: literate programming, reproducible research
;; URL: https://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 /@:/
or
/@
using its alias."
(cond ((and user password database host port)
(format "%s/%s@%s:%s/%s" user password host port database))
((and user password database)
(format "%s/%s@%s" user password database))
(t (user-error "Missing information to connect to database"))))
(defun org-babel-sql-dbstring-mssql (host user password database)
"Make sqlcmd command 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-dbstring-sqsh (host user password database)
"Make sqsh command line args for database connection.
\"sqsh\" is one method to access Sybase or MS SQL via 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-dbstring-vertica (host port user password database)
"Make Vertica command line args for database connection.
Pass nil to omit that arg."
(mapconcat #'identity
(delq nil
(list (when host (format "-h %s" host))
(when port (format "-p %d" port))
(when user (format "-U %s" user))
(when password (format "-w %s" (shell-quote-argument password) ))
(when database (format "-d %s" database))))
" "))
(defun org-babel-sql-dbstring-saphana (host port instance user password database)
"Make SAP HANA command line args for database connection.
Pass nil to omit that arg."
(mapconcat #'identity
(delq nil
(list (and host port (format "-n %s:%s" host port))
(and host (not port) (format "-n %s" host))
(and instance (format "-i %d" instance))
(and user (format "-u %s" user))
(and password (format "-p %s"
(shell-quote-argument password)))
(and 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's 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-find-db-connection-param (params name)
"Return database connection parameter NAME.
Given a parameter NAME, if :dbconnection is defined in PARAMS
then look for the parameter into the corresponding connection
defined in `sql-connection-alist', otherwise look into PARAMS.
See `sql-connection-alist' (part of SQL mode) for how to define
database connections."
(or (cdr (assq name params))
(and (assq :dbconnection params)
(let* ((dbconnection (cdr (assq :dbconnection params)))
(name-mapping '((:dbhost . sql-server)
(:dbport . sql-port)
(:dbuser . sql-user)
(:dbpassword . sql-password)
(:dbinstance . sql-dbinstance)
(:database . sql-database)))
(mapped-name (cdr (assq name name-mapping))))
(cadr (assq mapped-name
(cdr (assoc-string dbconnection sql-connection-alist t))))))))
(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 (assq :result-params params)))
(cmdline (cdr (assq :cmdline params)))
(dbhost (org-babel-find-db-connection-param params :dbhost))
(dbport (org-babel-find-db-connection-param params :dbport))
(dbuser (org-babel-find-db-connection-param params :dbuser))
(dbpassword (org-babel-find-db-connection-param params :dbpassword))
(dbinstance (org-babel-find-db-connection-param params :dbinstance))
(database (org-babel-find-db-connection-param params :database))
(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 (assq :out-file params))
(org-babel-temp-file "sql-out-")))
(header-delim "")
(command (cl-case (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)))
(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 "")
(org-babel-process-file-name in-file)
(org-babel-process-file-name out-file)))
((postgresql postgres) (format
"%s%s --set=\"ON_ERROR_STOP=1\" %s -A -P \
footer=off -F \"\t\" %s -f %s -o %s %s"
(if dbpassword
(format "PGPASSWORD=%s " dbpassword)
"")
(or (bound-and-true-p
sql-postgres-program)
"psql")
(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 "")))
(sqsh (format "sqsh %s %s -i %s -o %s -m csv"
(or cmdline "")
(org-babel-sql-dbstring-sqsh
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))))
(vertica (format "vsql %s -f %s -o %s %s"
(org-babel-sql-dbstring-vertica
dbhost dbport dbuser dbpassword database)
(org-babel-process-file-name in-file)
(org-babel-process-file-name out-file)
(or cmdline "")))
(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)))
(saphana (format "hdbsql %s -I %s -o %s %s"
(org-babel-sql-dbstring-saphana
dbhost dbport dbinstance dbuser dbpassword database)
(org-babel-process-file-name in-file)
(org-babel-process-file-name out-file)
(or cmdline "")))
(t (user-error "No support for the %s SQL engine" engine)))))
(with-temp-file in-file
(insert
(pcase (intern engine)
(`dbi "/format partbox\n")
(`oracle "SET PAGESIZE 50000
SET NEWPAGE 0
SET TAB OFF
SET SPACE 0
SET LINESIZE 9999
SET TRIMOUT ON TRIMSPOOL ON
SET ECHO OFF
SET FEEDBACK OFF
SET VERIFY OFF
SET HEADING ON
SET MARKUP HTML OFF SPOOL OFF
SET COLSEP '|'
")
((or `mssql `sqsh) "SET NOCOUNT ON
")
(`vertica "\\a\n")
(_ ""))
(org-babel-expand-body:sql body params)
;; "sqsh" requires "go" inserted at EOF.
(if (string= engine "sqsh") "\ngo" "")))
(org-babel-eval command "")
(org-babel-result-cond result-params
(with-temp-buffer
(progn (insert-file-contents-literally out-file) (buffer-string)))
(with-temp-buffer
(cond
((memq (intern engine) '(dbi mysql postgresql postgres saphana sqsh vertica))
;; 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 (if (string= engine "sqsh") '(4) '(16)))
(org-babel-reassemble-table
(mapcar (lambda (x)
(if (string= (car x) header-delim)
'hline
x))
(org-table-to-lisp))
(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 &optional sqlite)
"Expand the variables held in VARS in BODY.
If SQLITE has been provided, prevent passing a format to
`orgtbl-to-csv'. This prevents overriding the default format, which if
there were commas in the context of the table broke the table as an
argument mechanism."
(mapc
(lambda (pair)
(setq body
(replace-regexp-in-string
(format "$%s" (car pair))
(let ((val (cdr pair)))
(if (listp val)
(let ((data-file (org-babel-temp-file "sql-data-")))
(with-temp-file data-file
(insert (orgtbl-to-csv
val (if sqlite
nil
'(:fmt (lambda (el) (if (stringp el)
el
(format "%S" el))))))))
data-file)
(if (stringp val) val (format "%S" val))))
body t t)))
vars)
body)
(defun org-babel-prep-session:sql (_session _params)
"Raise an error because Sql sessions aren't implemented."
(error "SQL sessions not yet implemented"))
(provide 'ob-sql)
;;; ob-sql.el ends here
org-mode-9.7.29+dfsg/lisp/ob-sqlite.el 0000664 0000000 0000000 00000012264 15004304337 0017446 0 ustar 00root root 0000000 0000000 ;;; ob-sqlite.el --- Babel Functions for SQLite Databases -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2025 Free Software Foundation, Inc.
;; Author: Eric Schulte
;; Maintainer: Nick Savage
;; Keywords: literate programming, reproducible research
;; URL: https://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
;; 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 on the faulty key will try to fix it according to
;; those suggestions.
;; On a citation key, "follow" capability moves point to the corresponding entry
;; in the current bibliography. Elsewhere on the citation, it asks the user to
;; follow any of the keys cited there, with completion.
;; "export" capability supports the following citation styles:
;;
;; - author (a), including caps (c) variant,
;; - noauthor (na) including bare (b) variant,
;; - text (t), including bare (b), caps (c), and bare-caps (bc) variants,
;; - note (ft, including bare (b), caps (c), and bare-caps (bc) variants,
;; - nocite (n)
;; - numeric (nb),
;; - default, including bare (b), caps (c), and bare-caps (bc) variants.
;;
;; It also supports the following styles for bibliography:
;; - plain
;; - numeric
;; - author-year (default)
;; "insert" capability inserts or edits (with completion) citation style or
;; citation reference keys. In an appropriate place, it offers to insert a new
;; citation. With a prefix argument, it removes the one at point.
;; It supports bibliography files in BibTeX (".bibtex"), biblatex (".bib") and
;; JSON (".json") format.
;; Disclaimer: this citation processor is meant to be a proof of concept, and
;; possibly a fall-back mechanism when nothing else is available. It is too
;; limited for any serious use case.
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'bibtex)
(require 'json)
(require 'map)
(require 'oc)
(require 'seq)
(declare-function org-open-at-point "org" (&optional arg))
(declare-function org-open-file "org" (path &optional in-emacs line search))
(declare-function org-element-create "org-element-ast" (type &optional props &rest children))
(declare-function org-element-set "org-element-ast" (old new &optional keep-props))
(declare-function org-element-interpret-data "org-element" (data))
(declare-function org-element-parse-secondary-string "org-element" (string restriction &optional parent))
(declare-function org-element-map "org-element"
( data types fun
&optional
info first-match no-recursion
with-affiliated no-undefer))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-type-p "org-element-ast" (node types))
(declare-function org-element-contents "org-element-ast" (node))
(declare-function org-export-data "org-export" (data info))
(declare-function org-export-derived-backend-p "org-export" (backend &rest backends))
(declare-function org-export-raw-string "org-export" (contents))
;;; Customization
(defcustom org-cite-basic-sorting-field 'author
"Field used to sort bibliography items as a symbol, or nil."
:group 'org-cite
:package-version '(Org . "9.5")
:type 'symbol
:safe #'symbolp)
(defcustom org-cite-basic-author-year-separator ", "
"String used to separate cites in an author-year configuration."
:group 'org-cite
:package-version '(Org . "9.5")
:type 'string
:safe #'stringp)
(defcustom org-cite-basic-max-key-distance 2
"Maximum (Levenshtein) distance between a wrong key and its suggestions."
:group 'org-cite
:package-version '(Org . "9.5")
:type 'integer
:safe #'integerp)
(defcustom org-cite-basic-author-column-end 25
"Column where author field ends in completion table, as an integer."
:group 'org-cite
:package-version '(Org . "9.5")
:type 'integer
:safe #'integerp)
(defcustom org-cite-basic-column-separator " "
"Column separator in completion table, as a string."
:group 'org-cite
:package-version '(Org . "9.5")
:type 'string
:safe #'stringp)
(defcustom org-cite-basic-mouse-over-key-face 'highlight
"Face used when mouse is over a citation key."
:group 'org-cite
:package-version '(Org . "9.5")
:type 'face
:safe #'facep)
;;; Internal variables
(defvar org-cite-basic--bibliography-cache nil
"Cache for parsed bibliography files.
This is an association list following the pattern:
(FILE-ID . ENTRIES)
FILE-ID is a cons cell (FILE . HASH), with FILE being the absolute file name of
the bibliography file, and HASH a hash of its contents.
ENTRIES is a hash table with citation references as keys and fields alist as
values.")
(defvar org-cite-basic--completion-cache (make-hash-table :test #'equal)
"Cache for key completion table.
This is an a hash-table.")
;;; Internal functions
(defun org-cite-basic--parse-json ()
"Parse JSON entries in the current buffer.
Return a hash table with citation references as keys and fields alist as values."
(let ((entries (make-hash-table :test #'equal)))
(let ((json-array-type 'list)
(json-key-type 'symbol))
(dolist (item (json-read))
(puthash (cdr (assq 'id item))
(mapcar (pcase-lambda (`(,field . ,value))
(pcase field
((or 'author 'editor)
;; Author and editors are arrays of
;; objects, each of them designing a
;; person. These objects may contain
;; multiple properties, but for this
;; basic processor, we'll focus on
;; `given' and `family'.
;;
;; For compatibility with BibTeX, add
;; "and" between authors and editors.
(cons field
(mapconcat
(lambda (alist)
(concat (alist-get 'family alist)
" "
(alist-get 'given alist)))
value
" and ")))
('issued
;; Date are expressed as an array
;; (`date-parts') or a "string (`raw'
;; or `literal'). In both cases,
;; extract the year and associate it
;; to `year' field, for compatibility
;; with BibTeX format.
(let ((date (or (alist-get 'date-parts value)
(alist-get 'literal value)
(alist-get 'raw value))))
(cons 'year
(cond
((consp date)
(let ((year (caar date)))
(cond
((numberp year) (number-to-string year))
((stringp year) year)
(t
(error
"First element of CSL-JSON date-parts should be a number or string, got %s: %S"
(type-of year) year)))))
((stringp date)
(replace-regexp-in-string
(rx
(minimal-match (zero-or-more anything))
(group-n 1 (repeat 4 digit))
(zero-or-more anything))
(rx (backref 1))
date))
(t
(error "Unknown CSL-JSON date format: %S"
value))))))
(_
(cons field value))))
item)
entries))
entries)))
(defun org-cite-basic--parse-bibtex (dialect)
"Parse BibTeX entries in the current buffer.
DIALECT is the BibTeX dialect used. See `bibtex-dialect'.
Return a hash table with citation references as keys and fields alist as values."
(let ((entries (make-hash-table :test #'equal))
(bibtex-sort-ignore-string-entries t))
(bibtex-set-dialect dialect t)
;; Throw an error if bibliography is malformed.
(unless (bibtex-validate)
(user-error "Malformed bibliography at %S"
(or (buffer-file-name) (current-buffer))))
(bibtex-map-entries
(lambda (key &rest _)
;; Normalize entries: field names are turned into symbols
;; including special "=key=" and "=type=", and consecutive
;; white spaces are removed from values.
(puthash key
(mapcar
(pcase-lambda (`(,field . ,value))
(pcase field
("=key=" (cons 'id key))
("=type=" (cons 'type value))
(_
(cons
(intern (downcase field))
(replace-regexp-in-string "[ \t\n]+" " " value)))))
;; Parse, substituting the @string replacements.
;; See Emacs bug#56475 discussion.
(let ((bibtex-string-files `(,(buffer-file-name)))
(bibtex-expand-strings t))
(bibtex-parse-entry t)))
entries)))
entries))
(defvar org-cite-basic--file-id-cache nil
"Hash table linking files to their hash.")
(defun org-cite-basic--parse-bibliography (&optional info)
"List all entries available in the buffer.
Each association follows the pattern
(FILE . ENTRIES)
where FILE is the absolute file name of the BibTeX file, and ENTRIES is a hash
table where keys are references and values are association lists between fields,
as symbols, and values as strings or nil.
Optional argument INFO is the export state, as a property list."
(unless (hash-table-p org-cite-basic--file-id-cache)
(setq org-cite-basic--file-id-cache (make-hash-table :test #'equal)))
(if (plist-member info :cite-basic/bibliography)
(plist-get info :cite-basic/bibliography)
(let ((results nil))
(dolist (file (org-cite-list-bibliography-files))
;; Follow symlinks, to look into modification time of the
;; actual file, not its symlink.
(setq file (file-truename file))
(when (file-readable-p file)
(with-temp-buffer
(when (or (org-file-has-changed-p file)
(not (gethash file org-cite-basic--file-id-cache)))
(insert-file-contents file)
(set-visited-file-name file t)
(puthash file (org-buffer-hash) org-cite-basic--file-id-cache))
(condition-case nil
(unwind-protect
(let* ((file-id (cons file (gethash file org-cite-basic--file-id-cache)))
(entries
(or (cdr (assoc file-id org-cite-basic--bibliography-cache))
(let ((table
(pcase (file-name-extension file)
("json" (org-cite-basic--parse-json))
("bib" (org-cite-basic--parse-bibtex 'biblatex))
("bibtex" (org-cite-basic--parse-bibtex 'BibTeX))
(ext
(user-error "Unknown bibliography extension: %S"
ext)))))
(push (cons file-id table) org-cite-basic--bibliography-cache)
table))))
(push (cons file entries) results))
(set-visited-file-name nil t))
(error (setq org-cite-basic--file-id-cache nil))))))
(when info (plist-put info :cite-basic/bibliography results))
results)))
(defun org-cite-basic--key-number (key info)
"Return number associated to cited KEY.
INFO is the export state, as a property list."
(let ((predicate
(org-cite-basic--field-less-p org-cite-basic-sorting-field info)))
(org-cite-key-number key info predicate)))
(defun org-cite-basic--all-keys ()
"List all keys available in current bibliography."
(seq-mapcat (pcase-lambda (`(,_ . ,entries))
(map-keys entries))
(org-cite-basic--parse-bibliography)))
(defun org-cite-basic--get-entry (key &optional info)
"Return BibTeX entry for KEY, as an association list.
When non-nil, INFO is the export state, as a property list."
(catch :found
(pcase-dolist (`(,_ . ,entries) (org-cite-basic--parse-bibliography info))
(let ((entry (gethash key entries)))
(when entry (throw :found entry))))
nil))
(defun org-cite-basic--get-field (field entry-or-key &optional info raw)
"Return FIELD value for ENTRY-OR-KEY, or nil.
FIELD is a symbol. ENTRY-OR-KEY is either an association list, as returned by
`org-cite-basic--get-entry', or a string representing a citation key.
Optional argument INFO is the export state, as a property list.
Return value may be nil or a string. If current export backend is derived
from `latex', return a raw string object instead, unless optional
argument RAW is non-nil.
Throw an error if the field value is non-string and non-nil."
(let ((value
(cdr
(assq field
(pcase entry-or-key
((pred stringp)
(org-cite-basic--get-entry entry-or-key info))
((pred consp)
entry-or-key)
(_
(error "Wrong value for ENTRY-OR-KEY: %S" entry-or-key)))))))
(when (and value (not (stringp value)))
(error "Non-string bibliography field value: %S" value))
(if (and value
(not raw)
(org-export-derived-backend-p (plist-get info :back-end) 'latex))
(org-export-raw-string value)
value)))
(defun org-cite-basic--shorten-names (names)
"Return a list of family names from a list of full NAMES.
NAMES can be a string or raw string object.
To better accomomodate corporate names, this will only shorten
personal names of the form \"family, given\"."
(let (names-string raw-p)
(cond
((stringp names) (setq names-string names))
((org-element-type-p names 'raw)
(setq names-string (mapconcat #'identity (org-element-contents names) "")
raw-p t)))
(when names-string
(setq names-string
(mapconcat
(lambda (name)
(if (eq 1 (length name))
(cdr (split-string name))
(car (split-string name ", "))))
(split-string names-string " and ")
", "))
(if raw-p (org-export-raw-string names-string)
names-string))))
(defun org-cite-basic--number-to-suffix (n)
"Compute suffix associated to number N.
This is used for disambiguation."
(let ((result nil))
(apply #'string
(mapcar (lambda (n) (+ 97 n))
(catch :complete
(while t
(push (% n 26) result)
(setq n (/ n 26))
(cond
((= n 0) (throw :complete result))
((< n 27) (throw :complete (cons (1- n) result)))
((= n 27) (throw :complete (cons 0 (cons 0 result))))
(t nil))))))))
(defun org-cite-basic--get-author (entry-or-key &optional info raw)
"Return author associated to ENTRY-OR-KEY.
ENTRY-OR-KEY, INFO and RAW arguments are the same arguments as
used in `org-cite-basic--get-field', which see.
Author is obtained from the \"author\" field, if available, or
from the \"editor\" field otherwise."
(or (org-cite-basic--get-field 'author entry-or-key info raw)
(org-cite-basic--get-field 'editor entry-or-key info raw)))
(defun org-cite-basic--get-year (entry-or-key info &optional no-suffix)
"Return year associated to ENTRY-OR-KEY.
ENTRY-OR-KEY is either an association list, as returned by
`org-cite-basic--get-entry', or a string representing a citation
key. INFO is the export state, as a property list.
Year is obtained from the \"year\" field, if available, or from
the \"date\" field if it starts with a year pattern.
Unlike `org-cite-basic--get-field', this function disambiguates
author-year patterns by adding a letter suffix to the year when
necessary, unless optional argument NO-SUFFIX is non-nil."
;; The cache is an association list with the following structure:
;;
;; (AUTHOR-YEAR . KEY-SUFFIX-ALIST).
;;
;; AUTHOR-YEAR is the author year pair associated to current entry
;; or key.
;;
;; KEY-SUFFIX-ALIST is an association (KEY . SUFFIX), where KEY is
;; the cite key, as a string, and SUFFIX is the generated suffix
;; string, or the empty string.
(let* ((author (org-cite-basic--get-author entry-or-key info 'raw))
(year
(or (org-cite-basic--get-field 'year entry-or-key info 'raw)
(let ((date
(org-cite-basic--get-field 'date entry-or-key info 'raw)))
(and (stringp date)
(string-match (rx string-start
(group (= 4 digit))
(or string-end (not digit)))
date)
(match-string 1 date)))))
(cache-key (cons author year))
(key
(pcase entry-or-key
((pred stringp) entry-or-key)
((pred consp) (cdr (assq 'id entry-or-key)))
(_ (error "Wrong value for ENTRY-OR-KEY: %S" entry-or-key))))
(cache (plist-get info :cite-basic/author-date-cache)))
(pcase (assoc cache-key cache)
('nil
(let ((value (cons cache-key (list (cons key "")))))
(plist-put info :cite-basic/author-date-cache (cons value cache))
year))
(`(,_ . ,alist)
(let ((suffix
(or (cdr (assoc key alist))
(let ((new (org-cite-basic--number-to-suffix
(1- (length alist)))))
(push (cons key new) alist)
new))))
(if no-suffix year (concat year suffix)))))))
(defun org-cite-basic--print-bibtex-string (element &optional info)
"Print Bibtex formatted string ELEMENT, according to Bibtex syntax.
Remove all the {...} that are not a part of LaTeX macros and parse the
LaTeX fragments. Do nothing when current backend is derived from
LaTeX, according to INFO.
Return updated ELEMENT."
(if (org-export-derived-backend-p (plist-get info :back-end) 'latex)
;; Derived from LaTeX, no need to use manual ad-hoc LaTeX
;; parser.
element
;; Convert ELEMENT to anonymous when ELEMENT is string.
;; Otherwise, we cannot modify ELEMENT by side effect.
(when (org-element-type-p element 'plain-text)
(setq element (org-element-create 'anonymous nil element)))
;; Approximately parse LaTeX fragments, assuming Org mode syntax
;; (it is close to original LaTeX, and we do not want to
;; re-implement complete LaTeX parser here))
(org-element-map element t
(lambda (str)
(when (stringp str)
(org-element-set
str
(org-element-parse-secondary-string
str '(latex-fragment entity))))))
;; Strip the remaining { and }.
(org-element-map element t
(lambda (str)
(when (stringp str)
(org-element-set str (replace-regexp-in-string "[{}]" "" str)))))
element))
(defun org-cite-basic--print-entry (entry style &optional info)
"Format ENTRY according to STYLE string.
ENTRY is an alist, as returned by `org-cite-basic--get-entry'.
Optional argument INFO is the export state, as a property list."
(let ((author (org-cite-basic--get-author entry info))
(title (org-cite-basic--get-field 'title entry info))
(from
(or (org-cite-basic--get-field 'publisher entry info)
(org-cite-basic--get-field 'journal entry info)
(org-cite-basic--get-field 'institution entry info)
(org-cite-basic--get-field 'school entry info))))
(org-cite-basic--print-bibtex-string
(pcase style
("plain"
(let ((year (org-cite-basic--get-year entry info 'no-suffix)))
(org-cite-concat
(org-cite-basic--shorten-names author) ". "
title (and from (list ", " from)) ", " year ".")))
("numeric"
(let ((n (org-cite-basic--key-number (cdr (assq 'id entry)) info))
(year (org-cite-basic--get-year entry info 'no-suffix)))
(org-cite-concat
(format "[%d] " n) author ", "
(org-cite-emphasize 'italic title)
(and from (list ", " from)) ", "
year ".")))
;; Default to author-year. Use year disambiguation there.
(_
(let ((year (org-cite-basic--get-year entry info)))
(org-cite-concat
author " (" year "). "
(org-cite-emphasize 'italic title)
(and from (list ", " from)) "."))))
info)))
;;; "Activate" capability
(defun org-cite-basic--close-keys (key keys)
"List cite keys close to KEY in terms of string distance."
(seq-filter (lambda (k)
(>= org-cite-basic-max-key-distance
(org-string-distance k key)))
keys))
(defun org-cite-basic--set-keymap (beg end suggestions)
"Set keymap on citation key between BEG and END positions.
When the key is know, SUGGESTIONS is nil. Otherwise, it may be
a list of replacement keys, as strings, which will be offered as
substitutes for the unknown key. Finally, it may be the symbol
`all'."
(let ((km (make-sparse-keymap)))
(define-key km (kbd "")
(pcase suggestions
('nil #'org-open-at-point)
('all #'org-cite-insert)
(_
(lambda ()
(interactive)
(save-excursion
(goto-char beg)
(delete-region beg end)
(insert
"@"
(if (= 1 (length suggestions))
(car suggestions)
(completing-read "Did you mean: "
suggestions nil t))))))))
(put-text-property beg end 'keymap km)))
(defun org-cite-basic-activate (citation)
"Set various text properties on CITATION object.
Fontify whole citation with `org-cite' face. Fontify key with `error' face
when it does not belong to known keys. Otherwise, use `org-cite-key' face.
Moreover, when mouse is on a known key, display the corresponding bibliography.
On a wrong key, suggest a list of possible keys, and offer to substitute one of
them with a mouse click."
(pcase-let ((`(,beg . ,end) (org-cite-boundaries citation))
(keys (org-cite-basic--all-keys)))
(put-text-property beg end 'font-lock-multiline t)
(add-face-text-property beg end 'org-cite)
(dolist (reference (org-cite-get-references citation))
(pcase-let* ((`(,beg . ,end) (org-cite-key-boundaries reference))
(key (org-element-property :key reference)))
;; Highlight key on mouse over.
(put-text-property beg end
'mouse-face
org-cite-basic-mouse-over-key-face)
(if (member key keys)
;; Activate a correct key. Face is `org-cite-key' and
;; `help-echo' displays bibliography entry, for reference.
;; calls `org-open-at-point'.
(let* ((entry (org-cite-basic--get-entry key))
(bibliography-entry
(org-element-interpret-data
(org-cite-basic--print-entry entry "plain"))))
(add-face-text-property beg end 'org-cite-key)
(put-text-property beg end 'help-echo bibliography-entry)
(org-cite-basic--set-keymap beg end nil))
;; Activate a wrong key. Face is `error', `help-echo'
;; displays possible suggestions.
(add-face-text-property beg end 'error)
(let ((close-keys (org-cite-basic--close-keys key keys)))
(when close-keys
(put-text-property beg end 'help-echo
(concat "Suggestions (mouse-1 to substitute): "
(mapconcat #'identity close-keys " "))))
;; When the are close know keys, provides
;; completion to fix the current one. Otherwise, call
;; `org-cite-insert'.
(org-cite-basic--set-keymap beg end (or close-keys 'all))))))))
;;; "Export" capability
(defun org-cite-basic--format-author-year (citation format-cite format-ref info)
"Format CITATION object according to author-year format.
FORMAT-CITE is a function of three arguments: the global prefix, the contents,
and the global suffix. All arguments can be strings or secondary strings.
FORMAT-REF is a function of four arguments: the reference prefix, as a string or
secondary string, the author, the year, and the reference suffix, as a string or
secondary string.
INFO is the export state, as a property list."
(org-export-data
(funcall format-cite
(org-element-property :prefix citation)
(org-cite-mapconcat
(lambda (ref)
(let ((k (org-element-property :key ref))
(prefix (org-element-property :prefix ref))
(suffix (org-element-property :suffix ref)))
(funcall format-ref
prefix
(or (org-cite-basic--get-author k info) "??")
(or (org-cite-basic--get-year k info) "????")
suffix)))
(org-cite-get-references citation)
org-cite-basic-author-year-separator)
(org-element-property :suffix citation))
info))
(defun org-cite-basic--citation-numbers (citation info)
"Return numbers associated to references in CITATION object.
INFO is the export state as a property list."
(let* ((numbers
(sort (mapcar (lambda (k) (org-cite-basic--key-number k info))
(org-cite-get-references citation t))
#'<))
(last (car numbers))
(result (list (number-to-string (pop numbers)))))
;; Use compact number references, i.e., "1, 2, 3" becomes "1-3".
(while numbers
(let ((current (pop numbers))
(next (car numbers)))
(cond
((and next
(= current (1+ last))
(= current (1- next)))
(unless (equal "-" (car result))
(push "-" result)))
((equal "-" (car result))
(push (number-to-string current) result))
(t
(push (format ", %d" current) result)))
(setq last current)))
(apply #'concat (nreverse result))))
(defun org-cite-basic--field-less-p (field info)
"Return a sort predicate comparing FIELD values for two citation keys.
INFO is the export state, as a property list."
(and field
(lambda (a b)
(org-string<
(org-cite-basic--get-field field a info 'raw)
(org-cite-basic--get-field field b info 'raw)
nil t))))
(defun org-cite-basic--sort-keys (keys info)
"Sort KEYS by author name.
INFO is the export communication channel, as a property list."
(let ((predicate (org-cite-basic--field-less-p org-cite-basic-sorting-field info)))
(if predicate
(sort keys predicate)
keys)))
(defun org-cite-basic-export-citation (citation style _ info)
"Export CITATION object.
STYLE is the expected citation style, as a pair of strings or nil. INFO is the
export communication channel, as a property list."
(let ((has-variant-p
(lambda (variant type)
;; Non-nil when style VARIANT has TYPE. TYPE is either
;; `bare' or `caps'.
(member variant
(pcase type
('bare '("bare" "bare-caps" "b" "bc"))
('caps '("caps" "bare-caps" "c" "bc"))
(_ (error "Invalid variant type: %S" type)))))))
(pcase style
;; "author" style.
(`(,(or "author" "a") . ,variant)
(let ((caps (member variant '("caps" "c"))))
(org-cite-basic--format-author-year
citation
(lambda (p c s) (org-cite-concat p c s))
(lambda (prefix author _ suffix)
(org-cite-concat
prefix
(if caps (org-cite-capitalize author) author)
suffix))
info)))
;; "noauthor" style.
(`(,(or "noauthor" "na") . ,variant)
(let ((bare? (funcall has-variant-p variant 'bare)))
(org-cite-basic--format-author-year
citation
(lambda (prefix contents suffix)
(org-cite-concat
(unless bare? "(")
prefix
contents
suffix
(unless bare? ")")))
(lambda (prefix _ year suffix)
(org-cite-concat prefix year suffix))
info)))
;; "nocite" style.
(`(,(or "nocite" "n") . ,_) nil)
;; "text" and "note" styles.
(`(,(and (or "text" "note" "t" "ft") style) . ,variant)
(when (and (member style '("note" "ft"))
(not (org-cite-inside-footnote-p citation)))
(org-cite-adjust-note citation info)
(org-cite-wrap-citation citation info))
(let ((bare (funcall has-variant-p variant 'bare))
(caps (funcall has-variant-p variant 'caps)))
(org-cite-basic--format-author-year
citation
(lambda (p c s) (org-cite-concat p c s))
(lambda (p a y s)
(org-cite-concat p
(if caps (org-cite-capitalize a) a)
(if bare " " " (")
y
(and (not bare) ")")
s))
info)))
;; "numeric" style.
;;
;; When using this style on citations with multiple references,
;; use global affixes and ignore local ones.
(`(,(or "numeric" "nb") . ,_)
(pcase-let ((`(,prefix . ,suffix) (org-cite-main-affixes citation)))
(org-export-data
(org-cite-concat
"(" prefix (org-cite-basic--citation-numbers citation info) suffix ")")
info)))
;; Default ("nil") style.
(`(,_ . ,variant)
(let ((bare (funcall has-variant-p variant 'bare))
(caps (funcall has-variant-p variant 'caps)))
(org-cite-basic--format-author-year
citation
(lambda (p c s)
(org-cite-concat (and (not bare) "(") p c s (and (not bare) ")")))
(lambda (p a y s)
(org-cite-concat p (if caps (org-cite-capitalize a) a) ", " y s))
info)))
;; This should not happen.
(_ (error "Invalid style: %S" style)))))
(defun org-cite-basic-export-bibliography (keys _files style _props backend info)
"Generate bibliography.
KEYS is the list of cited keys, as strings. STYLE is the expected bibliography
style, as a string. BACKEND is the export backend, as a symbol. INFO is the
export state, as a property list."
(mapconcat
(lambda (entry)
(org-export-data
(org-cite-make-paragraph
(and (org-export-derived-backend-p backend 'latex)
(org-export-raw-string "\\noindent\n"))
(org-cite-basic--print-entry entry style info))
info))
(delq nil
(mapcar
(lambda (k) (org-cite-basic--get-entry k info))
(org-cite-basic--sort-keys keys info)))
"\n"))
;;; "Follow" capability
(defun org-cite-basic-goto (datum _)
"Follow citation or citation reference DATUM.
When DATUM is a citation reference, open bibliography entry referencing
the citation key. Otherwise, select which key to follow among all keys
present in the citation."
(let* ((key
(if (org-element-type-p datum 'citation-reference)
(org-element-property :key datum)
(pcase (org-cite-get-references datum t)
(`(,key) key)
(keys
(or (completing-read "Select citation key: " keys nil t)
(user-error "Aborted"))))))
(file
(pcase (seq-find (pcase-lambda (`(,_ . ,entries))
(gethash key entries))
(org-cite-basic--parse-bibliography))
(`(,f . ,_) f)
(_ (user-error "Cannot find citation key: %S" key)))))
(org-open-file file '(4))
(pcase (file-name-extension file)
("json"
;; `rx' can not be used with Emacs <27.1 since `literal' form
;; is not supported.
(let ((regexp (rx-to-string `(seq "\"id\":" (0+ (any "[ \t]")) "\"" ,key "\"") t)))
(goto-char (point-min))
(re-search-forward regexp)
(search-backward "{")))
(_
(bibtex-set-dialect)
(bibtex-search-entry key)))))
;;; "Insert" capability
(defun org-cite-basic--complete-style (_)
"Offer completion for style.
Return chosen style as a string."
(let* ((styles
(mapcar (pcase-lambda (`((,style . ,_) . ,_))
style)
(org-cite-supported-styles))))
(pcase styles
(`(,style) style)
(_ (completing-read "Style (\"\" for default): " styles nil t)))))
(defun org-cite-basic--key-completion-table ()
"Return completion table for cite keys, as a hash table.
In this hash table, keys are a strings with author, date, and
title of the reference. Values are the cite keys.
Return nil if there are no bibliography files or no entries."
;; Populate bibliography cache.
(let ((entries (org-cite-basic--parse-bibliography)))
(cond
((null entries) nil) ;no bibliography files
((gethash entries org-cite-basic--completion-cache)
org-cite-basic--completion-cache)
(t
(clrhash org-cite-basic--completion-cache)
(dolist (key (org-cite-basic--all-keys))
(let* ((entry (org-cite-basic--get-entry
key
;; Supply pre-calculated bibliography to avoid
;; performance degradation.
(list :cite-basic/bibliography entries)))
(completion
(concat
(let ((author (org-cite-basic--get-author entry nil 'raw)))
(if author
(truncate-string-to-width
(replace-regexp-in-string " and " "; " author)
org-cite-basic-author-column-end nil ?\s)
(make-string org-cite-basic-author-column-end ?\s)))
org-cite-basic-column-separator
(let ((date (org-cite-basic--get-year entry nil 'no-suffix)))
(format "%4s" (or date "")))
org-cite-basic-column-separator
(org-cite-basic--get-field 'title entry nil 'raw))))
(puthash completion key org-cite-basic--completion-cache)))
(unless (map-empty-p org-cite-basic--completion-cache) ;no key
(puthash entries t org-cite-basic--completion-cache)
org-cite-basic--completion-cache)))))
(defun org-cite-basic--complete-key (&optional multiple)
"Prompt for a reference key and return a citation reference string.
When optional argument MULTIPLE is non-nil, prompt for multiple
keys, until one of them is nil. Then return the list of
reference strings selected.
Raise an error when no bibliography is set in the buffer."
(let* ((table
(or (org-cite-basic--key-completion-table)
(user-error "No bibliography set")))
(prompt
(lambda (text)
(completing-read text table nil t))))
(if (null multiple)
(let ((key (gethash (funcall prompt "Key: ") table)))
(org-string-nw-p key))
(let* ((keys nil)
(build-prompt
(lambda ()
(if keys
(format "Key (empty input exits) %s: "
(mapconcat #'identity (reverse keys) ";"))
"Key (empty input exits): "))))
(let ((key (funcall prompt (funcall build-prompt))))
(while (org-string-nw-p key)
(push (gethash key table) keys)
(setq key (funcall prompt (funcall build-prompt)))))
keys))))
;;; Register processor
(org-cite-register-processor 'basic
:activate #'org-cite-basic-activate
:export-citation #'org-cite-basic-export-citation
:export-bibliography #'org-cite-basic-export-bibliography
:follow #'org-cite-basic-goto
:insert (org-cite-make-insert-processor #'org-cite-basic--complete-key
#'org-cite-basic--complete-style)
:cite-styles
'((("author" "a") ("caps" "c"))
(("noauthor" "na") ("bare" "b"))
(("nocite" "n"))
(("note" "ft") ("bare-caps" "bc") ("caps" "c"))
(("numeric" "nb"))
(("text" "t") ("bare-caps" "bc") ("caps" "c"))
(("nil") ("bare" "b") ("bare-caps" "bc") ("caps" "c"))))
(provide 'oc-basic)
;;; oc-basic.el ends here
org-mode-9.7.29+dfsg/lisp/oc-biblatex.el 0000664 0000000 0000000 00000043677 15004304337 0017754 0 ustar 00root root 0000000 0000000 ;;; oc-biblatex.el --- biblatex citation processor for Org -*- lexical-binding: t; -*-
;; Copyright (C) 2021-2025 Free Software Foundation, Inc.
;; Author: Nicolas Goaziou
;; 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
;; 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
;; Maintainer: András Simonyi
;; 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 ). Dependent styles (which are not "unique"
;; in the Zotero Style Repository terminology) are not supported.
;; The processor uses the "en-US" CSL locale file shipped with Org for rendering
;; localized dates and terms in the references, independently of the language
;; settings of the Org document. Additional CSL locales can be made available
;; by setting `org-cite-csl-locales-dir' to a directory containing the locale
;; files in question (see
;; for such files).
;; Bibliography is defined with the "bibliography" keyword. It supports files
;; with ".bib", ".bibtex", and ".json" extensions. References are exported using
;; the "print_bibliography" keyword.
;; The library supports the following citation styles:
;;
;; - author (a), including bare (b), caps (c), bare-caps (bc), full (f),
;; caps-full (cf), and bare-caps-full (bcf) variants,
;; - noauthor (na), including bare (b), caps (c) and bare-caps (bc) variants,
;; - nocite (n),
;; - year (y), including a bare (b) variant,
;; - text (t), including caps (c), full (f), and caps-full (cf) variants,
;; - title (ti), including a bare (b) variant,
;; - locators (l), including a bare (b) variant,
;; - bibentry (b), including a bare (b) variant,
;; - default style, including bare (b), caps (c) and bare-caps (bc) variants.
;;
;; Using "*" as a key in a nocite citation includes all available
;; items in the printed bibliography. The "bibentry" citation style,
;; similarly to biblatex's \fullcite, creates a citation which is
;; similar to the bibliography entry.
;; CSL styles recognize "locator" in citation references' suffix. For example,
;; in the citation
;;
;; [cite:see @Tarski-1965 chapter 1, for an example]
;;
;; "chapter 1" is the locator. The whole citation is rendered as
;;
;; (see Tarski 1965, chap. 1 for an example)
;;
;; in the default CSL style.
;;
;; The locator starts with a locator term, among "bk.", "bks.", "book", "chap.",
;; "chaps.", "chapter", "col.", "cols.", "column", "figure", "fig.", "figs.",
;; "folio", "fol.", "fols.", "number", "no.", "nos.", "line", "l.", "ll.",
;; "note", "n.", "nn.", "opus", "op.", "opp.", "page", "p.", "pp.", "paragraph",
;; "para.", "paras.", "¶", "¶¶", "§", "§§", "part", "pt.", "pts.", "section",
;; "sec.", "secs.", "sub verbo", "s.v.", "s.vv.", "verse", "v.", "vv.",
;; "volume", "vol.", and "vols.". It ends with the last comma or digit in the
;; suffix, whichever comes last, or runs till the end of the suffix.
;;
;; The part of the suffix before the locator is appended to reference's prefix.
;; If no locator term is used, but a number is present, then "page" is assumed.
;; Filtered sub-bibliographies can be printed by passing filtering
;; options to the "print_bibliography" keywords. E.g.,
;;
;; #+print_bibliography: :type book keyword: emacs
;;
;; If you need to use a key multiple times, you can separate its
;; values with commas, but without any space in-between:
;;
;; #+print_bibliography: :keyword abc,xyz :type article
;; This library was heavily inspired by and borrows from András Simonyi's
;; Citeproc Org () library.
;; Many thanks to him!
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'cl-lib)
(require 'map)
(require 'bibtex)
(require 'json)
(require 'oc)
(require 'citeproc nil t)
(declare-function citeproc-style-cite-note "ext:citeproc")
(declare-function citeproc-proc-style "ext:citeproc")
(declare-function citeproc-bt-entry-to-csl "ext:citeproc")
(declare-function citeproc-locale-getter-from-dir "ext:citeproc")
(declare-function citeproc-create "ext:citeproc")
(declare-function citeproc-citation-create "ext:citeproc")
(declare-function citeproc-append-citations "ext:citeproc")
(declare-function citeproc-add-uncited "ext:citeproc")
(declare-function citeproc-render-citations "ext:citeproc")
(declare-function citeproc-render-bib "ext:citeproc")
(declare-function citeproc-hash-itemgetter-from-any "ext:citeproc")
(declare-function citeproc-add-subbib-filters "ext:citeproc")
(declare-function citeproc-style-cite-superscript-p "ext:citeproc")
(declare-function org-element-interpret-data "org-element" (data))
(declare-function org-element-map "org-element" (data types fun &optional info first-match no-recursion with-affiliated))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-put-property "org-element-ast" (node property value))
(declare-function org-export-data "org-export" (data info))
(declare-function org-export-derived-backend-p "org-export" (backend &rest backends))
(declare-function org-export-get-footnote-number "org-export" (footnote info &optional data body-first))
;;; Customization
;;;; Location of CSL directories
(defcustom org-cite-csl-locales-dir nil
"Directory of CSL locale files.
If nil then only the fallback en-US locale will be available."
:group 'org-cite
:package-version '(Org . "9.5")
:type '(choice
(directory :tag "Locales directory")
(const :tag "Use en-US locale only" nil))
;; It's not obvious to me that arbitrary locations are safe.
;;; :safe #'string-or-null-p
)
(defcustom org-cite-csl-styles-dir nil
"Directory of CSL style files.
Relative style file names are expanded according to document's
default directory. If it fails and the variable is non-nil, Org
looks for style files in this directory, too."
:group 'org-cite
:package-version '(Org . "9.5")
:type '(choice
(directory :tag "Styles directory")
(const :tag "No central directory for style files" nil))
;; It's not obvious to me that arbitrary locations are safe.
;;; :safe #'string-or-null-p
)
;;;; Citelinks
(defcustom org-cite-csl-link-cites t
"When non-nil, link cites to references."
:group 'org-cite
:package-version '(Org . "9.5")
:type 'boolean
:safe #'booleanp)
(defcustom org-cite-csl-no-citelinks-backends '(ascii)
"List of export backends for which cite linking is disabled.
Cite linking for export backends derived from any of the backends listed here,
is also disabled."
:group 'org-cite
:package-version '(Org . "9.5")
:type '(repeat symbol))
;;;; Output-specific variables
(defcustom org-cite-csl-html-hanging-indent "1.5em"
"Size of hanging-indent for HTML output in valid CSS units."
:group 'org-cite
:package-version '(Org . "9.5")
:type 'string
:safe #'stringp)
(defcustom org-cite-csl-html-label-width-per-char "0.6em"
"Character width in CSS units for calculating entry label widths.
Used only when `second-field-align' is activated by the used CSL style."
:group 'org-cite
:package-version '(Org . "9.5")
:type 'string
:safe #'stringp)
(defcustom org-cite-csl-latex-hanging-indent "1.5em"
"Size of hanging-indent for LaTeX output in valid LaTeX units."
:group 'org-cite
:package-version '(Org . "9.5")
:type 'string
:safe #'stringp)
(defcustom org-cite-csl-latex-label-separator "0.6em"
"Distance between citation label and bibliography item for LaTeX output.
The value is a string representing the distance in valid LaTeX units.
Used only when `second-field-align' is activated by the used CSL
style.
The indentation length in these cases is computed as the sum of
`org-cite-csl-latex-label-separator' and the maximal label width, for
example,
indentation length
<------------------------->
max. label width separator
<---------------><-------->
[Doe22] John Doe. A title...
[DoeSmithJones19] John Doe, Jane Smith and...
[SmithDoe02] Jane Smith and John Doe...
The maximal label width, in turn, is calculated as the product of
`org-cite-csl-latex-label-width-per-char' and the maximal label
length measured in characters."
:group 'org-cite
:package-version '(Org . "9.7")
:type 'string
:safe #'stringp)
(defcustom org-cite-csl-latex-label-width-per-char "0.45em"
"Character width in LaTeX units for calculating entry label widths.
Used only when `second-field-align' is activated by the used CSL
style.
See the documentation of `org-cite-csl-latex-label-separator' for
details."
:group 'org-cite
:package-version '(Org . "9.7")
:type 'string
:safe #'stringp)
;; The following was inspired by and in many details follows how
;; Pandoc's () default LaTeX template
;; handles CSL output. Many thanks to the author, John MacFarlane!
(defcustom org-cite-csl-latex-preamble
"\\usepackage{calc}
\\newlength{\\cslhangindent}
\\setlength{\\cslhangindent}{[CSL-HANGINDENT]}
\\newlength{\\csllabelsep}
\\setlength{\\csllabelsep}{[CSL-LABELSEP]}
\\newlength{\\csllabelwidth}
\\setlength{\\csllabelwidth}{[CSL-LABELWIDTH-PER-CHAR] * [CSL-MAXLABEL-CHARS]}
\\newenvironment{cslbibliography}[2] % 1st arg. is hanging-indent, 2nd entry spacing.
{% By default, paragraphs are not indented.
\\setlength{\\parindent}{0pt}
% Hanging indent is turned on when first argument is 1.
\\ifodd #1
\\let\\oldpar\\par
\\def\\par{\\hangindent=\\cslhangindent\\oldpar}
\\fi
% Set entry spacing based on the second argument.
\\setlength{\\parskip}{\\parskip + #2\\baselineskip}
}%
{}
\\newcommand{\\cslblock}[1]{#1\\hfill\\break}
\\newcommand{\\cslleftmargin}[1]{\\parbox[t]{\\csllabelsep + \\csllabelwidth}{#1}}
\\newcommand{\\cslrightinline}[1]
{\\parbox[t]{\\linewidth - \\csllabelsep - \\csllabelwidth}{#1}\\break}
\\newcommand{\\cslindent}[1]{\\hspace{\\cslhangindent}#1}
\\newcommand{\\cslbibitem}[2]
{\\leavevmode\\vadjust pre{\\hypertarget{citeproc_bib_item_#1}{}}#2}
\\makeatletter
\\newcommand{\\cslcitation}[2]
{\\protect\\hyper@linkstart{cite}{citeproc_bib_item_#1}#2\\hyper@linkend}
\\makeatother"
"LaTeX preamble content inserted by the `csl' citation processor.
This preamble can be anything as long as it provides definitions
for the environment and commands that Citeproc's `org-latex'
formatter uses for formatting citations and bibliographies. In
particular, it has to define
- the commands \\cslblock{}, \\cslleftmargin{},
\\cslrightinline{} and \\cslindent{} for formatting
text that have, respectively, the CSL display attributes
`block', `left-margin', `right-inline' and `indent';
- the commands \\cslcitation{}{} and
\\cslbibitem{}{}, which are used to
format individual citations and bibliography items, including
hyperlinking citations to the corresponding bibliography entry
using their numerical id, which is passed as the first,
argument;
- and the environment \\cslbibliography{}{},
in which bibliographies are wrapped; the value of the
argument is 1 if hanging indent should be
applied and 0 if not, while the argument is an
integer specifying the number of extra line-heights
required between bibliography entries in addition to normal
line spacing.
When present, the placeholders [CSL-HANGINDENT], [CSL-LABELSEP],
[CSL-LABELWIDTH-PER-CHAR] and [CSL-MAXLABEL-CHARS] are replaced,
respectively, by the contents of the customizable variables
`org-cite-csl-latex-hanging-indent', `org-cite-csl-latex-label-separator',
`org-cite-csl-latex-label-width-per-char', and the maximal label length
in the bibliography measured in characters."
:group 'org-cite
:type 'string
:package-version '(Org . "9.7"))
;;; Internal variables
(defconst org-cite-csl--etc-dir
(let ((oc-root (file-name-directory (locate-library "oc"))))
(cond
;; First check whether it looks like we're running from the main
;; Org repository.
((let ((csl-org (expand-file-name "../etc/csl/" oc-root)))
(and (file-directory-p csl-org) csl-org)))
;; Next look for the directory alongside oc.el because package.el
;; and straight will put all of org-mode/lisp/ in org-mode/.
((let ((csl-pkg (expand-file-name "etc/csl/" oc-root)))
(and (file-directory-p csl-pkg) csl-pkg)))
;; Finally fall back the location used by shared system installs
;; and when running directly from Emacs repository.
(t
(expand-file-name "org/csl/" data-directory))))
"Directory containing CSL-related data files.")
(defconst org-cite-csl--fallback-locales-dir org-cite-csl--etc-dir
"Fallback CSL locale files directory.")
(defconst org-cite-csl--fallback-style-file
(expand-file-name "chicago-author-date.csl"
org-cite-csl--etc-dir)
"Default CSL style file, or nil.
If nil then the Chicago author-date style is used as a fallback.")
(defconst org-cite-csl--label-alist
'(("bk." . "book")
("bks." . "book")
("book" . "book")
("chap." . "chapter")
("chaps." . "chapter")
("chapter" . "chapter")
("col." . "column")
("cols." . "column")
("column" . "column")
("figure" . "figure")
("fig." . "figure")
("figs." . "figure")
("folio" . "folio")
("fol." . "folio")
("fols." . "folio")
("number" . "number")
("no." . "number")
("nos." . "number")
("line" . "line")
("l." . "line")
("ll." . "line")
("note" . "note")
("n." . "note")
("nn." . "note")
("opus" . "opus")
("op." . "opus")
("opp." . "opus")
("page" . "page")
("p" . "page")
("p." . "page")
("pp." . "page")
("paragraph" . "paragraph")
("para." . "paragraph")
("paras." . "paragraph")
("\\P" . "paragraph")
("¶" . "paragraph")
("\\P\\P" . "paragraph")
("¶¶" . "paragraph")
("part" . "part")
("pt." . "part")
("pts." . "part")
("§" . "section")
("\\S" . "section")
("§§" . "section")
("\\S\\S" . "section")
("section" . "section")
("sec." . "section")
("secs." . "section")
("sub verbo" . "sub verbo")
("s.v." . "sub verbo")
("s.vv." . "sub verbo")
("verse" . "verse")
("v." . "verse")
("vv." . "verse")
("volume" . "volume")
("vol." . "volume")
("vols." . "volume"))
"Alist mapping locator names to locators.")
(defconst org-cite-csl--label-regexp
;; Prior to Emacs-27.1 argument of `regexp' form must be a string literal.
;; It is the reason why `rx' is avoided here.
(rx-to-string
`(seq (or line-start space)
(regexp ,(regexp-opt (mapcar #'car org-cite-csl--label-alist) t))
(0+ digit)
(or word-end line-end space " "))
t)
"Regexp matching a label in a citation reference suffix.
Label is in match group 1.")
;;; Internal functions
(defun org-cite-csl--note-style-p (info)
"Non-nil when bibliography style implies wrapping citations in footnotes.
INFO is the export state, as a property list."
(citeproc-style-cite-note
(citeproc-proc-style
(org-cite-csl--processor info))))
(defun org-cite-csl--style-cite-superscript-p (info)
"Non-nil when bibliography style produces citations in superscript.
INFO is the export state, as a property list."
(citeproc-style-cite-superscript-p
(citeproc-proc-style
(org-cite-csl--processor info))))
(defun org-cite-csl--nocite-p (citation info)
"Non-nil when CITATION object's style is nocite.
INFO is the export state, as a property list."
(member (car (org-cite-citation-style citation info))
'("nocite" "n")))
(defun org-cite-csl--create-structure-params (citation info)
"Return citeproc structure creation params for CITATION object.
STYLE is the citation style, as a string or nil. INFO is the export
state, as a property list."
(let ((style (org-cite-citation-style citation info)))
(pcase style
;; "author" style.
(`(,(or "author" "a") . ,variant)
(pcase variant
((or "bare" "b") '(:mode author-only :suppress-affixes t))
((or "caps" "c") '(:mode author-only :capitalize-first t))
((or "full" "f") '(:mode author-only :ignore-et-al t))
((or "bare-caps" "bc") '(:mode author-only :suppress-affixes t :capitalize-first t))
((or "bare-full" "bf") '(:mode author-only :suppress-affixes t :ignore-et-al t))
((or "caps-full" "cf") '(:mode author-only :capitalize-first t :ignore-et-al t))
((or "bare-caps-full" "bcf") '(:mode author-only :suppress-affixes t :capitalize-first t :ignore-et-al t))
(_ '(:mode author-only))))
;; "noauthor" style.
(`(,(or "noauthor" "na") . ,variant)
(pcase variant
((or "bare" "b") '(:mode suppress-author :suppress-affixes t))
((or "caps" "c") '(:mode suppress-author :capitalize-first t))
((or "bare-caps" "bc")
'(:mode suppress-author :suppress-affixes t :capitalize-first t))
(_ '(:mode suppress-author))))
;; "year" style.
(`(,(or "year" "y") . ,variant)
(pcase variant
((or "bare" "b") '(:mode year-only :suppress-affixes t))
(_ '(:mode year-only))))
;; "bibentry" style.
(`(,(or "bibentry" "b") . ,variant)
(pcase variant
((or "bare" "b") '(:mode bib-entry :suppress-affixes t))
(_ '(:mode bib-entry))))
;; "locators" style.
(`(,(or "locators" "l") . ,variant)
(pcase variant
((or "bare" "b") '(:mode locator-only :suppress-affixes t))
(_ '(:mode locator-only))))
;; "title" style.
(`(,(or "title" "ti") . ,variant)
(pcase variant
((or "bare" "b") '(:mode title-only :suppress-affixes t))
(_ '(:mode title-only))))
;; "text" style.
(`(,(or "text" "t") . ,variant)
(pcase variant
((or "caps" "c") '(:mode textual :capitalize-first t))
((or "full" "f") '(:mode textual :ignore-et-al t))
((or "caps-full" "cf") '(:mode textual :ignore-et-al t :capitalize-first t))
(_ '(:mode textual))))
;; Default "nil" style.
(`(,_ . ,variant)
(pcase variant
((or "caps" "c") '(:capitalize-first t))
((or "bare" "b") '(:suppress-affixes t))
((or "bare-caps" "bc") '(:suppress-affixes t :capitalize-first t))
(_ nil)))
;; This should not happen.
(_ (error "Invalid style: %S" style)))))
(defun org-cite-csl--no-citelinks-p (info)
"Non-nil when export backend should not create cite-reference links.
INFO is the info channel plist."
(or (not org-cite-csl-link-cites)
(and org-cite-csl-no-citelinks-backends
(apply #'org-export-derived-backend-p
(plist-get info :back-end)
org-cite-csl-no-citelinks-backends))
;; No references are being exported anyway.
(not (org-element-map (plist-get info :parse-tree) 'keyword
(lambda (k)
(equal "PRINT_BIBLIOGRAPHY" (org-element-property :key k)))
info t))))
(defun org-cite-csl--output-format (info)
"Return expected Citeproc's output format.
INFO is the export state, as a property list. The return value is a symbol
corresponding to one of the output formats supported by Citeproc: `html',
`latex', or `org'."
(let ((backend (plist-get info :back-end)))
(cond
((org-export-derived-backend-p backend 'html) 'html)
((org-export-derived-backend-p backend 'latex) 'org-latex)
(t 'org))))
(defun org-cite-csl--style-file (info)
"Return style file associated to current export process.
INFO is the export state, as a property list.
When file name is relative, look for it in buffer's default
directory, failing that in `org-cite-csl-styles-dir' if non-nil.
Raise an error if no style file can be found."
(pcase (org-cite-bibliography-style info)
('nil org-cite-csl--fallback-style-file)
((and (pred file-name-absolute-p) file) file)
((and (pred file-exists-p) file) (expand-file-name file))
((and (guard org-cite-csl-styles-dir)
(pred (lambda (f)
(file-exists-p
(expand-file-name f org-cite-csl-styles-dir))))
file)
(expand-file-name file org-cite-csl-styles-dir))
(other
(user-error "CSL style file not found: %S" other))))
(defun org-cite-csl--locale-getter ()
"Return a locale getter.
The getter looks for locales in `org-cite-csl-locales-dir' directory. If it
cannot find them, it retrieves the default \"en_US\" from
`org-cite-csl--fallback-locales-dir'."
(lambda (loc)
(or (and org-cite-csl-locales-dir
(ignore-errors
(funcall (citeproc-locale-getter-from-dir org-cite-csl-locales-dir)
loc)))
(funcall (citeproc-locale-getter-from-dir
org-cite-csl--fallback-locales-dir)
loc))))
(defun org-cite-csl--processor (info)
"Return Citeproc processor reading items from current bibliography.
INFO is the export state, as a property list.
Newly created processor is stored as the value of the `:cite-citeproc-processor'
property in INFO."
(or (plist-get info :cite-citeproc-processor)
(let* ((bibliography (plist-get info :bibliography))
(locale (or (plist-get info :language) "en_US"))
(processor
(citeproc-create
(org-cite-csl--style-file info)
(citeproc-hash-itemgetter-from-any bibliography)
(org-cite-csl--locale-getter)
locale)))
(plist-put info :cite-citeproc-processor processor)
processor)))
(defun org-cite-csl--parse-reference (reference info)
"Return Citeproc's structure associated to citation REFERENCE.
INFO is the export state, as a property list.
The result is a association list. Keys are: `id', `prefix',`suffix',
`location', `locator' and `label'."
(let (label location-start locator-start location locator prefix suffix)
;; Parse suffix. Insert it in a temporary buffer to find
;; different parts: pre-label, label, locator, location (label +
;; locator), and suffix.
(with-temp-buffer
(save-excursion
(insert (org-element-interpret-data
(org-element-property :suffix reference))))
(cond
((re-search-forward org-cite-csl--label-regexp nil t)
(setq location-start (match-beginning 0))
(setq label (cdr (assoc (match-string 1) org-cite-csl--label-alist)))
(goto-char (match-end 1))
(skip-chars-forward "[:space:] ")
(setq locator-start (point)))
((re-search-forward (rx digit) nil t)
(setq location-start (match-beginning 0))
(setq label "page")
(setq locator-start location-start))
(t
(setq suffix (org-element-property :suffix reference))))
;; Find locator's end, and suffix, if any. To that effect, look
;; for the last comma or digit after label, whichever comes
;; last.
(unless suffix
(goto-char (point-max))
(let ((re (rx (or "," (group digit)))))
(when (re-search-backward re location-start t)
(goto-char (or (match-end 1) (match-beginning 0)))
(setq location (buffer-substring location-start (point)))
(setq locator (org-trim (buffer-substring locator-start (point))))
;; Skip comma in suffix.
(setq suffix
(org-cite-parse-objects
(buffer-substring (match-end 0) (point-max))
t)))))
(setq prefix
(org-cite-concat
(org-element-property :prefix reference)
(and location-start
(org-cite-parse-objects
(buffer-substring 1 location-start)
t)))))
;; Return value.
(let ((export
(lambda (data)
(org-string-nw-p
(org-trim
;; When Citeproc exports to Org syntax, avoid mix and
;; matching output formats by also generating Org
;; syntax for prefix and suffix.
(if (eq 'org (org-cite-csl--output-format info))
(org-element-interpret-data data)
(org-export-data data info)))))))
`((id . ,(org-element-property :key reference))
(prefix . ,(funcall export prefix))
(suffix . ,(funcall export suffix))
(locator . ,locator)
(label . ,label)
(location . ,location)))))
(defun org-cite-csl--create-structure (citation info)
"Create Citeproc structure for CITATION object.
INFO is the export state, as a property list."
(let* ((cites (mapcar (lambda (r)
(org-cite-csl--parse-reference r info))
(org-cite-get-references citation)))
(footnote (org-cite-inside-footnote-p citation)))
;; Global prefix is inserted in front of the prefix of the first
;; reference.
(let ((global-prefix (org-element-property :prefix citation)))
(when global-prefix
(let* ((first (car cites))
(prefix-item (assq 'prefix first)))
(setcdr prefix-item
(concat (org-element-interpret-data global-prefix)
" "
(cdr prefix-item))))))
;; Global suffix is appended to the suffix of the last reference.
(let ((global-suffix (org-element-property :suffix citation)))
(when global-suffix
(let* ((last (org-last cites))
(suffix-item (assq 'suffix last)))
(setcdr suffix-item
(concat (cdr suffix-item)
" "
(org-element-interpret-data global-suffix))))))
;; Check if CITATION needs wrapping, i.e., it should be wrapped in
;; a footnote, but isn't yet.
(when (and (not footnote) (org-cite-csl--note-style-p info))
(org-cite-adjust-note citation info)
(setq footnote (org-cite-wrap-citation citation info)))
;; Remove white space before CITATION when it is in superscript.
(when (org-cite-csl--style-cite-superscript-p info)
(org-cite--set-previous-post-blank citation 0 info))
;; Return structure.
(apply #'citeproc-citation-create
`(:note-index
,(and footnote (org-export-get-footnote-number footnote info))
:cites ,cites
,@(org-cite-csl--create-structure-params citation info)))))
(defun org-cite-csl--rendered-citations (info)
"Return the rendered citations as an association list.
INFO is the export state, as a property list.
Return an alist (CITATION . OUTPUT) where CITATION object has been rendered as
OUTPUT using Citeproc."
(or (plist-get info :cite-citeproc-rendered-citations)
(let ((citations (org-cite-list-citations info))
(processor (org-cite-csl--processor info))
normal-citations nocite-ids)
(dolist (citation citations)
(if (org-cite-csl--nocite-p citation info)
(setq nocite-ids (append (org-cite-get-references citation t) nocite-ids))
(push citation normal-citations)))
(let ((structures
(mapcar (lambda (c) (org-cite-csl--create-structure c info))
(nreverse normal-citations))))
(citeproc-append-citations structures processor))
(when nocite-ids
(citeproc-add-uncited nocite-ids processor))
;; All bibliographies have to be rendered in order to have
;; correct citation numbers even if there are several
;; sub-bibliograhies.
(org-cite-csl--rendered-bibliographies info)
(let (result
(rendered (citeproc-render-citations
processor
(org-cite-csl--output-format info)
(org-cite-csl--no-citelinks-p info))))
(dolist (citation citations)
(push (cons citation
(if (org-cite-csl--nocite-p citation info) "" (pop rendered)))
result))
(setq result (nreverse result))
(plist-put info :cite-citeproc-rendered-citations result)
result))))
(defun org-cite-csl--bibliography-filter (bib-props)
"Return the sub-bibliography filter corresponding to bibliography properties.
BIB-PROPS should be a plist representing the properties
associated with a \"print_bibliography\" keyword, as returned by
`org-cite-bibliography-properties'."
(let (result
(remove-keyword-colon (lambda (x) (intern (substring (symbol-name x) 1)))))
(map-do
(lambda (key value)
(pcase key
((or :keyword :notkeyword :nottype :notcsltype :filter)
(dolist (v (split-string value ","))
(push (cons (funcall remove-keyword-colon key) v) result)))
((or :type :csltype)
(if (string-match-p "," value)
(user-error "The \"%s\" print_bibliography option does not support comma-separated values" key)
(push (cons (funcall remove-keyword-colon key) value) result)))))
bib-props)
result))
(defun org-cite-csl--rendered-bibliographies (info)
"Return the rendered bibliographies.
INFO is the export state, as a property list.
Return an (OUTPUTS PARAMETERS) list where OUTPUTS is an alist
of (BIB-PROPS . OUTPUT) pairs where each key is a property list
of a \"print_bibliography\" keyword and the corresponding OUTPUT
value is the bibliography as rendered by Citeproc."
(or (plist-get info :cite-citeproc-rendered-bibliographies)
(let (bib-plists bib-filters)
;; Collect bibliography property lists and the corresponding
;; Citeproc sub-bib filters.
(org-element-map (plist-get info :parse-tree) 'keyword
(lambda (keyword)
(when (equal "PRINT_BIBLIOGRAPHY" (org-element-property :key keyword))
(let ((bib-plist (org-cite-bibliography-properties keyword)))
(push bib-plist bib-plists)
(push (org-cite-csl--bibliography-filter bib-plist) bib-filters)))))
(setq bib-filters (nreverse bib-filters)
bib-plists (nreverse bib-plists))
;; Render and return all bibliographies.
(let ((processor (org-cite-csl--processor info)))
(citeproc-add-subbib-filters bib-filters processor)
(pcase-let* ((format (org-cite-csl--output-format info))
(`(,rendered-bibs . ,parameters)
(citeproc-render-bib
(org-cite-csl--processor info)
format
(org-cite-csl--no-citelinks-p info)))
(outputs (cl-mapcar #'cons bib-plists rendered-bibs))
(result (list outputs parameters)))
(plist-put info :cite-citeproc-rendered-bibliographies result)
result)))))
(defun org-cite-csl--generate-latex-preamble (info)
"Generate the CSL-related part of the LaTeX preamble.
INFO is the export state, as a property list."
(let* ((parameters (cadr (org-cite-csl--rendered-bibliographies info)))
(max-offset (cdr (assq 'max-offset parameters)))
(result org-cite-csl-latex-preamble))
(map-do (lambda (placeholder replacement)
(when (string-match placeholder result)
(setq result (replace-match replacement t t result))))
`("\\[CSL-HANGINDENT\\]" ,org-cite-csl-latex-hanging-indent
"\\[CSL-LABELSEP\\]" ,org-cite-csl-latex-label-separator
"\\[CSL-LABELWIDTH-PER-CHAR\\]" ,org-cite-csl-latex-label-width-per-char
"\\[CSL-MAXLABEL-CHARS\\]" ,(number-to-string max-offset)))
result))
;;; Export capability
(defun org-cite-csl-render-citation (citation _style _backend info)
"Export CITATION object.
INFO is the export state, as a property list."
(org-require-package 'citeproc)
(let ((output (cdr (assq citation (org-cite-csl--rendered-citations info)))))
(if (not (eq 'org (org-cite-csl--output-format info)))
output
;; Parse Org output to re-export it during the regular export
;; process.
(org-cite-parse-objects output))))
(defun org-cite-csl-render-bibliography (_keys _files _style props _backend info)
"Export bibliography.
INFO is the export state, as a property list."
(org-require-package 'citeproc)
(pcase-let* ((format (org-cite-csl--output-format info))
(`(,outputs ,parameters) (org-cite-csl--rendered-bibliographies info))
(output (cdr (assoc props outputs))))
(pcase format
('html
(concat
(and (cdr (assq 'second-field-align parameters))
(let* ((max-offset (cdr (assq 'max-offset parameters)))
(char-width
(string-to-number org-cite-csl-html-label-width-per-char))
(char-width-unit
(progn
(string-match (number-to-string char-width)
org-cite-csl-html-label-width-per-char)
(substring org-cite-csl-html-label-width-per-char
(match-end 0)))))
(format
""
(* max-offset char-width)
char-width-unit)))
(and (cdr (assq 'hanging-indent parameters))
(format
""
org-cite-csl-html-hanging-indent
org-cite-csl-html-hanging-indent))
output))
('org-latex output)
(_
;; Parse Org output to re-export it during the regular export
;; process.
(org-cite-parse-elements output)))))
(defun org-cite-csl-finalizer (output _keys _files _style _backend info)
"Add \"hanging\" package if missing from LaTeX output.
OUTPUT is the export document, as a string. INFO is the export state, as a
property list."
(org-require-package 'citeproc)
(if (not (eq 'org-latex (org-cite-csl--output-format info)))
output
(with-temp-buffer
(save-excursion (insert output))
(when (search-forward "\\begin{document}" nil t)
(goto-char (match-beginning 0))
;; Insert the CSL-specific parts of the LaTeX preamble.
(insert (org-cite-csl--generate-latex-preamble info)))
(buffer-string))))
;;; Register `csl' processor
(org-cite-register-processor 'csl
:export-citation #'org-cite-csl-render-citation
:export-bibliography #'org-cite-csl-render-bibliography
:export-finalizer #'org-cite-csl-finalizer
:cite-styles
'((("author" "a") ("bare" "b") ("caps" "c") ("full" "f") ("bare-caps" "bc") ("caps-full" "cf") ("bare-caps-full" "bcf"))
(("noauthor" "na") ("bare" "b") ("caps" "c") ("bare-caps" "bc"))
(("year" "y") ("bare" "b"))
(("text" "t") ("caps" "c") ("full" "f") ("caps-full" "cf"))
(("nil") ("bare" "b") ("caps" "c") ("bare-caps" "bc"))
(("nocite" "n"))
(("title" "ti") ("bare" "b"))
(("bibentry" "b") ("bare" "b"))
(("locators" "l") ("bare" "b"))))
(provide 'oc-csl)
;;; oc-csl.el ends here
org-mode-9.7.29+dfsg/lisp/oc-natbib.el 0000664 0000000 0000000 00000020250 15004304337 0017377 0 ustar 00root root 0000000 0000000 ;;; oc-natbib.el --- Citation processor using natbib LaTeX package -*- lexical-binding: t; -*-
;; Copyright (C) 2021-2025 Free Software Foundation, Inc.
;; Author: Nicolas Goaziou
;; 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
;; 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
;; Thomas Baumann
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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 %s " desc))
((eq format 'latex) (format "\\textit{%s}" desc))
((eq format 'odt)
(format "%s " desc))
(t desc)))
(defun org-bbdb-open (name _)
"Follow a BBDB link to NAME."
(org-require-package 'bbdb-com "bbdb")
(let ((inhibit-redisplay (not debug-on-error)))
(if (fboundp 'bbdb-name)
(org-bbdb-open-old name)
(org-bbdb-open-new name))))
(defun org-bbdb-open-old (name)
(catch 'exit
;; Exact match on name
(bbdb-name (concat "\\`" name "\\'") nil)
(if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil))
;; Exact match on name
(bbdb-company (concat "\\`" name "\\'") nil)
(if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil))
;; Partial match on name
(bbdb-name name nil)
(if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil))
;; Partial match on company
(bbdb-company name nil)
(if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil))
;; General match including network address and notes
(bbdb name nil)
(when (= 0 (buffer-size (get-buffer "*BBDB*")))
(delete-window (get-buffer-window "*BBDB*"))
(error "No matching BBDB record"))))
(defun org-bbdb-open-new (name)
(catch 'exit
;; Exact match on name
(bbdb-search-name (concat "\\`" name "\\'") nil)
(if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil))
;; Exact match on name
(bbdb-search-organization (concat "\\`" name "\\'") nil)
(if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil))
;; Partial match on name
(bbdb-search-name name nil)
(if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil))
;; Partial match on company
(bbdb-search-organization name nil)
(if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil))
;; General match including network address and notes
(bbdb name nil)
(when (= 0 (buffer-size (get-buffer "*BBDB*")))
(delete-window (get-buffer-window "*BBDB*"))
(error "No matching BBDB record"))))
(defun org-bbdb-anniv-extract-date (time-str)
"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."
(pcase (org-split-string time-str "-")
(`(,a ,b) (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.
Argument STR is the anniversary field in BBDB."
(let ((pos (string-match "[ \t]" str)))
(if pos (list (substring str 0 pos)
(bbdb-string-trim (substring str pos)))
(list str nil))))
(defvar org-bbdb-anniv-hash nil
"A hash holding anniversaries extracted from BBDB.
The hash table is created on first use.")
(defvar org-bbdb-updated-p t
"This is non-nil if BBDB has been updated since we last built the hash.")
(defun org-bbdb-make-anniv-hash ()
"Create a hash with anniversaries extracted from BBDB, for fast access.
The anniversaries are assumed to be stored `org-bbdb-anniversary-field'."
(let ((old-bbdb (fboundp 'bbdb-record-getprop))
(record-func (if (fboundp 'bbdb-record-xfield)
'bbdb-record-xfield
'bbdb-record-note))
split tmp annivs)
(clrhash org-bbdb-anniv-hash)
(dolist (rec (bbdb-records))
(when (setq annivs (if old-bbdb
(bbdb-record-getprop
rec org-bbdb-anniversary-field)
(funcall record-func
rec org-bbdb-anniversary-field)))
(setq annivs (if old-bbdb
(bbdb-split annivs "\n")
;; parameter order is reversed in new bbdb
(bbdb-split "\n" annivs)))
(while annivs
(setq split (org-bbdb-anniv-split (pop annivs)))
(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))
tmp)
org-bbdb-anniv-hash))))))
(setq org-bbdb-updated-p nil))
(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))
(add-hook 'bbdb-after-change-hook 'org-bbdb-updated)
;;;###autoload
(defun org-bbdb-anniversaries ()
"Extract anniversaries from BBDB for display in the agenda.
When called programmatically, this function expects the `date'
variable to be globally bound."
(org-require-package 'bbdb)
(require 'diary-lib)
(unless (hash-table-p org-bbdb-anniv-hash)
(setq org-bbdb-anniv-hash
(make-hash-table :test 'equal :size 366)))
(when (or org-bbdb-updated-p
(= 0 (hash-table-count org-bbdb-anniv-hash)))
(org-bbdb-make-anniv-hash))
(let* ((m (car date)) ; month
(d (nth 1 date)) ; day
(y (nth 2 date)) ; year
(annivs (gethash (list m d) org-bbdb-anniv-hash))
(text ())
rec recs)
;; We don't want to miss people born on Feb. 29th
(when (and (= m 3) (= d 1)
(not (null (gethash (list 2 29) org-bbdb-anniv-hash)))
(not (calendar-leap-year-p y)))
(setq recs (gethash (list 2 29) org-bbdb-anniv-hash))
(while (setq rec (pop recs))
(push rec annivs)))
(when annivs
(while (setq rec (pop annivs))
(when rec
(let* ((class (or (nth 2 rec)
org-bbdb-default-anniversary-format))
(form (or (cdr (assoc-string
class org-bbdb-anniversary-format-alist t))
class)) ; (as format string)
(name (nth 1 rec))
(years (if (eq (car rec) nil)
"unknown"
(- y (car rec))))
(suffix (if (eq (car rec) nil)
""
(diary-ordinal-suffix years)))
(tmp (cond
((functionp form)
(funcall form name years suffix))
((listp form) (eval form))
(t (format form name years suffix)))))
(org-add-props tmp nil 'org-bbdb-name name)
(if text
(setq text (append text (list tmp)))
(setq text (list tmp)))))
))
text))
;;; Return the 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 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)))))
(defun org-bbdb-anniversary-description (agenda-date anniv-date)
"Return a string used to incorporate into an agenda anniversary entry.
The calculation of the anniversary description string is based on
the difference between the anniversary date, given as ANNIV-DATE,
and the date on which the entry appears in the agenda, given as
AGENDA-DATE. This makes it possible to have different entries
for the same event depending on if it occurs in the next few days
or far away in the future."
(let ((delta (- (calendar-absolute-from-gregorian anniv-date)
(calendar-absolute-from-gregorian agenda-date))))
(cond
((= delta 0) " -- today\\&")
((= delta 1) " -- tomorrow\\&")
((< delta org-bbdb-general-anniversary-description-after)
(format " -- in %d days\\&" delta))
((pcase-let ((`(,month ,day ,year) anniv-date))
(format " -- %d-%02d-%02d\\&" year month day))))))
(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 (agenda-date 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.
(let ((desc (org-bbdb-anniversary-description
agenda-date d)))
(string-match "]]" x)
(replace-match desc 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 ((agenda-date date)
(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 agenda-date d (org-bbdb-anniversaries))))
dates)))))
(defun org-bbdb-complete-link ()
"Read a bbdb link with name completion."
(org-require-package 'bbdb-com "bbdb")
(let ((rec (bbdb-completing-read-record "Name: ")))
(concat "bbdb:"
(bbdb-record-name (if (listp rec)
(car rec)
rec)))))
(defun org-bbdb-anniv-export-ical ()
"Extract anniversaries from BBDB and convert them to icalendar format."
(org-require-package 'bbdb)
(require 'diary-lib)
(unless (hash-table-p org-bbdb-anniv-hash)
(setq org-bbdb-anniv-hash
(make-hash-table :test 'equal :size 366)))
(when (or org-bbdb-updated-p
(= 0 (hash-table-count org-bbdb-anniv-hash)))
(org-bbdb-make-anniv-hash))
(maphash 'org-bbdb-format-vevent org-bbdb-anniv-hash))
(defun org-bbdb-format-vevent (key recs)
(let (rec categ)
(while (setq rec (pop recs))
(setq categ (or (nth 2 rec) org-bbdb-default-anniversary-format))
(princ (format "BEGIN:VEVENT
UID: ANNIV-%4i%02i%02i-%s
DTSTART:%4i%02i%02i
SUMMARY:%s
DESCRIPTION:%s
CATEGORIES:%s
RRULE:FREQ=YEARLY
END:VEVENT\n"
(nth 0 rec) (nth 0 key) (nth 1 key)
(mapconcat 'identity
(org-split-string (nth 1 rec) "[^a-zA-Z0-90]+")
"-")
(nth 0 rec) (nth 0 key) (nth 1 key)
(nth 1 rec)
(concat (capitalize categ) " " (nth 1 rec))
categ)))))
(provide 'ol-bbdb)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; ol-bbdb.el ends here
org-mode-9.7.29+dfsg/lisp/ol-bibtex.el 0000664 0000000 0000000 00000103337 15004304337 0017436 0 ustar 00root root 0000000 0000000 ;;; ol-bibtex.el --- Links to BibTeX entries -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2007-2025 Free Software Foundation, Inc.
;;
;; Authors: Bastien Guerry
;; Carsten Dominik
;; Eric Schulte
;; Keywords: org, text, capture
;;
;; 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
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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 ::
;;
;; for example: [[docview:~/.elisp/org/doc/org.pdf::1][Org-Mode Manual]]
;;
;; Autocompletion for inserting links is supported; you will be
;; prompted for a file and a page number.
;;
;; If you use org-store-link in a doc-view mode buffer, the stored
;; link will point to the current page.
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'doc-view)
(require 'ol)
(declare-function doc-view-goto-page "doc-view" (page))
(declare-function image-mode-window-get "image-mode" (prop &optional winprops))
(declare-function org-open-file "org" (path &optional in-emacs line search))
(org-link-set-parameters "docview"
:follow #'org-docview-open
:export #'org-docview-export
:store #'org-docview-store-link)
(defun org-docview-export (link description backend _info)
"Export a docview LINK with DESCRIPTION for BACKEND."
(let ((path (if (string-match "\\(.+\\)::.+" link) (match-string 1 link)
link))
(desc (or description link)))
(when (stringp path)
(setq path (expand-file-name path))
(cond
((eq backend 'html) (format "%s " path desc))
((eq backend 'latex) (format "\\href{%s}{%s}" path desc))
((eq backend 'ascii) (format "[%s] (<%s>)" desc path))
(t path)))))
(defun org-docview-open (link _)
"Open docview: LINK."
(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.
(if (file-exists-p path)
(org-open-file path 1)
(error "No such file: %s" path))
(when page (doc-view-goto-page page))))
(defun org-docview-store-link (&optional _interactive?)
"Store a link to a docview buffer."
(when (eq major-mode 'doc-view-mode)
;; 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))))
(org-link-store-props
:type "docview"
:link link
:description path))))
(defun org-docview-complete-link ()
"Use the existing file name completion for file.
Links to get the file name, then ask the user for the page number
and append it."
(concat (replace-regexp-in-string "^file:" "docview:" (org-link-complete-file))
"::"
(read-from-minibuffer "Page:" "1")))
(provide 'ol-docview)
;;; ol-docview.el ends here
org-mode-9.7.29+dfsg/lisp/ol-doi.el 0000664 0000000 0000000 00000004646 15004304337 0016737 0 ustar 00root root 0000000 0000000 ;;; ol-doi.el --- DOI links support in Org -*- lexical-binding: t; -*-
;; Copyright (C) 2021-2025 Free Software Foundation, Inc.
;; Author: Nicolas Goaziou
;; 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 %s " uri (or desc uri)))
(`latex
(if desc (format "\\href{%s}{%s}" uri desc)
(format "\\url{%s}" uri)))
(`ascii
(if (not desc) (format "<%s>" uri)
(concat (format "[%s]" desc)
(and (not (plist-get info :ascii-links-to-notes))
(format " (<%s>)" uri)))))
(`texinfo
(if (not desc) (format "@uref{%s}" uri)
(format "@uref{%s, %s}" uri desc)))
(_ uri))))
(org-link-set-parameters "doi"
:follow #'org-link-doi-open
:export #'org-link-doi-export)
(provide 'org-link-doi)
(provide 'ol-doi)
;;; ol-doi.el ends here
org-mode-9.7.29+dfsg/lisp/ol-eshell.el 0000664 0000000 0000000 00000004770 15004304337 0017436 0 ustar 00root root 0000000 0000000 ;;; ol-eshell.el --- Links to Working Directories in Eshell -*- lexical-binding: t; -*-
;; Copyright (C) 2011-2025 Free Software Foundation, Inc.
;; Author: Konrad Hinsen
;; 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 a
;; Keywords: link, eww
;; URL: https://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
;; Tassilo Horn
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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 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)
(defcustom org-gnus-no-server nil
"Should Gnus be started using `gnus-no-server'?"
:group 'org-link-follow
:version "24.4"
:package-version '(Org . "8.0")
:type 'boolean)
;;; Install the link type
(org-link-set-parameters "gnus"
:follow #'org-gnus-open
:store #'org-gnus-store-link)
;;; Implementation
(defun org-gnus-group-link (group)
"Create a link to the Gnus group GROUP.
If GROUP is a newsgroup and `org-gnus-prefer-web-links' is
non-nil, create a link to groups.google.com. 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-prefix-p "nntp" group) ;; Only for nntp groups
(org-xor current-prefix-arg
org-gnus-prefer-web-links))
(concat "https://groups.google.com/group/" unprefixed-group)
(concat "gnus:" group))))
(defun org-gnus-article-link (group newsgroups message-id x-no-archive)
"Create a link to a Gnus article.
The article is specified by its MESSAGE-ID. Additional
parameters are the Gnus GROUP, the NEWSGROUPS the article was
posted to and the X-NO-ARCHIVE header value of that article.
If GROUP is a newsgroup and `org-gnus-prefer-web-links' is
non-nil, create a link to groups.google.com.
Otherwise create a link to the article inside Gnus.
If `org-store-link' was called with a prefix arg the meaning of
`org-gnus-prefer-web-links' is reversed."
(if (and (org-xor current-prefix-arg org-gnus-prefer-web-links)
newsgroups ;make web links only for nntp groups
(not x-no-archive)) ;and if X-No-Archive isn't set
(format "https://groups.google.com/groups/search?as_umsgid=%s"
(url-encode-url message-id))
(concat "gnus:" group "#" message-id)))
(defun org-gnus-store-link (&optional _interactive?)
"Store a link to a Gnus folder or message."
(pcase major-mode
(`gnus-group-mode
(let ((group (gnus-group-group-name)))
(when group
(org-link-store-props :type "gnus" :group group)
(let ((description (org-gnus-group-link group)))
(org-link-add-props :link description :description description)
description))))
((or `gnus-summary-mode `gnus-article-mode)
(let* ((group
(pcase (gnus-find-method-for-group gnus-newsgroup-name)
(`(nnvirtual . ,_)
(with-current-buffer gnus-summary-buffer
(save-excursion
(car (nnvirtual-map-article (gnus-summary-article-number))))))
(`(,(or `nnselect `nnir) . ,_) ; nnir is for Emacs < 28.
(with-current-buffer gnus-summary-buffer
(save-excursion
(cond
((fboundp 'nnselect-article-group)
(nnselect-article-group (gnus-summary-article-number)))
((fboundp 'nnir-article-group)
(nnir-article-group (gnus-summary-article-number)))
(t
(error "No article-group variant bound"))))))
(_ gnus-newsgroup-name)))
(header (with-current-buffer gnus-summary-buffer
(save-excursion
(gnus-summary-article-header))))
(from (mail-header-from header))
(message-id (org-unbracket-string "<" ">" (mail-header-id header)))
(date (org-trim (mail-header-date header)))
;; Remove text properties of subject string to avoid Emacs
;; bug #3506.
(subject (org-no-properties
(copy-sequence (mail-header-subject header))))
(to (cdr (assq 'To (mail-header-extra header))))
newsgroups x-no-archive)
;; Fetching an article is an expensive operation; newsgroup and
;; x-no-archive are only needed for web links.
(when (org-xor current-prefix-arg org-gnus-prefer-web-links)
;; Make sure the original article buffer is up-to-date.
(save-window-excursion (gnus-summary-select-article))
(setq to (or to (gnus-fetch-original-field "To")))
(setq newsgroups (gnus-fetch-original-field "Newsgroups"))
(setq x-no-archive (gnus-fetch-original-field "x-no-archive")))
(org-link-store-props :type "gnus" :from from :date date :subject subject
:message-id message-id :group group :to to)
(let ((link (org-gnus-article-link
group newsgroups message-id x-no-archive))
(description (org-link-email-description)))
(org-link-add-props :link link :description description)
link)))
(`message-mode
(setq org-store-link-plist nil) ;reset
(save-excursion
(save-restriction
(message-narrow-to-headers)
(unless (message-fetch-field "Message-ID")
(message-generate-headers '(Message-ID)))
(goto-char (point-min))
(re-search-forward "^Message-ID:" nil t)
(put-text-property (line-beginning-position) (line-end-position)
'message-deletable nil)
(let ((gcc (org-last (message-unquote-tokens
(message-tokenize-header
(mail-fetch-field "gcc" nil t) " ,"))))
(id (org-unbracket-string "<" ">"
(mail-fetch-field "Message-ID")))
(to (mail-fetch-field "To"))
(from (mail-fetch-field "From"))
(subject (mail-fetch-field "Subject"))
) ;; newsgroup xarchive ;those are always nil for gcc
(unless gcc (error "Can not create link: No Gcc header found"))
(org-link-store-props :type "gnus" :from from :subject subject
:message-id id :group gcc :to to)
(let ((link (org-gnus-article-link gcc nil id nil)) ;;newsgroup xarchive
(description (org-link-email-description)))
(org-link-add-props :link link :description description)
link)))))))
(defun org-gnus-open-nntp (path)
"Follow the nntp: link specified by PATH."
(let* ((spec (split-string path "/"))
(server (split-string (nth 2 spec) "@"))
(group (nth 3 spec))
(article (nth 4 spec)))
(org-gnus-follow-link
(format "nntp+%s:%s" (or (cdr server) (car server)) group)
article)))
(defun org-gnus-open (path _)
"Follow the Gnus message or folder link specified by PATH."
(unless (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)
(error "Error in Gnus link %S" path))
(let ((group (match-string-no-properties 1 path))
(article (match-string-no-properties 3 path)))
(org-gnus-follow-link group article)))
(defun org-gnus-follow-link (&optional group article)
"Follow a Gnus link to GROUP and ARTICLE."
(require 'gnus)
(funcall (cdr (assq 'gnus org-link-frame-setup)))
(when gnus-other-frame-object (select-frame gnus-other-frame-object))
(let ((group (org-no-properties group))
(article (org-no-properties article)))
(cond
((and group article)
(gnus-activate-group group)
(condition-case nil
(let ((msg "Couldn't follow Gnus link. Summary couldn't be opened."))
(pcase (gnus-find-method-for-group group)
(`(nndoc . ,_)
(if (gnus-group-read-group t nil group)
(gnus-summary-goto-article article nil t)
(message msg)))
(_
(let ((articles 1)
group-opened)
(while (and (not group-opened)
;; Stop on integer overflows. Note: We
;; can drop this once we require at least
;; Emacs 27, which supports bignums.
(> articles 0))
(setq group-opened (gnus-group-read-group articles t group))
(setq articles (if (< articles 16)
(1+ articles)
(* articles 2))))
(if group-opened
(gnus-summary-goto-article article nil t)
(message msg))))))
(quit
(message "Couldn't follow Gnus link. The linked group is empty."))))
(group (gnus-group-jump-to-group group)))))
(defun org-gnus-no-new-news ()
"Like `\\[gnus]' but doesn't check for new news."
(cond ((gnus-alive-p) nil)
(org-gnus-no-server (gnus-no-server))
(t (gnus))))
(provide 'ol-gnus)
;;; ol-gnus.el ends here
org-mode-9.7.29+dfsg/lisp/ol-info.el 0000664 0000000 0000000 00000017030 15004304337 0017106 0 ustar 00root root 0000000 0000000 ;;; ol-info.el --- Links to Info Nodes -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2025 Free Software Foundation, Inc.
;; Author: Carsten Dominik
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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 ")
(defcustom org-info-other-documents
'(("dir" . "https://www.gnu.org/manual/manual.html") ; index
("libc" . "https://www.gnu.org/software/libc/manual/html_mono/libc.html")
("make" . "https://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."
:group 'org-link
:type '(alist :key-type string :value-type string)
:package-version '(Org . "9.7")
:safe t)
(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 ((cdr (assoc filename org-info-other-documents)))
((member filename org-info-emacs-documents)
(format "https://www.gnu.org/software/emacs/manual/html_mono/%s.html"
filename))
(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."
(pcase-let ((`(,manual . ,node) (org-info--link-file-node path)))
(pcase format
(`html
(format "%s "
(org-info-map-html-url manual)
(org-info--expand-node-name node)
(or desc path)))
(`texinfo
(let ((title (or desc "")))
(format "@ref{%s,%s,,%s,}" node title manual)))
(_ nil))))
(provide 'ol-info)
;;; ol-info.el ends here
org-mode-9.7.29+dfsg/lisp/ol-irc.el 0000664 0000000 0000000 00000023142 15004304337 0016731 0 ustar 00root root 0000000 0000000 ;;; ol-irc.el --- Links to IRC Sessions -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2008-2025 Free Software Foundation, Inc.
;;
;; Author: Philip Jackson
;; Keywords: erc, irc, link, 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 %s " link desc))
(`md (format "[%s](irc:%s)" desc link))
(_ nil))))
(provide 'ol-irc)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; ol-irc.el ends here
org-mode-9.7.29+dfsg/lisp/ol-man.el 0000664 0000000 0000000 00000011574 15004304337 0016735 0 ustar 00root root 0000000 0000000 ;;; ol-man.el --- Links to man pages -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2020-2025 Free Software Foundation, Inc.
;; Author: Carsten Dominik
;; Maintainer: Bastien Guerry
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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 %s " path desc))
((eq backend 'latex) (format "\\href{%s}{%s}" path desc))
((eq backend 'texinfo) (format "@uref{%s,%s}" path desc))
((eq backend 'ascii) (format "[%s] (<%s>)" desc path))
((eq backend 'md) (format "[%s](%s)" desc path))
(t path))))
(defvar Man-completion-cache) ; Defined in `man'.
(defun org-man-complete (&optional _arg)
"Complete man pages for `org-insert-link'."
(require 'man)
(concat
"man:"
(let ((completion-ignore-case t) ; See `man' comments.
(Man-completion-cache)) ; See `man' implementation.
(completing-read
"Manual entry: "
'Man-completion-table))))
(provide 'ol-man)
;;; ol-man.el ends here
org-mode-9.7.29+dfsg/lisp/ol-mhe.el 0000664 0000000 0000000 00000017463 15004304337 0016736 0 ustar 00root root 0000000 0000000 ;;; ol-mhe.el --- Links to MH-E Messages -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2025 Free Software Foundation, Inc.
;; Author: Thomas Baumann
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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
;;
;; The idea of transforming the HTML content with Org syntax is
;; proposed by Richard, I'm just coding it.
;;
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'ol)
(defvar w3m-current-url)
(defvar w3m-current-title)
(org-link-set-parameters "w3m" :store #'org-w3m-store-link)
(defun org-w3m-store-link ()
"Store a link to a w3m buffer."
(when (eq major-mode 'w3m-mode)
(org-link-store-props
:type "w3m"
:link w3m-current-url
:url (url-view-url t)
:description (or w3m-current-title w3m-current-url))))
(defun org-w3m-copy-for-org-mode ()
"Copy current buffer content or active region with Org style links.
This will encode `link-title' and `link-location' with
`org-link-make-string', and insert the transformed test into the kill ring,
so that it can be yanked into an Org buffer with links working correctly."
(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.
(deactivate-mark))
(message "Transforming links...")
(save-excursion
(goto-char transform-start)
(while (and (not out-bound) ; still inside region to copy
(not (org-w3m-no-next-link-p))) ; no next link current buffer
;; store current point before jump next anchor
(setq temp-position (point))
;; move to next anchor when current point is not at anchor
(or (get-text-property (point) 'w3m-href-anchor) (org-w3m-get-next-link-start))
(cond
((<= (point) transform-end) ; point is inside transform bound
;; get content between two links.
(when (> (point) temp-position)
(setq return-content (concat return-content
(buffer-substring
temp-position (point)))))
(cond
((setq link-location (get-text-property (point) 'w3m-href-anchor))
;; current point is a link
;; (we thus also got link location at current point)
;; get link title at current point.
(setq link-title (buffer-substring (point)
(org-w3m-get-anchor-end)))
;; concat Org style url to `return-content'.
(setq return-content
(concat return-content
(if (org-string-nw-p link-location)
(org-link-make-string link-location link-title)
link-title))))
((setq link-location (get-text-property (point) 'w3m-image))
;; current point is an image
;; (we thus also got image link location at current point)
;; get link title at current point.
(setq link-title (buffer-substring (point) (org-w3m-get-image-end)))
;; concat Org style url to `return-content'.
(setq return-content
(concat return-content
(if (org-string-nw-p link-location)
(org-link-make-string link-location link-title)
link-title))))
(t nil))); current point is neither a link nor an image
(t ; point is NOT inside transform bound
(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))))
(org-kill-new return-content)
(message "Transforming links...done, use C-y to insert text into Org file")
(message "Copy with link transformation complete."))))
(defun org-w3m-get-anchor-start ()
"Move cursor to the start of current anchor. Return point."
;; get start position of anchor or current point
;; NOTE: This function seems never to be used. Should it be removed?
(goto-char (or (previous-single-property-change (point) 'w3m-anchor-sequence)
(point))))
(defun org-w3m-get-anchor-end ()
"Move cursor to the end of current anchor. Return point."
;; get end position of anchor or point
(goto-char (or (next-single-property-change (point) 'w3m-anchor-sequence)
(point))))
(defun org-w3m-get-image-end ()
"Move cursor to the end of current image. Return point."
;; get end position of image or point
;; NOTE: Function `org-w3m-get-image-start' was not created because
;; function `org-w3m-get-anchor-start' is never used.
(goto-char (or (next-single-property-change (point) 'w3m-image)
(point))))
(defun org-w3m-get-next-link-start ()
"Move cursor to the start of next link or image. Return point."
(let (pos start-pos anchor-pos image-pos)
(setq pos (setq start-pos (point)))
(setq anchor-pos
(catch 'reach
(while (setq pos (next-single-property-change pos 'w3m-anchor-sequence))
(when (get-text-property pos 'w3m-href-anchor)
(throw 'reach pos)))))
(setq pos start-pos)
(setq image-pos
(catch 'reach
(while (setq pos (next-single-property-change pos 'w3m-image))
(when (get-text-property pos 'w3m-image)
(throw 'reach pos)))))
(goto-char (min (or anchor-pos (point-max)) (or image-pos (point-max))))))
(defun org-w3m-get-prev-link-start ()
"Move cursor to the start of previous link. Return point."
;; NOTE: This function is only called by `org-w3m-no-prev-link-p',
;; which itself seems never to be used. Should it be removed?
;;
;; WARNING: This function has not been updated to account for
;; `w3m-image'. See `org-w3m-get-next-link-start'.
(catch 'reach
(let ((pos (point)))
(while (setq pos (previous-single-property-change pos 'w3m-anchor-sequence))
(when (get-text-property pos 'w3m-href-anchor)
;; jump to previous anchor
(goto-char pos)
;; return point when current is valid link
(throw 'reach nil)))))
(point))
(defun org-w3m-no-next-link-p ()
"Whether there is no next link after the cursor.
Return t if there is no next link; otherwise, return nil."
(save-excursion
(equal (point) (org-w3m-get-next-link-start))))
(defun org-w3m-no-prev-link-p ()
"Whether there is no previous link after the cursor.
Return t if there is no previous link; otherwise, return nil."
;; NOTE: This function seems never to be used. Should it be removed?
(save-excursion
(equal (point) (org-w3m-get-prev-link-start))))
;; Install keys into the w3m keymap
(defvar w3m-mode-map)
(defvar w3m-minor-mode-map)
(when (and (boundp 'w3m-mode-map)
(keymapp w3m-mode-map))
(define-key w3m-mode-map "\C-c\C-x\M-w" 'org-w3m-copy-for-org-mode)
(define-key w3m-mode-map "\C-c\C-x\C-w" 'org-w3m-copy-for-org-mode))
(when (and (boundp 'w3m-minor-mode-map)
(keymapp w3m-minor-mode-map))
(define-key w3m-minor-mode-map "\C-c\C-x\M-w" 'org-w3m-copy-for-org-mode)
(define-key w3m-minor-mode-map "\C-c\C-x\C-w" 'org-w3m-copy-for-org-mode))
(add-hook
'w3m-mode-hook
(lambda ()
(define-key w3m-mode-map "\C-c\C-x\M-w" 'org-w3m-copy-for-org-mode)
(define-key w3m-mode-map "\C-c\C-x\C-w" 'org-w3m-copy-for-org-mode)))
(add-hook
'w3m-minor-mode-hook
(lambda ()
(define-key w3m-minor-mode-map "\C-c\C-x\M-w" 'org-w3m-copy-for-org-mode)
(define-key w3m-minor-mode-map "\C-c\C-x\C-w" 'org-w3m-copy-for-org-mode)))
(provide 'ol-w3m)
;;; ol-w3m.el ends here
org-mode-9.7.29+dfsg/lisp/ol.el 0000664 0000000 0000000 00000255477 15004304337 0016200 0 ustar 00root root 0000000 0000000 ;;; ol.el --- Org links library -*- lexical-binding: t; -*-
;; Copyright (C) 2018-2025 Free Software Foundation, Inc.
;; Author: Carsten Dominik
;; Keywords: outlines, hypermedia, calendar, text
;; 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
A search string is added to the file name with \"::\" as separator
and used to find the context when the link is activated by the command
`org-open-at-point'. When this option is t, the entire active region
is be placed in the search string of the file link. If set to a
positive integer N, only the first N lines of context are stored.
Using a prefix argument to the command `org-store-link' \
\(`\\[universal-argument] \\[org-store-link]')
negates this setting for the duration of the command."
:group 'org-link-store
:type '(choice boolean integer)
:safe (lambda (val) (or (booleanp val) (integerp val))))
(defcustom org-link-email-description-format "Email %c: %s"
"Format of the description part of a link to an email or Usenet message.
The following %-escapes will be replaced by corresponding information:
%F full \"From\" field
%f name, taken from \"From\" field, address if no name
%T full \"To\" field
%t first name in \"To\" field, address if no name
%c correspondent. Usually \"from NAME\", but if you sent it yourself, it
will be \"to NAME\". See also the variable `org-from-is-user-regexp'.
%s subject
%d date
%m message-id.
You may use normal field width specification between the % and the letter.
This is for example useful to limit the length of the subject.
Examples: \"%f on: %.30s\", \"Email from %f\", \"Email %c\""
:group 'org-link-store
:package-version '(Org . "9.3")
:type 'string
:safe #'stringp)
(defcustom org-link-from-user-regexp
(let ((mail (and (org-string-nw-p user-mail-address)
(format "\\<%s\\>" (regexp-quote user-mail-address))))
(name (and (org-string-nw-p user-full-name)
(format "\\<%s\\>" (regexp-quote user-full-name)))))
(if (and mail name) (concat mail "\\|" name) (or mail name)))
"Regexp matched against the \"From:\" header of an email or Usenet message.
It should match if the message is from the user him/herself."
:group 'org-link-store
:type 'regexp
:safe #'stringp)
(defcustom org-link-keep-stored-after-insertion nil
"Non-nil means keep link in list for entire session.
\\
The command `org-store-link' adds a link pointing to the current
location to an internal list. These links accumulate during a session.
The command `org-insert-link' can be used to insert links into any
Org file (offering completion for all stored links).
When this option is nil, every link which has been inserted once using
`\\[org-insert-link]' will be removed from the list, to make completing the \
unused
links more efficient."
:group 'org-link-store
:type 'boolean
:safe #'booleanp)
;;; Public variables
(defconst org-target-regexp (let ((border "[^<>\n\r \t]"))
(format "<<\\(%s\\|%s[^<>\n\r]*%s\\)>>"
border border border))
"Regular expression matching a link target.")
(defconst org-radio-target-regexp (format "<%s>" org-target-regexp)
"Regular expression matching a radio target.")
(defvar-local org-target-link-regexp nil
"Regular expression matching radio targets in plain text.")
(defconst org-target-link-regexp-limit (ash 2 12)
"Maximum allowed length of regexp.
The number should generally be ~order of magnitude smaller than
MAX_BUF_SIZE in src/regex-emacs.c. The number of regexp-emacs.c is
for processed regexp, which appears to be larger compared to the
original string length.")
(defvar-local org-target-link-regexps nil
"List of regular expressions matching radio targets in plain text.
This list is non-nil, when a single regexp would be too long to match
all the possible targets, exceeding Emacs's regexp length limit.")
(defvar org-link-types-re nil
"Matches a link that has a url-like prefix like \"http:\".")
(defvar org-link-angle-re nil
"Matches link with angular brackets, spaces are allowed.")
(defvar org-link-plain-re nil
"Matches plain link, without spaces.
Group 1 must contain the link type (i.e. https).
Group 2 must contain the link path (i.e. //example.com).
Used by `org-element-link-parser'.")
(defvar org-link-bracket-re nil
"Matches a link in double brackets.")
(defvar org-link-any-re nil
"Regular expression matching any link.")
(defvar-local org-link-abbrev-alist-local nil
"Buffer-local version of `org-link-abbrev-alist', which see.
The value of this is taken from the LINK keywords.")
(defvar org-stored-links nil
"Contains the links stored with `org-store-link'.")
(defvar org-store-link-plist nil
"Plist with info about the most recently link created with `org-store-link'.")
(defvar org-create-file-search-functions nil
"List of functions to construct the right search string for a file link.
These functions are called in turn with point at the location to
which the link should point.
A function in the hook should first test if it would like to
handle this file type, for example by checking the `major-mode'
or the file extension. If it decides not to handle this file, it
should just return nil to give other functions a chance. If it
does handle the file, it must return the search string to be used
when following the link. The search string will be part of the
file link, given after a double colon, and `org-open-at-point'
will automatically search for it. If special measures must be
taken to make the search successful, another function should be
added to the companion hook `org-execute-file-search-functions',
which see.
A function in this hook may also use `org-link-store-props' and set
`:description' property to provide a suggestion for the descriptive
text to be used for this link when it gets inserted into an Org buffer
with \\[org-insert-link].")
(defvar org-execute-file-search-functions nil
"List of functions to execute a file search triggered by a link.
Functions added to this hook must accept a single argument, the
search string that was part of the file link, the part after the
double colon. The function must first check if it would like to
handle this search, for example by checking the `major-mode' or
the file extension. If it decides not to handle this search, it
should just return nil to give other functions a chance. If it
does handle the search, it must return a non-nil value to keep
other functions from trying.
Each function can access the current prefix argument through the
variable `current-prefix-arg'. Note that a single prefix is used
to force opening a link in Emacs, so it may be good to only use a
numeric or double prefix to guide the search function.
In case this is needed, a function in this hook can also restore
the window configuration before `org-open-at-point' was called using:
(set-window-configuration org-window-config-before-follow-link)")
(defvar org-open-link-functions nil
"Hook for functions finding a plain text link.
These functions must take a single argument, the link content.
They will be called for links that look like [[link text][description]]
when LINK TEXT does not have a protocol like \"http:\" and does not look
like a filename (e.g. \"./blue.png\").
These functions will be called *before* Org attempts to resolve the
link by doing text searches in the current buffer - so if you want a
link \"[[target]]\" to still find \"<>\", your function should
handle this as a special case.
When the function does handle the link, it must return a non-nil value.
If it decides that it is not responsible for this link, it must return
nil to indicate that Org can continue with other options like
exact and fuzzy text search.")
;;; Internal Variables
(defconst org-link--forbidden-chars "]\t\n\r<>"
"Characters forbidden within a link, as a string.")
(defvar org-link--history nil
"History for inserted links.")
(defvar org-link--insert-history nil
"Minibuffer history for links inserted with `org-insert-link'.")
(defvar org-link--search-failed nil
"Non-nil when last link search failed.")
;;; Internal Functions
(defun org-link--try-special-completion (type)
"If there is completion support for link type TYPE, offer it."
(let ((fun (org-link-get-parameter type :complete)))
(if (functionp fun)
(funcall fun)
(read-string "Link (no completion support): " (concat type ":")))))
(defun org-link--prettify (link)
"Return a human-readable representation of LINK.
The car of LINK must be a raw link. The cdr of LINK must be
either a link description or nil."
(let ((desc (or (cadr link) "")))
(concat (format "%-45s" (substring desc 0 (min (length desc) 40)))
"<" (car link) ">")))
(defun org-link--decode-compound (hex)
"Unhexify Unicode hex-chars HEX.
E.g. \"%C3%B6\" is the German o-Umlaut. Note: this function also
decodes single byte encodings like \"%E1\" (a-acute) if not
followed by another \"%[A-F0-9]{2}\" group."
(save-match-data
(let* ((bytes (cdr (split-string hex "%")))
(ret "")
(eat 0)
(sum 0))
(while bytes
(let* ((val (string-to-number (pop bytes) 16))
(shift-xor
(if (= 0 eat)
(cond
((>= val 252) (cons 6 252))
((>= val 248) (cons 5 248))
((>= val 240) (cons 4 240))
((>= val 224) (cons 3 224))
((>= val 192) (cons 2 192))
(t (cons 0 0)))
(cons 6 128))))
(when (>= val 192) (setq eat (car shift-xor)))
(setq val (logxor val (cdr shift-xor)))
(setq sum (+ (ash sum (car shift-xor)) val))
(when (> eat 0) (setq eat (- eat 1)))
(cond
((= 0 eat) ;multi byte
(setq ret (concat ret (char-to-string sum)))
(setq sum 0))
((not bytes) ; single byte(s)
(setq ret (org-link--decode-single-byte-sequence hex))))))
ret)))
(defun org-link--decode-single-byte-sequence (hex)
"Unhexify hex-encoded single byte character sequence HEX."
(mapconcat (lambda (byte)
(char-to-string (string-to-number byte 16)))
(cdr (split-string hex "%"))
""))
(defun org-link--fontify-links-to-this-file ()
"Fontify links to the current file in `org-stored-links'."
(let ((f (buffer-file-name)) a b)
(setq a (mapcar (lambda(l)
(let ((ll (car l)))
(when (and (string-match "^file:\\(.+\\)::" ll)
(equal f (expand-file-name (match-string 1 ll))))
ll)))
org-stored-links))
(when (featurep 'org-id)
(setq b (mapcar (lambda(l)
(let ((ll (car l)))
(when (and (string-match "^id:\\(.+\\)$" ll)
(equal f (expand-file-name
(or (org-id-find-id-file
(match-string 1 ll)) ""))))
ll)))
org-stored-links)))
(mapcar (lambda(l)
(put-text-property 0 (length l) 'face 'font-lock-comment-face l))
(delq nil (append a b)))))
(defun org-link--buffer-for-internals ()
"Return buffer used for displaying the target of internal links."
(cond
((not org-link-use-indirect-buffer-for-internals) (current-buffer))
((string-suffix-p "(Clone)" (buffer-name))
(message "Buffer is already a clone, not making another one")
;; We also do not modify visibility in this case.
(current-buffer))
(t ;make a new indirect buffer for displaying the link
(let* ((indirect-buffer-name (concat (buffer-name) "(Clone)"))
(indirect-buffer
(or (get-buffer indirect-buffer-name)
(make-indirect-buffer (current-buffer)
indirect-buffer-name
'clone))))
(with-current-buffer indirect-buffer (org-cycle-overview))
indirect-buffer))))
(defun org-link--search-radio-target (target)
"Search a radio target matching TARGET in current buffer.
White spaces are not significant."
(let ((re (format "<<<%s>>>"
(mapconcat #'regexp-quote
(split-string target)
"[ \t]+\\(?:\n[ \t]*\\)?")))
(origin (point)))
(goto-char (point-min))
(catch :radio-match
(while (re-search-forward re nil t)
(forward-char -1)
(let ((object (org-element-context)))
(when (org-element-type-p object 'radio-target)
(goto-char (org-element-begin object))
(org-fold-show-context 'link-search)
(throw :radio-match nil))))
(goto-char origin)
(user-error "No match for radio target: %s" target))))
(defun org-link--context-from-region ()
"Return context string from active region, or nil."
(when (org-region-active-p)
(let ((context (buffer-substring (region-beginning) (region-end))))
(when (and (wholenump org-link-context-for-files)
(> org-link-context-for-files 0))
(let ((lines (org-split-string context "\n")))
(setq context
(mapconcat #'identity
(cl-subseq lines 0 org-link-context-for-files)
"\n"))))
context)))
(defun org-link--normalize-string (string &optional context)
"Remove ignored contents from STRING string and return it.
This function removes contiguous white spaces and statistics
cookies. When optional argument CONTEXT is non-nil, it assumes
STRING is a context string, and also removes special search
syntax around the string."
(let ((string
(org-trim
(replace-regexp-in-string
(rx (one-or-more (any " \t")))
" "
(replace-regexp-in-string
;; Statistics cookie regexp.
(rx (seq "[" (0+ digit) (or "%" (seq "/" (0+ digit))) "]"))
" "
string)))))
(when context
(while (cond ((and (string-prefix-p "(" string)
(string-suffix-p ")" string))
(setq string (org-trim (substring string 1 -1))))
((string-match "\\`[#*]+[ \t]*" string)
(setq string (substring string (match-end 0))))
(t nil))))
string))
(defun org-link--reveal-maybe (region _)
"Reveal folded link in REGION when needed.
This function is intended to be used as :fragile property of a folding
spec."
(org-with-point-at (car region)
(not (org-in-regexp org-link-any-re))))
(defun org-link--try-link-store-functions (interactive?)
"Try storing external links, prompting if more than one is possible.
Each function returned by `org-store-link-functions' is called in
turn. If multiple functions return non-nil, prompt for which
link should be stored.
Argument INTERACTIVE? indicates whether `org-store-link' was
called interactively and is passed to the link store functions.
Return t when a link has been stored in `org-link-store-props'."
(let ((results-alist nil))
(dolist (f (org-store-link-functions))
(when (condition-case nil
(funcall f interactive?)
;; FIXME: The store function used (< Org 9.7) to accept
;; no arguments; provide backward compatibility support
;; for them.
(wrong-number-of-arguments
(funcall f)))
;; FIXME: return value is not link's plist, so we store the
;; new value before it is modified. It would be cleaner to
;; ask store link functions to return the plist instead.
(push (cons f (copy-sequence org-store-link-plist))
results-alist)))
(pcase results-alist
(`nil nil)
(`((,_ . ,_)) t) ;single choice: nothing to do
(`((,name . ,_) . ,_)
;; Reinstate link plist associated to the chosen
;; function.
(apply #'org-link-store-props
(cdr (assoc-string
(completing-read
(format "Store link with (default %s): " name)
(mapcar #'car results-alist)
nil t nil nil (symbol-name name))
results-alist)))
t))))
(defun org-link--add-to-stored-links (link desc)
"Add LINK to `org-stored-links' with description DESC."
(cond
((not (member (list link desc) org-stored-links))
(push (list link desc) org-stored-links)
(message "Stored: %s" (or desc link)))
((equal (list link desc) (car org-stored-links))
(message "This link has already been stored"))
(t
(setq org-stored-links
(delete (list link desc) org-stored-links))
(push (list link desc) org-stored-links)
(message "Link moved to front: %s" (or desc link)))))
(defun org-link--file-link-to-here ()
"Return as (LINK . DESC) a file link with search string to here."
(let ((link (concat "file:"
(abbreviate-file-name
(buffer-file-name (buffer-base-buffer)))))
desc)
(when org-link-context-for-files
(pcase (org-link-precise-link-target)
(`nil nil)
(`(,search-string ,search-desc ,_position)
(setq link (format "%s::%s" link search-string))
(setq desc search-desc))))
(cons link desc)))
;;; Public API
(defun org-link-types ()
"Return a list of known link types."
(mapcar #'car org-link-parameters))
(defun org-link-get-parameter (type key)
"Get TYPE link property for KEY.
TYPE is a string and KEY is a plist keyword. See
`org-link-parameters' for supported keywords."
(plist-get (cdr (assoc type org-link-parameters))
key))
(defun org-link-set-parameters (type &rest parameters)
"Set link TYPE properties to PARAMETERS.
PARAMETERS should be keyword value pairs. See
`org-link-parameters' for supported keys."
(when (member type '("coderef" "custom-id" "fuzzy" "radio"))
(error "Cannot override reserved link type: %S" type))
(let ((data (assoc type org-link-parameters)))
(if data (setcdr data (org-combine-plists (cdr data) parameters))
(push (cons type parameters) org-link-parameters)
(org-link-make-regexps)
(when (featurep 'org-element) (org-element-update-syntax)))))
;; This way, one can add multiple functions as, say, :follow parameter.
;; For example,
;; (add-function :before-until (org-link-get-parameter "id" :follow) #'my-function)
;; See https://orgmode.org/list/a123389c-8f86-4836-a4fe-1e3f4281d33b@app.fastmail.com
(gv-define-setter org-link-get-parameter (value type key)
`(org-link-set-parameters ,type ,key ,value))
(defun org-link-make-regexps ()
"Update the link regular expressions.
This should be called after the variable `org-link-parameters' has changed."
(let ((types-re (regexp-opt (org-link-types) t)))
(setq org-link-types-re
(concat "\\`" types-re ":")
org-link-angle-re
(format "<%s:\\([^>\n]*\\(?:\n[ \t]*[^> \t\n][^>\n]*\\)*\\)>"
types-re)
org-link-plain-re
(let* ((non-space-bracket "[^][ \t\n()<>]")
(parenthesis
`(seq (any "<([")
(0+ (or (regex ,non-space-bracket)
(seq (any "<([")
(0+ (regex ,non-space-bracket))
(any "])>"))))
(any "])>"))))
;; Heuristics for an URL link inspired by
;; https://daringfireball.net/2010/07/improved_regex_for_matching_urls
(rx-to-string
`(seq word-start
;; Link type: match group 1.
(regexp ,types-re)
":"
;; Link path: match group 2.
(group
(1+ (or (regex ,non-space-bracket)
,parenthesis))
(or (regexp "[^[:punct:] \t\n]")
?/
,parenthesis)))))
org-link-bracket-re
(rx (seq "[["
;; URI part: match group 1.
(group
(one-or-more
(or (not (any "[]\\"))
(and "\\" (zero-or-more "\\\\") (any "[]"))
(and (one-or-more "\\") (not (any "[]"))))))
"]"
;; Description (optional): match group 2.
(opt "[" (group (+? anything)) "]")
"]"))
org-link-any-re
(concat "\\(" org-link-bracket-re "\\)\\|\\("
org-link-angle-re "\\)\\|\\("
org-link-plain-re "\\)"))))
(defun org-link-complete-file (&optional arg)
"Create a file link using completion.
With optional ARG \\='(16), abbreviate the file name in the link."
(let ((file (read-file-name "File: "))
(pwd (file-name-as-directory (expand-file-name ".")))
(pwd1 (file-name-as-directory (abbreviate-file-name
(expand-file-name ".")))))
(cond ((equal arg '(16))
(concat "file:"
(abbreviate-file-name (expand-file-name file))))
((string-match
(concat "^" (regexp-quote pwd1) "\\(.+\\)") file)
(concat "file:" (match-string 1 file)))
((string-match
(concat "^" (regexp-quote pwd) "\\(.+\\)")
(expand-file-name file))
(concat "file:"
(match-string 1 (expand-file-name file))))
(t (concat "file:" file)))))
(defun org-link-email-description (&optional fmt)
"Return the description part of an email link.
This takes information from `org-store-link-plist' and formats it
according to FMT (default from `org-link-email-description-format')."
(setq fmt (or fmt org-link-email-description-format))
(let* ((p org-store-link-plist)
(to (plist-get p :toaddress))
(from (plist-get p :fromaddress))
(table
(list
(cons "%c" (plist-get p :fromto))
(cons "%F" (plist-get p :from))
(cons "%f" (or (plist-get p :fromname) (plist-get p :fromaddress) "?"))
(cons "%T" (plist-get p :to))
(cons "%t" (or (plist-get p :toname) (plist-get p :toaddress) "?"))
(cons "%s" (plist-get p :subject))
(cons "%d" (plist-get p :date))
(cons "%m" (plist-get p :message-id)))))
(when (string-match "%c" fmt)
;; Check if the user wrote this message
(if (and org-link-from-user-regexp from to
(save-match-data (string-match org-link-from-user-regexp from)))
(setq fmt (replace-match "to %t" t t fmt))
(setq fmt (replace-match "from %f" t t fmt))))
(org-replace-escapes fmt table)))
(defun org-link-store-props (&rest plist)
"Store link properties PLIST.
The properties are pre-processed by extracting names, addresses
and dates."
(let ((x (plist-get plist :from)))
(when x
(let ((adr (mail-extract-address-components x)))
(setq plist (plist-put plist :fromname (car adr)))
(setq plist (plist-put plist :fromaddress (nth 1 adr))))))
(let ((x (plist-get plist :to)))
(when x
(let ((adr (mail-extract-address-components x)))
(setq plist (plist-put plist :toname (car adr)))
(setq plist (plist-put plist :toaddress (nth 1 adr))))))
(let ((x (ignore-errors (date-to-time (plist-get plist :date)))))
(when x
(setq plist (plist-put plist :date-timestamp
(format-time-string
(org-time-stamp-format t) x)))
(setq plist (plist-put plist :date-timestamp-inactive
(format-time-string
(org-time-stamp-format t t) x)))))
(let ((from (plist-get plist :from))
(to (plist-get plist :to)))
(when (and from to org-link-from-user-regexp)
(setq plist
(plist-put plist :fromto
(if (string-match org-link-from-user-regexp from)
(concat "to %t")
(concat "from %f"))))))
(setq org-store-link-plist plist))
(defun org-link-add-props (&rest plist)
"Add these properties to the link property list PLIST."
(let (key value)
(while plist
(setq key (pop plist) value (pop plist))
(setq org-store-link-plist
(plist-put org-store-link-plist key value)))))
(defun org-link-encode (text table)
"Return percent escaped representation of string TEXT.
TEXT is a string with the text to escape. TABLE is a list of
characters that should be escaped."
(mapconcat
(lambda (c)
(if (memq c table)
(mapconcat (lambda (e) (format "%%%.2X" e))
(or (encode-coding-char c 'utf-8)
(error "Unable to percent escape character: %c" c))
"")
(char-to-string c)))
text ""))
(defun org-link-decode (s)
"Decode percent-encoded parts in string S.
E.g. \"%C3%B6\" becomes the German o-Umlaut."
(replace-regexp-in-string "\\(%[0-9A-Za-z]\\{2\\}\\)+"
#'org-link--decode-compound s t t))
(defun org-link-escape (link)
"Backslash-escape sensitive characters in string LINK."
(replace-regexp-in-string
(rx (seq (group (zero-or-more "\\")) (group (or string-end (any "[]")))))
(lambda (m)
(concat (match-string 1 m)
(match-string 1 m)
(and (/= (match-beginning 2) (match-end 2)) "\\")))
link nil t 1))
(defun org-link-unescape (link)
"Remove escaping backslash characters from string LINK."
(replace-regexp-in-string
(rx (group (one-or-more "\\")) (or string-end (any "[]")))
(lambda (_)
(concat (make-string (/ (- (match-end 1) (match-beginning 1)) 2) ?\\)))
link nil t 1))
(defun org-link-make-string (link &optional description)
"Make a bracket link, consisting of LINK and DESCRIPTION.
LINK is escaped with backslashes for inclusion in buffer."
(let* ((zero-width-space (string ?\x200B))
(description
(and (org-string-nw-p description)
;; Description cannot contain two consecutive square
;; brackets, or end with a square bracket. To prevent
;; this, insert a zero width space character between
;; the brackets, or at the end of the description.
(replace-regexp-in-string
"\\(]\\)\\(]\\)"
(concat "\\1" zero-width-space "\\2")
(replace-regexp-in-string "]\\'"
(concat "\\&" zero-width-space)
(org-trim description))))))
(if (not (org-string-nw-p link))
(or description
(error "Empty link"))
(format "[[%s]%s]"
(org-link-escape link)
(if description (format "[%s]" description) "")))))
(defun org-store-link-functions ()
"List of functions that are called to create and store a link.
The functions are defined in the `:store' property of
`org-link-parameters'. Each function should accept an argument
INTERACTIVE? which indicates whether the user has initiated
`org-store-link' interactively.
Each function will be called in turn with a single argument
INTERACTIVE? - non-nil when user interaction is allowed. Each function
should check if it is responsible for creating this link (for example
by looking at the major mode). If not, it must return nil. If yes,
it should return a non-nil value after calling `org-link-store-props'
with a list of properties and values. Special properties are:
:type The link prefix, like \"http\". This must be given.
:link The link, like \"http://www.astro.uva.nl/~dominik\".
This is obligatory as well.
:description Optional default description for the second pair
of brackets in an Org mode link. The user can still change
this when inserting this link into an Org mode buffer.
In addition to these, any additional properties can be specified
and then used in capture templates."
(cl-loop for link in org-link-parameters
with store-func
do (setq store-func (org-link-get-parameter (car link) :store))
if store-func
collect store-func))
(defun org-link-expand-abbrev (link)
"Replace link abbreviations in LINK string.
Abbreviations are defined in `org-link-abbrev-alist'."
(if (not (string-match "^\\([^:]*\\)\\(::?\\(.*\\)\\)?$" link)) link
(let* ((key (match-string 1 link))
(as (or (assoc key org-link-abbrev-alist-local)
(assoc key org-link-abbrev-alist)))
(tag (and (match-end 2) (match-string 3 link)))
rpl)
(if (not as)
link
(setq rpl (cdr as))
;; Drop any potentially dangerous text properties like
;; `modification-hooks' that may be used as an attack vector.
(substring-no-properties
(cond
((symbolp rpl) (funcall rpl tag))
((string-match "%(\\([^)]+\\))" rpl)
(let ((rpl-fun-symbol (intern-soft (match-string 1 rpl))))
;; Using `unsafep-function' is not quite enough because
;; Emacs considers functions like `genenv' safe, while
;; they can potentially be used to expose private system
;; data to attacker if abbreviated link is clicked.
(if (or (eq t (get rpl-fun-symbol 'org-link-abbrev-safe))
(eq t (get rpl-fun-symbol 'pure)))
(replace-match
(save-match-data
(funcall (intern-soft (match-string 1 rpl)) tag))
t t rpl)
(org-display-warning
(format "Disabling unsafe link abbrev: %s
You may mark function safe via (put '%s 'org-link-abbrev-safe t)"
rpl (match-string 1 rpl)))
(setq org-link-abbrev-alist-local (delete as org-link-abbrev-alist-local)
org-link-abbrev-alist (delete as org-link-abbrev-alist))
link
)))
((string-match "%s" rpl) (replace-match (or tag "") t t rpl))
((string-match "%h" rpl)
(replace-match (url-hexify-string (or tag "")) t t rpl))
(t (concat rpl tag))))))))
(defun org-link-open (link &optional arg)
"Open a link object LINK.
ARG is an optional prefix argument. Some link types may handle
it. For example, it determines what application to run when
opening a \"file\" link.
Functions responsible for opening the link are either hard-coded
for internal and \"file\" links, or stored as a parameter in
`org-link-parameters', which see."
(let ((type (org-element-property :type link))
(path (org-element-property :path link)))
(pcase type
;; Opening a "file" link requires special treatment since we
;; first need to integrate search option, if any.
("file"
(let* ((option (org-element-property :search-option link))
(path (if option (concat path "::" option) path)))
(org-link-open-as-file path
(pcase (org-element-property :application link)
((guard arg) arg)
("emacs" 'emacs)
("sys" 'system)))))
;; Internal links.
((or "coderef" "custom-id" "fuzzy" "radio")
(unless (run-hook-with-args-until-success 'org-open-link-functions path)
(if (not arg) (org-mark-ring-push)
(switch-to-buffer-other-window (org-link--buffer-for-internals)))
(let ((destination
(org-with-wide-buffer
(if (equal type "radio")
(org-link--search-radio-target path)
(org-link-search
(pcase type
("custom-id" (concat "#" path))
("coderef" (format "(%s)" path))
(_ path))
;; Prevent fuzzy links from matching themselves.
(and (equal type "fuzzy")
(+ 2 (org-element-begin link)))))
(point))))
(unless (and (<= (point-min) destination)
(>= (point-max) destination))
(widen))
(goto-char destination))))
(_
;; Look for a dedicated "follow" function in custom links.
(let ((f (org-link-get-parameter type :follow)))
(when (functionp f)
;; Function defined in `:follow' parameter may use a single
;; argument, as it was mandatory before Org 9.4. This is
;; deprecated, but support it for now.
(condition-case nil
(funcall f path arg)
(wrong-number-of-arguments
(funcall f path)))))))))
(defun org-link-open-from-string (s &optional arg)
"Open a link in the string S, as if it was in Org mode.
Optional argument ARG is passed to `org-open-file' when S is a
\"file\" link."
(interactive "sLink: \nP")
(pcase (with-temp-buffer
(let ((org-inhibit-startup nil))
(insert s)
(org-mode)
(goto-char (point-min))
(org-element-link-parser)))
(`nil (user-error "No valid link in %S" s))
(link (org-link-open link arg))))
(defun org-link-search (s &optional avoid-pos stealth new-heading-container)
"Search for a search string S in the accessible part of the buffer.
If S starts with \"#\", it triggers a custom ID search.
If S is enclosed within parenthesis, it initiates a coderef
search.
If S is surrounded by forward slashes, it is interpreted as
a regular expression. In Org mode files, this will create an
`org-occur' sparse tree. In ordinary files, `occur' will be used
to list matches. If the current buffer is in `dired-mode', grep
will be used to search in all files.
When AVOID-POS is given, ignore matches near that position.
When optional argument STEALTH is non-nil, do not modify
visibility around point, thus ignoring `org-show-context-detail'
variable.
When optional argument NEW-HEADING-CONTAINER is an element, any
new heading that is created (see
`org-link-search-must-match-exact-headline') will be added as a
subheading of NEW-HEADING-CONTAINER. Otherwise, new headings are
created at level 1 at the end of the accessible part of the
buffer.
Search is case-insensitive and ignores white spaces. Return type
of matched result, which is either `dedicated' or `fuzzy'. Search
respects buffer narrowing."
(unless (org-string-nw-p s) (error "Invalid search string \"%s\"" s))
(let* ((case-fold-search t)
(origin (point))
(normalized (replace-regexp-in-string "\n[ \t]*" " " s))
(starred (eq (string-to-char normalized) ?*))
(words (split-string (if starred (substring s 1) s)))
(s-multi-re (mapconcat #'regexp-quote words "\\(?:[ \t\n]+\\)"))
(s-single-re (mapconcat #'regexp-quote words "[ \t]+"))
type)
(cond
;; Check if there are any special search functions.
((run-hook-with-args-until-success 'org-execute-file-search-functions s))
((eq (string-to-char s) ?#)
;; Look for a custom ID S if S starts with "#".
(let* ((id (substring normalized 1))
(match (org-find-property "CUSTOM_ID" id)))
(if match (progn (goto-char match) (setf type 'dedicated))
(error "No match for custom ID: %s" id))))
((string-match "\\`(\\(.*\\))\\'" normalized)
;; Look for coderef targets if S is enclosed within parenthesis.
(let ((coderef (match-string-no-properties 1 normalized))
(re (substring s-single-re 1 -1)))
(goto-char (point-min))
(catch :coderef-match
(while (re-search-forward re nil t)
(let ((element (org-element-at-point)))
(when (and (org-element-type-p element '(example-block src-block))
(org-match-line
(concat ".*?" (org-src-coderef-regexp
(org-src-coderef-format element)
coderef))))
(setq type 'dedicated)
(goto-char (match-beginning 2))
(throw :coderef-match nil))))
(goto-char origin)
(error "No match for coderef: %s" coderef))))
((string-match "\\`/\\(.*\\)/\\'" normalized)
;; Look for a regular expression.
(funcall (if (derived-mode-p 'org-mode) #'org-occur #'org-do-occur)
(match-string 1 s)))
;; From here, we handle fuzzy links.
;;
;; Look for targets, only if not in a headline search.
((and (not starred)
(let ((target (format "<<%s>>" s-multi-re)))
(catch :target-match
(goto-char (point-min))
(while (re-search-forward target nil t)
(backward-char)
(let ((context (org-element-context)))
(when (org-element-type-p context 'target)
(setq type 'dedicated)
(goto-char (org-element-begin context))
(throw :target-match t))))
nil))))
;; Look for elements named after S, only if not in a headline
;; search.
((and (not starred)
(let ((name (format "^[ \t]*#\\+NAME: +%s[ \t]*$" s-single-re)))
(catch :name-match
(goto-char (point-min))
(while (re-search-forward name nil t)
(let* ((element (org-element-at-point))
(name (org-element-property :name element)))
(when (and name (equal (mapcar #'upcase words) (mapcar #'upcase (split-string name))))
(setq type 'dedicated)
(forward-line 0)
(throw :name-match t))))
nil))))
;; Regular text search. Prefer headlines in Org mode buffers.
;; Ignore COMMENT keyword, TODO keywords, priority cookies,
;; statistics cookies and tags.
((and (derived-mode-p 'org-mode)
(let ((title-re
(format "%s.*\\(?:%s[ \t]\\)?.*%s"
org-outline-regexp-bol
org-comment-string
(mapconcat #'regexp-quote words ".+"))))
(goto-char (point-min))
(catch :found
(while (re-search-forward title-re nil t)
(when (equal (mapcar #'upcase words)
(mapcar #'upcase
(split-string
(org-link--normalize-string
(org-get-heading t t t t)))))
(throw :found t)))
nil)))
(forward-line 0)
(setq type 'dedicated))
;; Offer to create non-existent headline depending on
;; `org-link-search-must-match-exact-headline'.
((and (derived-mode-p 'org-mode)
(eq org-link-search-must-match-exact-headline 'query-to-create)
(yes-or-no-p "No match - create this as a new heading? "))
(let* ((container-ok (and new-heading-container
(org-element-type-p new-heading-container '(headline))))
(new-heading-position (if container-ok
(- (org-element-end new-heading-container) 1)
(point-max)))
(new-heading-level (if container-ok
(+ 1 (org-element-property :level new-heading-container))
1)))
;; Need to widen when target is outside accessible portion of
;; buffer, since the we want the user to end up there.
(unless (and (<= (point-min) new-heading-position)
(>= (point-max) new-heading-position))
(widen))
(goto-char new-heading-position)
(unless (bolp) (newline))
(org-insert-heading nil t new-heading-level)
(insert (if starred (substring s 1) s) "\n")
(forward-line -1)))
;; Only headlines are looked after. No need to process
;; further: throw an error.
((and (derived-mode-p 'org-mode)
(or starred org-link-search-must-match-exact-headline))
(goto-char origin)
(error "No match for fuzzy expression: %s" normalized))
;; Regular text search.
((catch :fuzzy-match
(goto-char (point-min))
(while (re-search-forward s-multi-re nil t)
;; Skip match if it contains AVOID-POS or it is included in
;; a link with a description but outside the description.
(unless (or (and avoid-pos
(<= (match-beginning 0) avoid-pos)
(> (match-end 0) avoid-pos))
(and (save-match-data
(org-in-regexp org-link-bracket-re))
(match-beginning 3)
(or (> (match-beginning 3) (point))
(<= (match-end 3) (point)))
(org-element-lineage
(save-match-data (org-element-context))
'link t)))
(goto-char (match-beginning 0))
(setq type 'fuzzy)
(throw :fuzzy-match t)))
nil))
;; All failed. Throw an error.
(t (goto-char origin)
(error "No match for fuzzy expression: %s" normalized)))
;; Disclose surroundings of match, if appropriate.
(when (and (derived-mode-p 'org-mode) (not stealth))
(org-fold-show-context 'link-search))
type))
(defun org-link-heading-search-string (&optional string)
"Make search string for the current headline or STRING.
Search string starts with an asterisk. COMMENT keyword and
statistics cookies are removed, and contiguous spaces are packed
into a single one.
When optional argument STRING is non-nil, assume it a headline,
without any asterisk, TODO or COMMENT keyword, and without any
priority cookie or tag."
(concat "*"
(org-link--normalize-string
(or string (org-get-heading t t t t)))))
(defun org-link-precise-link-target ()
"Determine search string and description for storing a link.
If a search string (see `org-link-search') is found, return
list (SEARCH-STRING DESC POSITION). Otherwise, return nil.
If there is an active region, the contents (or a part of it, see
`org-link-context-for-files') is used as the search string.
In Org buffers, if point is at a named element (such as a source
block), the name is used for the search string. If at a heading,
its CUSTOM_ID is used to form a search string of the form
\"#id\", if present, otherwise the current heading text is used
in the form \"*Heading\".
If none of those finds a suitable search string, the current line
is used as the search string.
The description DESC is nil (meaning the user will be prompted
for a description when inserting the link) for search strings
based on a region or the current line. For other cases, DESC is
a cleaned-up version of the name or heading at point.
POSITION is the buffer position at which the search string
matches."
(let* ((region (org-link--context-from-region))
(result
(cond
(region
(list (org-link--normalize-string region t)
nil
(region-beginning)))
((derived-mode-p 'org-mode)
(let* ((element (org-element-at-point))
(name (org-element-property :name element))
(heading (org-element-lineage element '(headline inlinetask) t))
(custom-id (org-entry-get heading "CUSTOM_ID")))
(cond
(name
(list name
name
(org-element-begin element)))
((org-before-first-heading-p)
(list (org-link--normalize-string (org-current-line-string) t)
nil
(line-beginning-position)))
(heading
(list (if custom-id (concat "#" custom-id)
(org-link-heading-search-string))
(org-link--normalize-string
(org-get-heading t t t t))
(org-element-begin heading))))))
;; Not in an org-mode buffer, no region
(t
(list (org-link--normalize-string (org-current-line-string) t)
nil
(line-beginning-position))))))
;; Only use search option if there is some text.
(when (org-string-nw-p (car result))
result)))
(defun org-link-open-as-file (path in-emacs)
"Pretend PATH is a file name and open it.
IN-EMACS is passed to `org-open-file'.
According to \"file\"-link syntax, PATH may include additional
search options, separated from the file name with \"::\".
This function is meant to be used as a possible tool for
`:follow' property in `org-link-parameters'."
(let* ((option (and (string-match "::\\(.*\\)\\'" path)
(match-string 1 path)))
(file-name (if (not option) path
(substring path 0 (match-beginning 0)))))
(if (and (string-match "[*?{]" (file-name-nondirectory file-name))
(not (file-exists-p file-name)))
(dired file-name)
(apply #'org-open-file
file-name
in-emacs
(cond ((not option) nil)
((string-match-p "\\`[0-9]+\\'" option)
(list (string-to-number option)))
(t (list nil option)))))))
(defun org-link-display-format (s)
"Replace links in string S with their description.
If there is no description, use the link target."
(save-match-data
(replace-regexp-in-string
org-link-bracket-re
(lambda (m) (or (match-string 2 m) (match-string 1 m)))
s nil t)))
(defun org-link-add-angle-brackets (s)
"Wrap string S within angle brackets."
(unless (equal (substring s 0 1) "<") (setq s (concat "<" s)))
(unless (equal (substring s -1) ">") (setq s (concat s ">")))
s)
;;; Built-in link types
;;;; "elisp" link type
(defun org-link--open-elisp (path _)
"Open a \"elisp\" type link.
PATH is the sexp to evaluate, as a string."
(if (or (and (org-string-nw-p org-link-elisp-skip-confirm-regexp)
(string-match-p org-link-elisp-skip-confirm-regexp path))
(not org-link-elisp-confirm-function)
(funcall org-link-elisp-confirm-function
(format "Execute %s as Elisp? "
(org-add-props path nil 'face 'org-warning))))
(message "%s => %s" path
(if (eq ?\( (string-to-char path))
(eval (read path))
(call-interactively (read path))))
(user-error "Abort")))
(org-link-set-parameters "elisp" :follow #'org-link--open-elisp)
;;;; "file" link type
(org-link-set-parameters "file" :complete #'org-link-complete-file)
;;;; "help" link type
(defun org-link--open-help (path _)
"Open a \"help\" type link.
PATH is a symbol name, as a string."
(pcase (intern path)
((and (pred fboundp) function) (describe-function function))
((and (pred boundp) variable) (describe-variable variable))
(name (user-error "Unknown function or variable: %s" name))))
(defun org-link--store-help (&optional _interactive?)
"Store \"help\" type link."
(when (eq major-mode 'help-mode)
(let ((symbol
(save-excursion
(goto-char (point-min))
;; In case the help is about the key-binding, store the
;; function instead.
(search-forward "runs the command " (line-end-position) t)
(read (current-buffer)))))
(org-link-store-props :type "help"
:link (format "help:%s" symbol)
:description nil))))
(org-link-set-parameters "help"
:follow #'org-link--open-help
:store #'org-link--store-help)
;;;; "http", "https", "mailto", "ftp", and "news" link types
(dolist (scheme '("ftp" "http" "https" "mailto" "news"))
(org-link-set-parameters scheme
:follow
(lambda (url arg)
(browse-url (concat scheme ":" url) arg))))
;;;; "shell" link type
(defun org-link--open-shell (path _)
"Open a \"shell\" type link.
PATH is the command to execute, as a string."
(if (or (and (org-string-nw-p org-link-shell-skip-confirm-regexp)
(string-match-p org-link-shell-skip-confirm-regexp path))
(not org-link-shell-confirm-function)
(funcall org-link-shell-confirm-function
(format "Execute %s in shell? "
(org-add-props path nil 'face 'org-warning))))
(let ((buf (generate-new-buffer "*Org Shell Output*")))
(message "Executing %s" path)
(shell-command path buf)
(when (featurep 'midnight)
(setq clean-buffer-list-kill-buffer-names
(cons (buffer-name buf)
clean-buffer-list-kill-buffer-names))))
(user-error "Abort")))
(org-link-set-parameters "shell" :follow #'org-link--open-shell)
;;; Interactive Functions
;;;###autoload
(defun org-next-link (&optional search-backward)
"Move forward to the next link.
If the link is in hidden text, expose it. When SEARCH-BACKWARD
is non-nil, move backward."
(interactive)
(let ((pos (point))
(search-fun (if search-backward #'re-search-backward
#'re-search-forward)))
;; Tweak initial position. If last search failed, wrap around.
;; Otherwise, make sure we do not match current link.
(cond
((not (and org-link--search-failed (eq this-command last-command)))
(cond
((and (not search-backward) (looking-at org-link-any-re))
(goto-char (match-end 0)))
(search-backward
(pcase (org-in-regexp org-link-any-re nil t)
(`(,beg . ,_) (goto-char beg))
(_ nil)))
(t nil)))
(search-backward
(goto-char (point-max))
(message "Link search wrapped back to end of buffer"))
(t
(goto-char (point-min))
(message "Link search wrapped back to beginning of buffer")))
(setq org-link--search-failed nil)
(catch :found
(while (funcall search-fun org-link-any-re nil t)
(let ((context (save-excursion
(unless search-backward (forward-char -1))
(org-element-context))))
(pcase (org-element-lineage context 'link t)
(`nil nil)
(link
(goto-char (org-element-begin link))
(when (org-invisible-p) (org-fold-show-context 'link-search))
(throw :found t)))))
(goto-char pos)
(setq org-link--search-failed t)
(message "No further link found"))))
;;;###autoload
(defun org-previous-link ()
"Move backward to the previous link.
If the link is in hidden text, expose it."
(interactive)
(org-next-link t))
;;;###autoload
(defun org-toggle-link-display ()
"Toggle the literal or descriptive display of links in current buffer."
(interactive)
(setq org-link-descriptive (not org-link-descriptive))
(org-restart-font-lock))
;;;###autoload
(defun org-store-link (arg &optional interactive?)
"Store a link to the current location.
\\
This link is added to `org-stored-links' and can later be inserted
into an Org buffer with `org-insert-link' (`\\[org-insert-link]').
When optional argument INTERACTIVE? is nil, the link is not stored in
`org-stored-links', but returned as a string.
For some link types, a `\\[universal-argument]' prefix ARG is interpreted. \
A single
`\\[universal-argument]' negates `org-link-context-for-files' for file links or
`org-gnus-prefer-web-links' for links to Usenet articles.
A `\\[universal-argument] \\[universal-argument]' prefix ARG forces \
skipping storing functions that are not
part of Org core.
A `\\[universal-argument] \\[universal-argument] \\[universal-argument]' \
prefix ARG forces storing a link for each line in the
active region.
Assume the function is called interactively if INTERACTIVE? is
non-nil.
In Org buffers, an additional \"human-readable\" simple file link
is stored as an alternative to persistent org-id or other links,
if at a heading with a CUSTOM_ID property or an element with a
NAME."
(interactive "P\np")
(org-load-modules-maybe)
(if (and (equal arg '(64)) (org-region-active-p))
(save-excursion
(let ((end (region-end)))
(goto-char (region-beginning))
(set-mark (point))
(while (< (line-end-position) end)
(move-end-of-line 1) (activate-mark)
(let (current-prefix-arg)
(call-interactively 'org-store-link))
(move-beginning-of-line 2)
(set-mark (point)))))
(setq org-store-link-plist nil)
;; Negate `org-context-in-file-links' when given a single universal arg.
(let ((org-link-context-for-files (org-xor org-link-context-for-files
(equal arg '(4))))
link desc search agenda-link) ;; description
(cond
;; Store a link using an external link type, if any function is
;; available, unless external link types are skipped for this
;; call using two universal args. If more than one function
;; can generate a link from current location, ask the user
;; which one to use.
((and (not (equal arg '(16)))
(org-link--try-link-store-functions interactive?))
(setq link (plist-get org-store-link-plist :link))
;; If store function actually set `:description' property, use
;; it, even if it is nil. Otherwise, fallback to nil (ask user).
(setq desc (plist-get org-store-link-plist :description)))
;; Store a link from a remote editing buffer.
((org-src-edit-buffer-p)
(let ((coderef-format (org-src-coderef-format))
(format-link
(lambda (label)
(if org-src-source-file-name
(format "file:%s::(%s)" org-src-source-file-name label)
(format "(%s)" label)))))
(cond
;; Code references do not exist in this type of buffer.
;; Pretend we're linking from the source buffer directly.
((not (memq (org-src-source-type) '(example-block src-block)))
(with-current-buffer (org-src-source-buffer)
(org-store-link arg interactive?))
(setq link nil))
;; A code reference exists. Use it.
((save-excursion
(forward-line 0)
(re-search-forward (org-src-coderef-regexp coderef-format)
(line-end-position)
t))
(setq link (funcall format-link (match-string-no-properties 3))))
;; No code reference. Create a new one then store the link
;; to it, but only in the function is called interactively.
(interactive?
(end-of-line)
(let* ((label (read-string "Code line label: "))
(reference (format coderef-format label))
(gc (- 79 (length reference))))
(if (< (current-column) gc)
(org-move-to-column gc t)
(insert " "))
(insert reference)
(setq link (funcall format-link label))))
;; No code reference, and non-interactive call. Don't know
;; what to do. Give up.
(t (setq link nil)))))
;; We are in the agenda, link to referenced location
((eq major-mode 'org-agenda-mode)
(let ((m (or (get-text-property (point) 'org-hd-marker)
(get-text-property (point) 'org-marker))))
(when m
(org-with-point-at m
(setq agenda-link (org-store-link nil interactive?))))))
;; Calendar mode
((eq major-mode 'calendar-mode)
(let ((cd (calendar-cursor-to-date)))
(setq link
(format-time-string
(org-time-stamp-format)
(org-encode-time 0 0 0 (nth 1 cd) (nth 0 cd) (nth 2 cd))))
(org-link-store-props :type "calendar" :date cd)))
;; Image mode
((eq major-mode 'image-mode)
(setq link (concat "file:"
(abbreviate-file-name buffer-file-name)))
(org-link-store-props :type "image" :file buffer-file-name))
;; In dired, store a link to the file of the current line
((derived-mode-p 'dired-mode)
(let ((file (dired-get-filename nil t)))
(setq file (if file
(abbreviate-file-name
(expand-file-name (dired-get-filename nil t)))
;; Otherwise, no file so use current directory.
default-directory))
(setq link (concat "file:" file))))
;; Try `org-create-file-search-functions`. If any are
;; successful, create a file link to the current buffer with
;; the provided search string.
((setq search (run-hook-with-args-until-success
'org-create-file-search-functions))
(setq link (concat "file:" (abbreviate-file-name buffer-file-name)
"::" search)
desc (plist-get org-store-link-plist :description)))
;; Main logic for storing built-in link types in org-mode
;; buffers
((and (buffer-file-name (buffer-base-buffer)) (derived-mode-p 'org-mode))
(org-with-limited-levels
(cond
;; Store a link using the target at point
((org-in-regexp "[^<]<<\\([^<>]+\\)>>[^>]" 1)
(setq link
(concat "file:"
(abbreviate-file-name
(buffer-file-name (buffer-base-buffer)))
"::" (match-string 1))
;; Target may be shortened when link is inserted.
;; Avoid [[target][file:~/org/test.org::target]]
;; links. Maybe the case of identical target and
;; description should be handled by `org-insert-link'.
desc nil))
(t
;; Just link to current headline.
(let ((here (org-link--file-link-to-here)))
(setq link (car here))
(setq desc (cdr here)))))))
;; Buffer linked to file, but not an org-mode buffer.
((buffer-file-name (buffer-base-buffer))
;; Just link to this file here.
(let ((here (org-link--file-link-to-here)))
(setq link (car here))
(setq desc (cdr here))))
(interactive?
(user-error "No method for storing a link from this buffer"))
(t (setq link nil)))
;; We're done setting link and desc, clean up
(when (consp link) (setq link (or (cdr link) (car link))))
(cond ((not desc))
((equal desc "NONE") (setq desc nil))
(t (setq desc (org-link-display-format desc))))
;; Store and return the link
(if (not (and interactive? link))
(or agenda-link (and link (org-link-make-string link desc)))
(org-link--add-to-stored-links link desc)
;; In org buffers, store an additional "human-readable" link
;; using custom id, if available.
(when (and (buffer-file-name (buffer-base-buffer))
(derived-mode-p 'org-mode)
(org-entry-get nil "CUSTOM_ID"))
(let ((here (org-link--file-link-to-here)))
(setq link (car here))
(setq desc (cdr here)))
(unless (equal (list link desc) (car org-stored-links))
(org-link--add-to-stored-links link desc)))
(car org-stored-links)))))
;;;###autoload
(defun org-insert-link (&optional complete-file link-location description)
"Insert a link. At the prompt, enter the link.
Completion can be used to insert any of the link protocol prefixes in use.
The history can be used to select a link previously stored with
`org-store-link'. When the empty string is entered (i.e. if you just
press `RET' at the prompt), the link defaults to the most recently
stored link. As `SPC' triggers completion in the minibuffer, you need to
use `M-SPC' or `C-q SPC' to force the insertion of a space character.
Completion candidates include link descriptions.
If there is a link under cursor then edit it.
You will also be prompted for a description, and if one is given, it will
be displayed in the buffer instead of the link.
If there is already a link at point, this command will allow you to edit
link and description parts.
With a `\\[universal-argument]' prefix, prompts for a file to link to. The \
file name can be
selected using completion. The path to the file will be relative to the
current directory if the file is in the current directory or a subdirectory.
Otherwise, the link will be the absolute path as completed in the minibuffer
\(i.e. normally ~/path/to/file). You can configure this behavior using the
option `org-link-file-path-type'.
With a `\\[universal-argument] \\[universal-argument]' prefix, enforce an \
absolute path even if the file is in
the current directory or below.
A `\\[universal-argument] \\[universal-argument] \\[universal-argument]' \
prefix negates `org-link-keep-stored-after-insertion'.
If the LINK-LOCATION parameter is non-nil, this value will be used as
the link location instead of reading one interactively.
If the DESCRIPTION parameter is non-nil, this value will be used
as the default description. If not, and the chosen link type has
a non-nil `:insert-description' parameter, that is used to
generate a description as described in `org-link-parameters'
docstring. Otherwise, if `org-link-make-description-function' is
non-nil, this function will be called with the link target, and
the result will be the default link description. When called
non-interactively, don't allow editing the default description."
(interactive "P")
(let* ((wcf (current-window-configuration))
(origbuf (current-buffer))
(region (when (org-region-active-p)
(buffer-substring (region-beginning) (region-end))))
(remove (and region (list (region-beginning) (region-end))))
(desc region)
(link link-location)
(abbrevs org-link-abbrev-alist-local)
(all-prefixes (append (mapcar #'car abbrevs)
(mapcar #'car org-link-abbrev-alist)
(org-link-types)))
entry link-original)
(cond
(link-location) ; specified by arg, just use it.
((org-in-regexp org-link-bracket-re 1)
;; We do have a link at point, and we are going to edit it.
(setq remove (list (match-beginning 0) (match-end 0)))
(setq desc (when (match-end 2) (match-string-no-properties 2)))
(setq link (read-string "Link: "
(org-link-unescape
(match-string-no-properties 1)))))
((or (org-in-regexp org-link-angle-re)
(org-in-regexp org-link-plain-re))
;; Convert to bracket link
(setq remove (list (match-beginning 0) (match-end 0))
link (read-string "Link: "
(org-unbracket-string "<" ">" (match-string 0)))))
((member complete-file '((4) (16)))
;; Completing read for file names.
(setq link (org-link-complete-file complete-file)))
(t
;; Read link, with completion for stored links.
(org-link--fontify-links-to-this-file)
(switch-to-buffer-other-window "*Org Links*")
(with-current-buffer "*Org Links*"
(read-only-mode 1)
(let ((inhibit-read-only t)
;; FIXME Duplicate: Also in 'ox.el'.
(propertize-help-key
(lambda (key)
;; Add `face' *and* `font-lock-face' to "work
;; reliably in any buffer", per a comment in
;; `help--key-description-fontified'.
(propertize key
'font-lock-face 'help-key-binding
'face 'help-key-binding))))
(erase-buffer)
(insert
(apply #'format "Type %s to complete link type, then %s to complete destination.\n"
(mapcar propertize-help-key
(list "TAB" "RET"))))
(when org-stored-links
(insert (apply #'format "\nStored links accessible with %s/%s or %s/%s are:\n\n"
(mapcar propertize-help-key
(list "" ""
"M-p" "M-n"
"RET"))))
(insert (mapconcat #'org-link--prettify
(reverse org-stored-links)
"\n"))))
(goto-char (point-min)))
(when (get-buffer-window "*Org Links*" 'visible)
(let ((cw (selected-window)))
(select-window (get-buffer-window "*Org Links*" 'visible))
(with-current-buffer "*Org Links*" (setq truncate-lines t))
(unless (pos-visible-in-window-p (point-max))
(org-fit-window-to-buffer))
(and (window-live-p cw) (select-window cw))))
(unwind-protect
;; Fake a link history, containing the stored links.
(let ((org-link--history
(append (mapcar #'car org-stored-links)
org-link--insert-history)))
(setq link
(org-completing-read
(org-format-prompt "Insert link" (caar org-stored-links))
(append
(mapcar (lambda (x) (concat x ":")) all-prefixes)
(mapcar #'car org-stored-links)
;; Allow description completion. Avoid "nil" option
;; in the case of `completing-read-default' when
;; some links have no description.
(delq nil (mapcar 'cadr org-stored-links)))
nil nil nil
'org-link--history
(caar org-stored-links)))
(unless (org-string-nw-p link) (user-error "No link selected"))
(dolist (l org-stored-links)
(when (equal link (cadr l))
(setq link (car l))))
(when (or (member link all-prefixes)
(and (equal ":" (substring link -1))
(member (substring link 0 -1) all-prefixes)
(setq link (substring link 0 -1))))
(setq link (with-current-buffer origbuf
(org-link--try-special-completion link)))))
(when-let* ((window (get-buffer-window "*Org Links*" t)))
(quit-window 'kill window))
(set-window-configuration wcf)
(when (get-buffer "*Org Links*")
(kill-buffer "*Org Links*")))
(setq entry (assoc link org-stored-links))
(or entry (push link org-link--insert-history))
(setq desc (or desc (nth 1 entry)))))
(setq link-original link)
(when (and (string-match org-link-plain-re link)
(not (string-match org-ts-regexp link)))
;; URL-like link, normalize the use of angular brackets.
(setq link (org-unbracket-string "<" ">" link)))
;; Check if we are linking to the current file with a search
;; option If yes, simplify the link by using only the search
;; option.
(when (and (buffer-file-name (buffer-base-buffer))
(let ((case-fold-search nil))
(string-match "\\`file:\\(.+?\\)::" link)))
(let ((path (match-string-no-properties 1 link))
(search (substring-no-properties link (match-end 0))))
(save-match-data
(when (equal (file-truename (buffer-file-name (buffer-base-buffer)))
(file-truename path))
;; We are linking to this same file, with a search option
(setq link search)))))
;; Check if we can/should use a relative path. If yes, simplify
;; the link.
(let ((case-fold-search nil))
(when (string-match "\\`\\(file\\|docview\\):" link)
(let* ((type (match-string-no-properties 0 link))
(path-start (match-end 0))
(search (and (string-match "::\\(.*\\)\\'" link)
(match-string 1 link)))
(path
(if search
(substring-no-properties
link path-start (match-beginning 0))
(substring-no-properties link (match-end 0))))
(origpath path))
(cond
((or (eq org-link-file-path-type 'absolute)
(equal complete-file '(16)))
(setq path (abbreviate-file-name (expand-file-name path))))
((eq org-link-file-path-type 'noabbrev)
(setq path (expand-file-name path)))
((eq org-link-file-path-type 'relative)
(setq path (file-relative-name path)))
((functionp org-link-file-path-type)
(setq path (funcall org-link-file-path-type path)))
(t
(save-match-data
(if (string-match (concat "^" (regexp-quote
(expand-file-name
(file-name-as-directory
default-directory))))
(expand-file-name path))
;; We are linking a file with relative path name.
(setq path (substring (expand-file-name path)
(match-end 0)))
(setq path (abbreviate-file-name (expand-file-name path)))))))
(setq link (concat type path (and search (concat "::" search))))
(when (equal desc origpath)
(setq desc path)))))
(let* ((type
(cond
((and all-prefixes
(string-match (rx-to-string `(: string-start (submatch (or ,@all-prefixes)) ":")) link))
(match-string 1 link))
((file-name-absolute-p link) "file")
((string-match "\\`\\.\\.?/" link) "file")))
(initial-input
(cond
(description)
(desc)
((org-link-get-parameter type :insert-description)
(let ((def (org-link-get-parameter type :insert-description)))
(condition-case nil
(cond
((stringp def) def)
((functionp def)
(funcall def link desc)))
(error
(message "Can't get link description from org link parameter `:insert-description': %S"
def)
(sit-for 2)
nil))))
(org-link-make-description-function
(condition-case nil
(funcall org-link-make-description-function link desc)
(error
(message "Can't get link description from %S"
org-link-make-description-function)
(sit-for 2)
nil))))))
(setq desc (if (called-interactively-p 'any)
(read-string "Description: " initial-input)
initial-input)))
(when (funcall (if (equal complete-file '(64)) 'not 'identity)
(not org-link-keep-stored-after-insertion))
(setq org-stored-links (delq (assoc link-original org-stored-links)
org-stored-links)))
(unless (org-string-nw-p desc) (setq desc nil))
(when remove (apply #'delete-region remove))
(insert (org-link-make-string link desc))
;; Redisplay so as the new link has proper invisible characters.
(sit-for 0)))
;;;###autoload
(defun org-insert-all-links (arg &optional pre post)
"Insert all links in `org-stored-links'.
When a universal prefix, do not delete the links from `org-stored-links'.
When `ARG' is a number, insert the last N link(s).
`PRE' and `POST' are optional arguments to define a string to
prepend or to append."
(interactive "P")
(let ((org-link-keep-stored-after-insertion (equal arg '(4)))
(links (copy-sequence org-stored-links))
(pr (or pre "- "))
(po (or post "\n"))
(cnt 1) l)
(if (null org-stored-links)
(message "No link to insert")
(while (and (or (listp arg) (>= arg cnt))
(setq l (if (listp arg)
(pop links)
(pop org-stored-links))))
(setq cnt (1+ cnt))
(insert pr)
(org-insert-link nil (car l) (or (cadr l) ""))
(insert po)))))
;;;###autoload
(defun org-insert-last-stored-link (arg)
"Insert the last link stored in `org-stored-links'."
(interactive "p")
(org-insert-all-links arg "" "\n"))
;;;###autoload
(defun org-insert-link-global ()
"Insert a link like Org mode does.
This command can be called in any mode to insert a link in Org syntax."
(interactive)
(org-load-modules-maybe)
(org-run-like-in-org-mode 'org-insert-link))
(defun org--re-list-search-forward (regexp-list &optional bound noerror count)
"Like `re-search-forward', but REGEXP-LIST is a list of regexps.
BOUND, NOERROR, and COUNT are passed to `re-search-forward'."
(let (result (min-found most-positive-fixnum)
(pos-found nil)
(min-found-data nil)
(tail regexp-list))
(while tail
(setq result (save-excursion (re-search-forward (pop tail) bound t count)))
(when (and result (< result min-found))
(setq min-found result
pos-found (match-end 0)
min-found-data (match-data))))
(if (= most-positive-fixnum min-found)
(pcase noerror
(`t nil)
(_ (re-search-forward (car regexp-list) bound noerror count)))
(set-match-data min-found-data)
(goto-char pos-found))))
(defun org--re-list-looking-at (regexp-list &optional inhibit-modify)
"Like `looking-at', but REGEXP-LIST is a list of regexps.
INHIBIT-MODIFY is passed to `looking-at'."
(catch :found
(while regexp-list
(when
(if inhibit-modify
(looking-at-p (pop regexp-list))
;; FIXME: In Emacs <29, `looking-at' does not accept
;; optional INHIBIT-MODIFY argument.
(looking-at (pop regexp-list)))
(throw :found t)))))
;;;###autoload
(defun org-update-radio-target-regexp ()
"Find all radio targets in this file and update the regular expression.
Also refresh fontification if needed."
(interactive)
(let ((old-regexp org-target-link-regexp)
;; Some languages, e.g., Chinese, do not use spaces to
;; separate words. Also allow surrounding radio targets with
;; line-breakable characters.
(before-re "\\(?:^\\|[^[:alnum:]]\\|\\c|\\)\\(")
(after-re "\\)\\(?:$\\|[^[:alnum:]]\\|\\c|\\)")
(targets
(org-with-wide-buffer
(goto-char (point-min))
(let (rtn)
(while (re-search-forward org-radio-target-regexp nil t)
;; Make sure point is really within the object.
(backward-char)
(let ((obj (org-element-context)))
(when (org-element-type-p obj 'radio-target)
(cl-pushnew (org-element-property :value obj) rtn
:test #'equal))))
rtn))))
(setq targets
(sort targets
(lambda (a b)
(> (length a) (length b)))))
(setq org-target-link-regexp
(and targets
(concat before-re
(mapconcat
(lambda (x)
(replace-regexp-in-string
" +" "\\s-+" (regexp-quote x) t t))
targets
"\\|")
after-re)))
(setq org-target-link-regexps nil)
(let (current-length sub-targets)
(when (<= org-target-link-regexp-limit (length org-target-link-regexp))
(while (or targets sub-targets)
(when (and sub-targets
(or (not targets)
(>= (+ current-length (length (car targets)))
org-target-link-regexp-limit)))
(push (concat before-re
(mapconcat
(lambda (x)
(replace-regexp-in-string
" +" "\\s-+" (regexp-quote x) t t))
(nreverse sub-targets)
"\\|")
after-re)
org-target-link-regexps)
(setq current-length nil
sub-targets nil))
(unless current-length
(setq current-length (+ (length before-re) (length after-re))))
(when targets (push (pop targets) sub-targets))
(cl-incf current-length (length (car sub-targets))))
(setq org-target-link-regexps (nreverse org-target-link-regexps))))
(unless (equal old-regexp org-target-link-regexp)
;; Clean-up cache.
(let ((regexp (cond ((not old-regexp) org-target-link-regexp)
((not org-target-link-regexp) old-regexp)
(t
(concat before-re
(mapconcat
(lambda (re)
(substring re (length before-re)
(- (length after-re))))
(list old-regexp org-target-link-regexp)
"\\|")
after-re)))))
(when (and (featurep 'org-element)
(not (bound-and-true-p org-mode-loading)))
(if org-target-link-regexps
(org-element-cache-reset)
(org-with-point-at 1
(while (re-search-forward regexp nil t)
(org-element-cache-refresh (match-beginning 1)))))))
;; Re fontify buffer.
(when (memq 'radio org-highlight-links)
(org-restart-font-lock)))))
;;; Initialize Regexps
(org-link-make-regexps)
(provide 'ol)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; ol.el ends here
org-mode-9.7.29+dfsg/lisp/org-agenda.el 0000664 0000000 0000000 00001560655 15004304337 0017570 0 ustar 00root root 0000000 0000000 ;;; org-agenda.el --- Dynamic task and appointment lists for Org -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2025 Free Software Foundation, Inc.
;; Author: Carsten Dominik
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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
These commands will be offered on the splash screen displayed by the
agenda dispatcher `\\[org-agenda]'. Each entry is a list like this:
(key desc type match settings files)
key The key (one or more characters as a string) to be associated
with the command.
desc A description of the command. When omitted or nil, a default
description is built using MATCH.
type The command type, any of the following symbols:
agenda The daily/weekly agenda.
agenda* Appointments for current week/day.
todo Entries with a specific TODO keyword, in all agenda files.
search Entries containing search words entry or headline.
tags Tags/Property/TODO match in all agenda files.
tags-todo Tags/P/T match in all agenda files, TODO entries only.
todo-tree Sparse tree of specific TODO keyword in *current* file.
tags-tree Sparse tree with all tags matches in *current* file.
occur-tree Occur sparse tree for *current* file.
alltodo The global TODO list.
stuck Stuck projects.
... A user-defined function.
match What to search for:
- a single keyword for TODO keyword searches
- a tags/property/todo match expression for searches
- a word search expression for text searches.
- a regular expression for occur searches
For all other commands, this should be the empty string.
settings A list of option settings, similar to that in a let form, so like
this: ((opt1 val1) (opt2 val2) ...). The values will be
evaluated at the moment of execution, so quote them when needed.
files A list of files to write the produced agenda buffer to with
the command `org-store-agenda-views'.
If a file name ends in \".html\", an HTML version of the buffer
is written out. If it ends in \".ps\", a PostScript version is
produced. Otherwise, only the plain text is written to the file.
You can also define a set of commands, to create a composite agenda buffer.
In this case, an entry looks like this:
(key desc (cmd1 cmd2 ...) general-settings-for-whole-set files)
where
desc A description string to be displayed in the dispatcher menu.
cmd An agenda command, similar to the above. However, tree commands
are not allowed. Valid commands for a set are:
(agenda \"\" settings)
(agenda* \"\" settings)
(alltodo \"\" settings)
(stuck \"\" settings)
(todo \"match\" settings files)
(search \"match\" settings files)
(tags \"match\" settings files)
(tags-todo \"match\" settings files)
Each command can carry a list of options, and another set of options can be
given for the whole set of commands. Individual command options take
precedence over the general options.
When using several characters as key to a command, the first characters
are prefix commands. For the dispatcher to display useful information, you
should provide a description for the prefix, like
(setq org-agenda-custom-commands
\\='((\"h\" . \"HOME + Name tag searches\") ; describe prefix \"h\"
(\"hl\" tags \"+HOME+Lisa\")
(\"hp\" tags \"+HOME+Peter\")
(\"hk\" tags \"+HOME+Kim\")))
See also Info node `(org) Custom Agenda Views'."
:group 'org-agenda-custom-commands
:type `(repeat
(choice :value ("x" "Describe command here" tags "" nil)
(list :tag "Single command"
(string :tag "Access Key(s) ")
(option (string :tag "Description"))
(choice
(const :tag "Agenda" agenda)
(const :tag "TODO list" alltodo)
(const :tag "Search words" search)
(const :tag "Stuck projects" stuck)
(const :tag "Tags/Property match (all agenda files)" tags)
(const :tag "Tags/Property match of TODO entries (all agenda files)" tags-todo)
(const :tag "TODO keyword search (all agenda files)" todo)
(const :tag "Tags sparse tree (current buffer)" tags-tree)
(const :tag "TODO keyword tree (current buffer)" todo-tree)
(const :tag "Occur tree (current buffer)" occur-tree)
(sexp :tag "Other, user-defined function"))
(string :tag "Match (only for some commands)")
,org-agenda-custom-commands-local-options
(option (repeat :tag "Export" (file :tag "Export to"))))
(list :tag "Command series, all agenda files"
(string :tag "Access Key(s)")
(string :tag "Description ")
(repeat :tag "Component"
(choice
(list :tag "Agenda"
(const :format "" agenda)
(const :tag "" :format "" "")
,org-agenda-custom-commands-local-options)
(list :tag "TODO list (all keywords)"
(const :format "" alltodo)
(const :tag "" :format "" "")
,org-agenda-custom-commands-local-options)
(list :tag "Search words"
(const :format "" search)
(string :tag "Match")
,org-agenda-custom-commands-local-options)
(list :tag "Stuck projects"
(const :format "" stuck)
(const :tag "" :format "" "")
,org-agenda-custom-commands-local-options)
(list :tag "Tags/Property match (all agenda files)"
(const :format "" tags)
(string :tag "Match")
,org-agenda-custom-commands-local-options)
(list :tag "Tags/Property match of TODO entries (all agenda files)"
(const :format "" tags-todo)
(string :tag "Match")
,org-agenda-custom-commands-local-options)
(list :tag "TODO keyword search"
(const :format "" todo)
(string :tag "Match")
,org-agenda-custom-commands-local-options)
(list :tag "Other, user-defined function"
(symbol :tag "function")
(string :tag "Match")
,org-agenda-custom-commands-local-options)))
(repeat :tag "Settings for entire command set"
(list (variable :tag "Any variable")
(sexp :tag "Value")))
(option (repeat :tag "Export" (file :tag "Export to"))))
(cons :tag "Prefix key documentation"
(string :tag "Access Key(s)")
(string :tag "Description ")))))
(defcustom org-agenda-query-register ?o
"The register holding the current query string.
The purpose of this is that if you construct a query string interactively,
you can then use it to define a custom command."
:group 'org-agenda-custom-commands
:type 'character)
(defcustom org-stuck-projects
'("+LEVEL=2/-DONE" ("TODO" "NEXT" "NEXTACTION") nil "")
"How to identify stuck projects.
This is a list of four items:
1. A tags/todo/property matcher string that is used to identify a project.
See Info node `(org) Matching tags and properties' for a
description of tag and property searches. The entire tree
below a headline matched by this is considered one project.
2. A list of TODO keywords identifying non-stuck projects.
If the project subtree contains any headline with one of these todo
keywords, the project is considered to be not stuck. If you specify
\"*\" as a keyword, any TODO keyword will mark the project unstuck.
3. A list of tags identifying non-stuck projects.
If the project subtree contains any headline with one of these tags,
the project is considered to be not stuck. If you specify \"*\" as
a tag, any tag will mark the project unstuck. Note that this is about
the explicit presence of a tag somewhere in the subtree, inherited
tags do not count here. If inherited tags make a project not stuck,
use \"-TAG\" in the tags part of the matcher under (1.) above.
4. An arbitrary regular expression matching non-stuck projects.
If the project turns out to be not stuck, search continues also in the
subtree to see if any of the subtasks have project status.
See also the variable `org-tags-match-list-sublevels' which applies
to projects matched by this search as well.
After defining this variable, you may use `org-agenda-list-stuck-projects'
\(bound to `\\[org-agenda] #') to produce the list."
:group 'org-agenda-custom-commands
:type '(list
(string :tag "Tags/TODO match to identify a project")
(repeat :tag "Projects are *not* stuck if they have an entry with \
TODO keyword any of" (string))
(repeat :tag "Projects are *not* stuck if they have an entry with \
TAG being any of" (string))
(regexp :tag "Projects are *not* stuck if this regexp matches inside \
the subtree")))
(defgroup org-agenda-skip nil
"Options concerning skipping parts of agenda files."
:tag "Org Agenda Skip"
:group 'org-agenda)
(defcustom org-agenda-skip-function-global nil
"Function to be called at each match during agenda construction.
If this function returns nil, the current match should not be skipped.
If the function decided to skip an agenda match, is must return the
buffer position from which the search should be continued.
This may also be a Lisp form, which will be evaluated.
This variable will be applied to every agenda match, including
tags/property searches and TODO lists. So try to make the test function
do its checking as efficiently as possible. To implement a skipping
condition just for specific agenda commands, use the variable
`org-agenda-skip-function' which can be set in the options section
of custom agenda commands."
:group 'org-agenda-skip
:type 'sexp)
(defgroup org-agenda-daily/weekly nil
"Options concerning the daily/weekly agenda."
:tag "Org Agenda Daily/Weekly"
:group 'org-agenda)
(defgroup org-agenda-todo-list nil
"Options concerning the global todo list agenda view."
:tag "Org Agenda Todo List"
:group 'org-agenda)
(defgroup org-agenda-match-view nil
"Options concerning the general tags/property/todo match agenda view."
:tag "Org Agenda Match View"
:group 'org-agenda)
(defgroup org-agenda-search-view nil
"Options concerning the search agenda view."
:tag "Org Agenda Search View"
:group 'org-agenda)
(defvar org-agenda-archives-mode nil
"Non-nil means the agenda will include archived items.
If this is the symbol `trees', trees in the selected agenda scope
that are marked with the ARCHIVE tag will be included anyway. When this is
t, also all archive files associated with the current selection of agenda
files will be included.")
(defcustom org-agenda-restriction-lock-highlight-subtree t
"Non-nil means highlight the whole subtree when restriction is active.
Otherwise only highlight the headline. Highlighting the whole subtree is
useful to ensure no edits happen beyond the restricted region."
:group 'org-agenda
:type 'boolean)
(defcustom org-agenda-skip-comment-trees t
"Non-nil means skip trees that start with the COMMENT keyword.
When nil, these trees are also scanned by agenda commands."
:group 'org-agenda-skip
:type 'boolean)
(defcustom org-agenda-todo-list-sublevels t
"Non-nil means check also the sublevels of a TODO entry for TODO entries.
When nil, the sublevels of a TODO entry are not checked, resulting in
potentially much shorter TODO lists."
:group 'org-agenda-skip
:group 'org-agenda-todo-list
:type 'boolean)
(defcustom org-agenda-todo-ignore-with-date nil
"Non-nil means don't show entries with a date in the global todo list.
You can use this if you prefer to mark mere appointments with a TODO keyword,
but don't want them to show up in the TODO list.
When this is set, it also covers deadlines and scheduled items, the settings
of `org-agenda-todo-ignore-scheduled' and `org-agenda-todo-ignore-deadlines'
will be ignored.
See also the variable `org-agenda-tags-todo-honor-ignore-options'."
:group 'org-agenda-skip
:group 'org-agenda-todo-list
:type 'boolean)
(defcustom org-agenda-todo-ignore-timestamp nil
"Non-nil means don't show entries with a timestamp.
This applies when creating the global todo list.
Valid values are:
past Don't show entries for today or in the past.
future Don't show entries with a timestamp in the future.
The idea behind this is that if it has a future
timestamp, you don't want to think about it until the
date.
all Don't show any entries with a timestamp in the global todo list.
The idea behind this is that by setting a timestamp, you
have already \"taken care\" of this item.
This variable can also have an integer as a value. If positive (N),
todos with a timestamp N or more days in the future will be ignored. If
negative (-N), todos with a timestamp N or more days in the past will be
ignored. If 0, todos with a timestamp either today or in the future will
be ignored. For example, a value of -1 will exclude todos with a
timestamp in the past (yesterday or earlier), while a value of 7 will
exclude todos with a timestamp a week or more in the future.
See also `org-agenda-todo-ignore-with-date'.
See also the variable `org-agenda-tags-todo-honor-ignore-options' if you want
to make his option also apply to the tags-todo list."
:group 'org-agenda-skip
:group 'org-agenda-todo-list
:version "24.1"
:type '(choice
(const :tag "Ignore future timestamp todos" future)
(const :tag "Ignore past or present timestamp todos" past)
(const :tag "Ignore all timestamp todos" all)
(const :tag "Show timestamp todos" nil)
(integer :tag "Ignore if N or more days in past(-) or future(+).")))
(defcustom org-agenda-todo-ignore-scheduled nil
"Non-nil means, ignore some scheduled TODO items when making TODO list.
This applies when creating the global todo list.
Valid values are:
past Don't show entries scheduled today or in the past.
future Don't show entries scheduled in the future.
The idea behind this is that by scheduling it, you don't want to
think about it until the scheduled date.
all Don't show any scheduled entries in the global todo list.
The idea behind this is that by scheduling it, you have already
\"taken care\" of this item.
t Same as `all', for backward compatibility.
This variable can also have an integer as a value. See
`org-agenda-todo-ignore-timestamp' for more details.
See also `org-agenda-todo-ignore-with-date'.
See also the variable `org-agenda-tags-todo-honor-ignore-options' if you want
to make his option also apply to the tags-todo list."
:group 'org-agenda-skip
:group 'org-agenda-todo-list
:type '(choice
(const :tag "Ignore future-scheduled todos" future)
(const :tag "Ignore past- or present-scheduled todos" past)
(const :tag "Ignore all scheduled todos" all)
(const :tag "Ignore all scheduled todos (compatibility)" t)
(const :tag "Show scheduled todos" nil)
(integer :tag "Ignore if N or more days in past(-) or future(+).")))
(defcustom org-agenda-todo-ignore-deadlines nil
"Non-nil means ignore some deadline TODO items when making TODO list.
There are different motivations for using different values, please think
carefully when configuring this variable.
This applies when creating the global TODO list.
Valid values are:
near Don't show near deadline entries. A deadline is near when it is
closer than `org-deadline-warning-days' days. The idea behind this
is that such items will appear in the agenda anyway.
far Don't show TODO entries where a deadline has been defined, but
is not going to happen anytime soon. This is useful if you want to use
the TODO list to figure out what to do now.
past Don't show entries with a deadline timestamp for today or in the past.
future Don't show entries with a deadline timestamp in the future, not even
when they become `near' ones. Use it with caution.
all Ignore all TODO entries that do have a deadline.
t Same as `near', for backward compatibility.
This variable can also have an integer as a value. See
`org-agenda-todo-ignore-timestamp' for more details.
See also `org-agenda-todo-ignore-with-date'.
See also the variable `org-agenda-tags-todo-honor-ignore-options' if you want
to make his option also apply to the tags-todo list."
:group 'org-agenda-skip
:group 'org-agenda-todo-list
:type '(choice
(const :tag "Ignore near deadlines" near)
(const :tag "Ignore near deadlines (compatibility)" t)
(const :tag "Ignore far deadlines" far)
(const :tag "Ignore all TODOs with a deadlines" all)
(const :tag "Show all TODOs, even if they have a deadline" nil)
(integer :tag "Ignore if N or more days in past(-) or future(+).")))
(defcustom org-agenda-todo-ignore-time-comparison-use-seconds nil
"Time unit to use when possibly ignoring an agenda item.
See the docstring of various `org-agenda-todo-ignore-*' options.
The default is to compare time stamps using days. An item is thus
considered to be in the future if it is at least one day after today.
Non-nil means to compare time stamps using seconds. An item is then
considered future if it has a time value later than current time."
:group 'org-agenda-skip
:group 'org-agenda-todo-list
:version "24.4"
:package-version '(Org . "8.0")
:type '(choice
(const :tag "Compare time with days" nil)
(const :tag "Compare time with seconds" t)))
(defcustom org-agenda-tags-todo-honor-ignore-options nil
"Non-nil means honor todo-list ignores options also in tags-todo search.
The variables
`org-agenda-todo-ignore-with-date',
`org-agenda-todo-ignore-timestamp',
`org-agenda-todo-ignore-scheduled',
`org-agenda-todo-ignore-deadlines'
make the global TODO list skip entries that have time stamps of certain
kinds. If this option is set, the same options will also apply for the
tags-todo search, which is the general tags/property matcher
restricted to unfinished TODO entries only."
:group 'org-agenda-skip
:group 'org-agenda-todo-list
:group 'org-agenda-match-view
:type 'boolean)
(defcustom org-agenda-skip-scheduled-if-done nil
"Non-nil means don't show scheduled items in agenda when they are done.
This is relevant for the daily/weekly agenda, not for the TODO list. It
applies only to the actual date of the scheduling. Warnings about an item
with a past scheduling dates are always turned off when the item is DONE."
:group 'org-agenda-skip
:group 'org-agenda-daily/weekly
:type 'boolean)
(defcustom org-agenda-skip-scheduled-if-deadline-is-shown nil
"Non-nil means skip scheduling line if same entry shows because of deadline.
In the agenda of today, an entry can show up multiple times
because it is both scheduled and has a nearby deadline, and maybe
a plain time stamp as well.
When this variable is nil, the entry will be shown several times.
When set to t, then only the deadline is shown and the fact that
the entry is scheduled today or was scheduled previously is not
shown.
When set to the symbol `not-today', skip scheduled previously,
but not scheduled today."
:group 'org-agenda-skip
:group 'org-agenda-daily/weekly
:type '(choice
(const :tag "Never" nil)
(const :tag "Always" t)
(const :tag "Not when scheduled today" not-today))
:package-version '(Org . "9.7"))
(defcustom org-agenda-skip-timestamp-if-deadline-is-shown nil
"Non-nil means skip timestamp line if same entry shows because of deadline.
In the agenda of today, an entry can show up multiple times
because it has both a plain timestamp and has a nearby deadline.
When this variable is t, then only the deadline is shown and the
fact that the entry has a timestamp for or including today is not
shown. When this variable is nil, the entry will be shown
several times."
:group 'org-agenda-skip
:group 'org-agenda-daily/weekly
:version "24.1"
:type '(choice
(const :tag "Never" nil)
(const :tag "Always" t)))
(defcustom org-agenda-skip-deadline-if-done nil
"Non-nil means don't show deadlines when the corresponding item is done.
When nil, the deadline is still shown and should give you a happy feeling.
This is relevant for the daily/weekly agenda. It applies only to the
actual date of the deadline. Warnings about approaching and past-due
deadlines are always turned off when the item is DONE."
:group 'org-agenda-skip
:group 'org-agenda-daily/weekly
:type 'boolean)
(defcustom org-agenda-skip-deadline-prewarning-if-scheduled nil
"Non-nil means skip deadline prewarning when entry is also scheduled.
This will apply on all days where a prewarning for the deadline would
be shown, but not at the day when the entry is actually due. On that day,
the deadline will be shown anyway.
This variable may be set to nil, t, the symbol `pre-scheduled',
or a number which will then give the number of days before the actual
deadline when the prewarnings should resume. The symbol `pre-scheduled'
eliminates the deadline prewarning only prior to the scheduled date.
This can be used in a workflow where the first showing of the deadline will
trigger you to schedule it, and then you don't want to be reminded of it
because you will take care of it on the day when scheduled."
:group 'org-agenda-skip
:group 'org-agenda-daily/weekly
:version "24.1"
:type '(choice
(const :tag "Always show prewarning" nil)
(const :tag "Remove prewarning prior to scheduled date" pre-scheduled)
(const :tag "Remove prewarning if entry is scheduled" t)
(integer :tag "Restart prewarning N days before deadline")))
(defcustom org-agenda-skip-scheduled-delay-if-deadline nil
"Non-nil means skip scheduled delay when entry also has a deadline.
This variable may be set to nil, t, the symbol `post-deadline',
or a number which will then give the number of days after the actual
scheduled date when the delay should expire. The symbol `post-deadline'
eliminates the schedule delay when the date is posterior to the deadline."
:group 'org-agenda-skip
:group 'org-agenda-daily/weekly
:version "24.4"
:package-version '(Org . "8.0")
:type '(choice
(const :tag "Always honor delay" nil)
(const :tag "Ignore delay if posterior to the deadline" post-deadline)
(const :tag "Ignore delay if entry has a deadline" t)
(integer :tag "Honor delay up until N days after the scheduled date")))
(defcustom org-agenda-skip-additional-timestamps-same-entry nil
"When nil, multiple same-day timestamps in entry make multiple agenda lines.
When non-nil, after the search for timestamps has matched once in an
entry, the rest of the entry will not be searched."
:group 'org-agenda-skip
:type 'boolean)
(defcustom org-agenda-skip-timestamp-if-done nil
"Non-nil means don't select item by timestamp or -range if it is DONE."
:group 'org-agenda-skip
:group 'org-agenda-daily/weekly
:type 'boolean)
(defcustom org-agenda-dim-blocked-tasks t
"Non-nil means dim blocked tasks in the agenda display.
This causes some overhead during agenda construction, but if you
have turned on `org-enforce-todo-dependencies',
`org-enforce-todo-checkbox-dependencies', or any other blocking
mechanism, this will create useful feedback in the agenda.
Instead of t, this variable can also have the value `invisible'.
Then blocked tasks will be invisible and only become visible when
they become unblocked. An exemption to this behavior is when a task is
blocked because of unchecked checkboxes below it. Since checkboxes do
not show up in the agenda views, making this task invisible you remove any
trace from agenda views that there is something to do. Therefore, a task
that is blocked because of checkboxes will never be made invisible, it
will only be dimmed."
:group 'org-agenda-daily/weekly
:group 'org-agenda-todo-list
:version "24.3"
:type '(choice
(const :tag "Do not dim" nil)
(const :tag "Dim to a gray face" t)
(const :tag "Make invisible" invisible)))
(defgroup org-agenda-startup nil
"Options concerning initial settings in the Agenda in Org Mode."
:tag "Org Agenda Startup"
:group 'org-agenda)
(defcustom org-agenda-menu-show-matcher t
"Non-nil means show the match string in the agenda dispatcher menu.
When nil, the matcher string is not shown, but is put into the help-echo
property so than moving the mouse over the command shows it.
Setting it to nil is good if matcher strings are very long and/or if
you want to use two-columns display (see `org-agenda-menu-two-columns')."
:group 'org-agenda
:version "24.1"
:type 'boolean)
(defcustom org-agenda-menu-two-columns nil
"Non-nil means, use two columns to show custom commands in the dispatcher.
If you use this, you probably want to set `org-agenda-menu-show-matcher'
to nil."
:group 'org-agenda
:version "24.1"
:type 'boolean)
(defcustom org-agenda-finalize-hook nil
"Hook run just before displaying an agenda buffer.
The buffer is still writable when the hook is called.
You can modify some of the buffer substrings but you should be
extra careful not to modify the text properties of the agenda
headlines as the agenda display heavily relies on them."
:group 'org-agenda-startup
:type 'hook)
(defcustom org-agenda-filter-hook nil
"Hook run just after filtering with `org-agenda-filter'."
:group 'org-agenda-startup
:package-version '(Org . "9.4")
:type 'hook)
(defcustom org-agenda-mouse-1-follows-link nil
"Non-nil means \\`mouse-1' on a link will follow the link in the agenda.
A longer mouse click will still set point. Needs to be set
before org.el is loaded."
:group 'org-agenda-startup
:type 'boolean)
(defcustom org-agenda-start-with-follow-mode nil
"The initial value of follow mode in a newly created agenda window."
:group 'org-agenda-startup
:type 'boolean)
(defcustom org-agenda-follow-indirect nil
"Non-nil means `org-agenda-follow-mode' displays only the
current item's tree, in an indirect buffer."
:group 'org-agenda
:version "24.1"
:type 'boolean)
(defcustom org-agenda-show-outline-path t
"Non-nil means show outline path in echo area after line motion.
If set to `title', show outline path with prepended document
title. Fallback to file name is no title is present."
:group 'org-agenda-startup
:type '(choice
(const :tag "Don't show outline path in agenda view." nil)
(const :tag "Show outline path with prepended file name." t)
(const :tag "Show outline path with prepended document title." title))
:package-version '(Org . "9.6"))
(defcustom org-agenda-start-with-entry-text-mode nil
"The initial value of entry-text-mode in a newly created agenda window."
:group 'org-agenda-startup
:type 'boolean)
(defcustom org-agenda-entry-text-maxlines 5
"Number of text lines to be added when `E' is pressed in the agenda.
Note that this variable only used during agenda display. To add entry text
when exporting the agenda, configure the variable
`org-agenda-add-entry-text-maxlines'."
:group 'org-agenda
:type 'integer)
(defcustom org-agenda-entry-text-exclude-regexps nil
"List of regular expressions to clean up entry text.
The complete matches of all regular expressions in this list will be
removed from entry text before it is shown in the agenda."
:group 'org-agenda
:type '(repeat (regexp)))
(defcustom org-agenda-entry-text-leaders " > "
"Text prepended to the entry text in agenda buffers."
:version "24.4"
:package-version '(Org . "8.0")
:group 'org-agenda
:type 'string)
(defcustom org-agenda-start-with-archives-mode nil
"Initial value of archive mode in a newly created agenda window.
See `org-agenda-archives-mode' for acceptable values and their
meaning."
:group 'org-agenda-startup
:package-version '(Org . "9.7")
:type 'symbol)
(defvar org-agenda-entry-text-cleanup-hook nil
"Hook that is run after basic cleanup of entry text to be shown in agenda.
This cleanup is done in a temporary buffer, so the function may inspect and
change the entire buffer.
Some default stuff like drawers and scheduling/deadline dates will already
have been removed when this is called, as will any matches for regular
expressions listed in `org-agenda-entry-text-exclude-regexps'.")
(defvar org-agenda-include-inactive-timestamps nil
"Non-nil means include inactive time stamps in agenda.
Dynamically scoped.")
(defgroup org-agenda-windows nil
"Options concerning the windows used by the Agenda in Org Mode."
:tag "Org Agenda Windows"
:group 'org-agenda)
(defcustom org-agenda-window-setup 'reorganize-frame
"How the agenda buffer should be displayed.
Possible values for this option are:
current-window Show agenda in the current window, keeping all other windows.
other-window Use `switch-to-buffer-other-window' to display agenda.
only-window Show agenda, deleting all other windows.
reorganize-frame Show only two windows on the current frame, the current
window and the agenda.
other-frame Use `switch-to-buffer-other-frame' to display agenda.
Also, when exiting the agenda, kill that frame.
other-tab Use `switch-to-buffer-other-tab' to display the
agenda, making use of the `tab-bar-mode' introduced
in Emacs version 27.1. Also, kill that tab when
exiting the agenda view.
See also the variable `org-agenda-restore-windows-after-quit'."
:group 'org-agenda-windows
:type '(choice
(const current-window)
(const other-frame)
(const other-tab)
(const other-window)
(const only-window)
(const reorganize-frame))
:package-version '(Org . "9.4"))
(defcustom org-agenda-window-frame-fractions '(0.5 . 0.75)
"The min and max height of the agenda window as a fraction of frame height.
The value of the variable is a cons cell with two numbers between 0 and 1.
It only matters if `org-agenda-window-setup' is `reorganize-frame'."
:group 'org-agenda-windows
:type '(cons (number :tag "Minimum") (number :tag "Maximum")))
(defcustom org-agenda-restore-windows-after-quit nil
"Non-nil means restore window configuration upon exiting agenda.
Before the window configuration is changed for displaying the
agenda, the current status is recorded. When the agenda is
exited with `q' or `x' and this option is set, the old state is
restored. If `org-agenda-window-setup' is `other-frame' or
`other-tab', the value of this option will be ignored."
:group 'org-agenda-windows
:type 'boolean)
(defcustom org-agenda-span 'week
"Number of days to include in overview display.
Can be day, week, month, year, or any number of days.
Custom commands can set this variable in the options section."
:group 'org-agenda-daily/weekly
:type '(choice (const :tag "Day" day)
(const :tag "Week" week)
(const :tag "Fortnight" fortnight)
(const :tag "Month" month)
(const :tag "Year" year)
(integer :tag "Custom")))
(defcustom org-agenda-start-on-weekday 1
"Non-nil means start the overview always on the specified weekday.
0 denotes Sunday, 1 denotes Monday, etc.
When nil, always start on the current day.
Custom commands can set this variable in the options section.
This variable only applies when agenda spans either 7 or 14 days."
:group 'org-agenda-daily/weekly
:type '(choice (const :tag "Today" nil)
(integer :tag "Weekday No.")))
(defcustom org-agenda-show-all-dates t
"Non-nil means `org-agenda' shows every day in the selected range.
When nil, only the days which actually have entries are shown."
:group 'org-agenda-daily/weekly
:type 'boolean)
(defcustom org-agenda-format-date 'org-agenda-format-date-aligned
"Format string for displaying dates in the agenda.
Used by the daily/weekly agenda. This should be a format string
understood by `format-time-string', or a function returning the
formatted date as a string. The function must take a single
argument, a calendar-style date list like (month day year)."
:group 'org-agenda-daily/weekly
:type '(choice
(string :tag "Format string")
(function :tag "Function")))
(defun org-agenda-end-of-line ()
"Go to the end of visible line."
(interactive)
(goto-char (line-end-position)))
(defun org-agenda-format-date-aligned (date)
"Format a DATE string for display in the daily/weekly agenda.
This function makes sure that dates are aligned for easy reading."
(require 'cal-iso)
(let* ((dayname (calendar-day-name date))
(day (cadr date))
(day-of-week (calendar-day-of-week date))
(month (car date))
(monthname (calendar-month-name month))
(year (nth 2 date))
(iso-week (org-days-to-iso-week
(calendar-absolute-from-gregorian date)))
;; (weekyear (cond ((and (= month 1) (>= iso-week 52))
;; (1- year))
;; ((and (= month 12) (<= iso-week 1))
;; (1+ year))
;; (t year)))
(weekstring (if (= day-of-week 1)
(format " W%02d" iso-week)
"")))
(format "%-10s %2d %s %4d%s"
dayname day monthname year weekstring)))
(defcustom org-agenda-time-leading-zero nil
"Non-nil means use leading zero for military times in agenda.
For example, 9:30am would become 09:30 rather than 9:30."
:group 'org-agenda-daily/weekly
:version "24.1"
:type 'boolean)
(defcustom org-agenda-timegrid-use-ampm nil
"When set, show AM/PM style timestamps on the timegrid."
:group 'org-agenda
:version "24.1"
:type 'boolean)
(defcustom org-agenda-clock-report-header nil
"Header inserted before the table in Org agenda clock report mode.
See Info node `(org) Agenda Commands' for more details."
:group 'org-agenda
:type '(choice
(string :tag "Header")
(const :tag "No header" nil))
:safe #'stringp
:package-version '(Org . "9.6"))
(defun org-agenda-time-of-day-to-ampm (time)
"Convert TIME of a string like \"13:45\" to an AM/PM style time string."
(let* ((hour-number (string-to-number (substring time 0 -3)))
(minute (substring time -2))
(ampm "am"))
(cond
((equal hour-number 12)
(setq ampm "pm"))
((> hour-number 12)
(setq ampm "pm")
(setq hour-number (- hour-number 12))))
(concat
(if org-agenda-time-leading-zero
(format "%02d" hour-number)
(format "%02s" (number-to-string hour-number)))
":" minute ampm)))
(defun org-agenda-time-of-day-to-ampm-maybe (time)
"Conditionally convert TIME to AM/PM format.
This is based on `org-agenda-timegrid-use-ampm'."
(if org-agenda-timegrid-use-ampm
(org-agenda-time-of-day-to-ampm time)
time))
(defcustom org-agenda-weekend-days '(6 0)
"Which days are weekend?
These days get the special face `org-agenda-date-weekend' in the agenda."
:group 'org-agenda-daily/weekly
:type '(set :greedy t
(const :tag "Monday" 1)
(const :tag "Tuesday" 2)
(const :tag "Wednesday" 3)
(const :tag "Thursday" 4)
(const :tag "Friday" 5)
(const :tag "Saturday" 6)
(const :tag "Sunday" 0)))
(defcustom org-agenda-move-date-from-past-immediately-to-today t
"Non-nil means jump to today when moving a past date forward in time.
When using S-right in the agenda to move a date forward, and the date
stamp currently points to the past, the first key press will move it
to today. When nil, just move one day forward even if the date stays
in the past."
:group 'org-agenda-daily/weekly
:version "24.1"
:type 'boolean)
(defcustom org-agenda-diary-file 'diary-file
"File to which to add new entries with the `i' key in agenda and calendar.
When this is the symbol `diary-file', the functionality in the Emacs
calendar will be used to add entries to the `diary-file'. But when this
points to a file, `org-agenda-diary-entry' will be used instead."
:group 'org-agenda
:type '(choice
(const :tag "The standard Emacs diary file" diary-file)
(file :tag "Special Org file diary entries")))
(defcustom org-agenda-include-diary nil
"If non-nil, include in the agenda entries from the Emacs Calendar's diary.
Custom commands can set this variable in the options section."
:group 'org-agenda-daily/weekly
:type 'boolean)
(defcustom org-agenda-include-deadlines t
"If non-nil, include entries within their deadline warning period.
Custom commands can set this variable in the options section."
:group 'org-agenda-daily/weekly
:version "24.1"
:type 'boolean)
(defcustom org-agenda-show-future-repeats t
"Non-nil shows repeated entries in the future part of the agenda.
When set to the symbol `next' only the first future repeat is shown."
:group 'org-agenda-daily/weekly
:type '(choice
(const :tag "Show all repeated entries" t)
(const :tag "Show next repeated entry" next)
(const :tag "Do not show repeated entries" nil))
:package-version '(Org . "9.1")
:safe #'symbolp)
(defcustom org-agenda-skip-scheduled-repeats-after-deadline nil
"Non-nil hides scheduled repeated entries past deadline."
:group 'org-agenda-daily/weekly
:type 'boolean
:package-version '(Org . "9.7")
:safe t)
(defcustom org-agenda-prefer-last-repeat nil
"Non-nil sets date for repeated entries to their last repeat.
When nil, display SCHEDULED and DEADLINE dates at their base
date, and in today's agenda, as a reminder. Display plain
timestamps, on the other hand, at every repeat date in the past
in addition to the base date.
When non-nil, show a repeated entry at its latest repeat date,
possibly being today even if it wasn't marked as done. This
setting is useful if you do not always mark repeated entries as
done and, yet, consider that reaching repeat date starts the task
anew.
When set to a list of strings, prefer last repeats only for
entries with these TODO keywords."
:group 'org-agenda-daily/weekly
:type '(choice
(const :tag "Prefer last repeat" t)
(const :tag "Prefer base date" nil)
(repeat :tag "Prefer last repeat for entries with these TODO keywords"
(string :tag "TODO keyword")))
:version "26.1"
:package-version '(Org . "9.1")
:safe (lambda (x) (or (booleanp x) (consp x))))
(defcustom org-scheduled-past-days 10000
"Number of days to continue listing scheduled items not marked DONE.
When an item is scheduled on a date, it shows up in the agenda on
this day and will be listed until it is marked done or for the
number of days given here."
:group 'org-agenda-daily/weekly
:type 'integer
:safe 'integerp)
(defcustom org-deadline-past-days 10000
"Number of days to warn about missed deadlines.
When an item has deadline on a date, it shows up in the agenda on
this day and will appear as a reminder until it is marked DONE or
for the number of days given here."
:group 'org-agenda-daily/weekly
:type 'integer
:version "26.1"
:package-version '(Org . "9.1")
:safe 'integerp)
(defcustom org-agenda-log-mode-items '(closed clock)
"List of items that should be shown in agenda log mode.
\\\
This list may contain the following symbols:
closed Show entries that have been closed on that day.
clock Show entries that have received clocked time on that day.
state Show all logged state changes.
Note that instead of changing this variable, you can also press \
`\\[universal-argument] \\[org-agenda-log-mode]' in
the agenda to display all available LOG items temporarily."
:group 'org-agenda-daily/weekly
:type '(set :greedy t (const closed) (const clock) (const state)))
(defcustom org-agenda-clock-consistency-checks
'(:max-duration "10:00" :min-duration 0 :max-gap "0:05"
:gap-ok-around ("4:00")
:default-face ((:background "DarkRed") (:foreground "white"))
:overlap-face nil :gap-face nil :no-end-time-face nil
:long-face nil :short-face nil)
"This is a property list, with the following keys:
:max-duration Mark clocking chunks that are longer than this time.
This is a time string like \"HH:MM\", or the number
of minutes as an integer.
:min-duration Mark clocking chunks that are shorter that this.
This is a time string like \"HH:MM\", or the number
of minutes as an integer.
:max-gap Mark gaps between clocking chunks that are longer than
this duration. A number of minutes, or a string
like \"HH:MM\".
:gap-ok-around List of times during the day which are usually not working
times. When a gap is detected, but the gap contains any
of these times, the gap is *not* reported. For example,
if this is (\"4:00\" \"13:00\") then gaps that contain
4:00 in the morning (i.e. the night) and 13:00
(i.e. a typical lunch time) do not cause a warning.
You should have at least one time during the night in this
list, or otherwise the first task each morning will trigger
a warning because it follows a long gap.
Furthermore, the following properties can be used to define faces for
issue display.
:default-face the default face, if the specific face is undefined
:overlap-face face for overlapping clocks
:gap-face face for gaps between clocks
:no-end-time-face face for incomplete clocks
:long-face face for clock intervals that are too long
:short-face face for clock intervals that are too short"
:group 'org-agenda-daily/weekly
:group 'org-clock
:version "24.1"
:type 'plist)
(defcustom org-agenda-log-mode-add-notes t
"Non-nil means add first line of notes to log entries in agenda views.
If a log item like a state change or a clock entry is associated with
notes, the first line of these notes will be added to the entry in the
agenda display."
:group 'org-agenda-daily/weekly
:type 'boolean)
(defcustom org-agenda-start-with-log-mode nil
"The initial value of log-mode in a newly created agenda window.
See `org-agenda-log-mode' and `org-agenda-log-mode-items' for further
explanations on the possible values."
:group 'org-agenda-startup
:group 'org-agenda-daily/weekly
:type '(choice (const :tag "Don't show log items" nil)
(const :tag "Show only log items" only)
(const :tag "Show all possible log items" clockcheck)
(repeat :tag "Choose among possible values for `org-agenda-log-mode-items'"
(choice (const :tag "Show closed log items" closed)
(const :tag "Show clocked log items" clock)
(const :tag "Show all logged state changes" state)))))
(defcustom org-agenda-start-with-clockreport-mode nil
"The initial value of clockreport-mode in a newly created agenda window."
:group 'org-agenda-startup
:group 'org-agenda-daily/weekly
:type 'boolean)
(defcustom org-agenda-clockreport-parameter-plist '(:link t :maxlevel 2)
"Property list with parameters for the clocktable in clockreport mode.
This is the display mode that shows a clock table in the daily/weekly
agenda, the properties for this dynamic block can be set here.
The usual clocktable parameters are allowed here, but you cannot set
the properties :name, :tstart, :tend, :block, and :scope - these will
be overwritten to make sure the content accurately reflects the
current display in the agenda."
:group 'org-agenda-daily/weekly
:type 'plist)
(defvaralias 'org-agenda-search-view-search-words-only
'org-agenda-search-view-always-boolean)
(defcustom org-agenda-search-view-always-boolean nil
"Non-nil means the search string is interpreted as individual parts.
The search string for search view can either be interpreted as a phrase,
or as a list of snippets that define a boolean search for a number of
strings.
When this is non-nil, the string will be split on whitespace, and each
snippet will be searched individually, and all must match in order to
select an entry. A snippet is then a single string of non-white
characters, or a string in double quotes, or a regexp in {} braces.
If a snippet is preceded by \"-\", the snippet must *not* match.
\"+\" is syntactic sugar for positive selection. Each snippet may
be found as a full word or a partial word, but see the variable
`org-agenda-search-view-force-full-words'.
When this is nil, search will look for the entire search phrase as one,
with each space character matching any amount of whitespace, including
line breaks.
Even when this is nil, you can still switch to Boolean search dynamically
by preceding the first snippet with \"+\" or \"-\". If the first snippet
is a regexp marked with braces like \"{abc}\", this will also switch to
boolean search."
:group 'org-agenda-search-view
:version "24.1"
:type 'boolean)
(defcustom org-agenda-search-view-force-full-words nil
"Non-nil means, search words must be matches as complete words.
When nil, they may also match part of a word."
:group 'org-agenda-search-view
:version "24.1"
:type 'boolean)
(defcustom org-agenda-search-view-max-outline-level 0
"Maximum outline level to display in search view.
E.g. when this is set to 1, the search view will only
show headlines of level 1. When set to 0, the default
value, don't limit agenda view by outline level."
:group 'org-agenda-search-view
:version "26.1"
:package-version '(Org . "8.3")
:type 'integer)
(defgroup org-agenda-time-grid nil
"Options concerning the time grid in the Org Agenda."
:tag "Org Agenda Time Grid"
:group 'org-agenda)
(defcustom org-agenda-search-headline-for-time t
"Non-nil means search headline for a time-of-day.
If the headline contains a time-of-day in one format or another, it will
be used to sort the entry into the time sequence of items for a day.
Timestamps in the headline will be ignored."
:group 'org-agenda-time-grid
:type 'boolean)
(defcustom org-agenda-use-time-grid t
"Non-nil means show a time grid in the agenda schedule.
A time grid is a set of lines for specific times (like every two hours between
8:00 and 20:00). The items scheduled for a day at specific times are
sorted in between these lines.
For details about when the grid will be shown, and what it will look like, see
the variable `org-agenda-time-grid'."
:group 'org-agenda-time-grid
:type 'boolean)
(defcustom org-agenda-time-grid
(let ((graphical (and (display-graphic-p)
(char-displayable-p ?┄))))
`((daily today require-timed)
(800 1000 1200 1400 1600 1800 2000)
,(if graphical " ┄┄┄┄┄ " "......")
,(if graphical "┄┄┄┄┄┄┄┄┄┄┄┄┄┄┄" "----------------")))
"The settings for time grid for agenda display.
This is a list of four items. The first item is again a list. It contains
symbols specifying conditions when the grid should be displayed:
daily if the agenda shows a single day
weekly if the agenda shows an entire week
today show grid on current date, independent of daily/weekly display
require-timed show grid only if at least one item has a time specification
remove-match skip grid times already present in an entry
The second item is a list of integers, indicating the times that
should have a grid line.
The third item is a string which will be placed right after the
times that have a grid line.
The fourth item is a string placed after the grid times. This
will align with agenda items."
:group 'org-agenda-time-grid
:package-version '(Org . "9.6")
:type
'(list
(set :greedy t :tag "Grid Display Options"
(const :tag "Show grid in single day agenda display" daily)
(const :tag "Show grid in weekly agenda display" weekly)
(const :tag "Always show grid for today" today)
(const :tag "Show grid only if any timed entries are present"
require-timed)
(const :tag "Skip grid times already present in an entry"
remove-match))
(repeat :tag "Grid Times" (integer :tag "Time"))
(string :tag "Grid String (after agenda times)")
(string :tag "Grid String (aligns with agenda items)")))
(defcustom org-agenda-show-current-time-in-grid t
"Non-nil means show the current time in the time grid."
:group 'org-agenda-time-grid
:version "24.1"
:type 'boolean)
(defcustom org-agenda-current-time-string
(if (and (display-graphic-p)
(char-displayable-p ?←)
(char-displayable-p ?─))
"← now ───────────────────────────────────────────────"
"now - - - - - - - - - - - - - - - - - - - - - - - - -")
"The string for the current time marker in the agenda."
:group 'org-agenda-time-grid
:package-version '(Org . "9.6")
:type 'string)
(defgroup org-agenda-sorting nil
"Options concerning sorting in the Org Agenda."
:tag "Org Agenda Sorting"
:group 'org-agenda)
(defcustom org-agenda-sorting-strategy
'((agenda habit-down time-up urgency-down category-keep)
(todo urgency-down category-keep)
(tags urgency-down category-keep)
(search category-keep))
"Sorting structure for the agenda items of a single day.
This is a list of symbols which will be used in sequence to determine
if an entry should be listed before another entry. The following
symbols are recognized:
time-up Put entries with time-of-day indications first, early first.
time-down Put entries with time-of-day indications first, late first.
timestamp-up Sort by any timestamp date, early first.
timestamp-down Sort by any timestamp date, late first.
scheduled-up Sort by scheduled timestamp date, early first.
scheduled-down Sort by scheduled timestamp date, late first.
deadline-up Sort by deadline timestamp date, early first.
deadline-down Sort by deadline timestamp date, late first.
ts-up Sort by active timestamp date, early first.
ts-down Sort by active timestamp date, late first.
tsia-up Sort by inactive timestamp date, early first.
tsia-down Sort by inactive timestamp date, late first.
category-keep Keep the default order of categories, corresponding to the
sequence in `org-agenda-files'.
category-up Sort alphabetically by category, A-Z.
category-down Sort alphabetically by category, Z-A.
tag-up Sort alphabetically by last tag, A-Z.
tag-down Sort alphabetically by last tag, Z-A.
priority-up Sort numerically by priority, high priority last.
priority-down Sort numerically by priority, high priority first.
urgency-up Sort numerically by urgency, high urgency last.
Urgency is calculated based on item's priority,
and proximity to scheduled time and deadline. See
info node `(org)Sorting of agenda items' for
details.
urgency-down Sort numerically by urgency, high urgency first.
todo-state-up Sort by todo state, tasks that are done last.
todo-state-down Sort by todo state, tasks that are done first.
effort-up Sort numerically by estimated effort, high effort last.
effort-down Sort numerically by estimated effort, high effort first.
user-defined-up Sort according to `org-agenda-cmp-user-defined', high last.
user-defined-down Sort according to `org-agenda-cmp-user-defined', high first.
habit-up Put entries that are habits first.
habit-down Put entries that are habits last.
alpha-up Sort headlines alphabetically.
alpha-down Sort headlines alphabetically, reversed.
The different possibilities will be tried in sequence, and testing stops
if one comparison returns a \"not-equal\". For example,
(setq org-agenda-sorting-strategy
\\='(time-up category-keep priority-down))
means: Pull out all entries having a specified time of day and sort them,
in order to make a time schedule for the current day the first thing in the
agenda listing for the day. Of the entries without a time indication, keep
the grouped in categories, don't sort the categories, but keep them in
the sequence given in `org-agenda-files'. Within each category sort by
priority.
Leaving out `category-keep' would mean that items will be sorted across
categories by priority.
Instead of a single list, this can also be a set of list for specific
contents, with a context symbol in the car of the list, any of
`agenda', `todo', `tags', `search' for the corresponding agenda views.
Custom commands can bind this variable in the options section."
:group 'org-agenda-sorting
:type `(choice
(repeat :tag "General" ,org-sorting-choice)
(list :tag "Individually"
(cons (const :tag "Strategy for Weekly/Daily agenda" agenda)
(repeat ,org-sorting-choice))
(cons (const :tag "Strategy for TODO lists" todo)
(repeat ,org-sorting-choice))
(cons (const :tag "Strategy for Tags matches" tags)
(repeat ,org-sorting-choice))
(cons (const :tag "Strategy for search matches" search)
(repeat ,org-sorting-choice))))
:package-version '(Org . "9.7"))
(defcustom org-agenda-cmp-user-defined nil
"A function to define the comparison `user-defined'.
This function must receive two arguments, agenda entry a and b.
If a>b, return +1. If a effort operator. Then, tasks with no effort defined will be treated
as tasks with high effort.
When nil, such items are sorted as 0 minutes effort."
:group 'org-agenda-sorting
:type 'boolean)
(defgroup org-agenda-line-format nil
"Options concerning the entry prefix in the Org agenda display."
:tag "Org Agenda Line Format"
:group 'org-agenda)
(defcustom org-agenda-prefix-format
'((agenda . " %i %-12:c%?-12t% s")
(todo . " %i %-12:c")
(tags . " %i %-12:c")
(search . " %i %-12:c"))
"Format specifications for the prefix of items in the agenda views.
An alist with one entry per agenda type. The keys of the
sublists are `agenda', `todo', `search' and `tags'. The values
are format strings.
This format works similar to a printf format, with the following meaning:
%c the category of the item, \"Diary\" for entries from the diary,
or as given by the CATEGORY keyword or derived from the file name
%e the effort required by the item
%l the level of the item (insert X space(s) if item is of level X)
%i the icon category of the item, see `org-agenda-category-icon-alist'
%T the last tag of the item (ignore inherited tags, which come first)
%t the HH:MM time-of-day specification if one applies to the entry
%s Scheduling/Deadline information, a short string
%b show breadcrumbs, i.e., the names of the higher levels
%(expression) Eval EXPRESSION and replace the control string
by the result
All specifiers work basically like the standard `%s' of printf, but may
contain two additional characters: a question mark just after the `%'
and a whitespace/punctuation character just before the final letter.
If the first character after `%' is a question mark, the entire field
will only be included if the corresponding value applies to the current
entry. This is useful for fields which should have fixed width when
present, but zero width when absent. For example, \"%?-12t\" will
result in a 12 character time field if a time of the day is specified,
but will completely disappear in entries which do not contain a time.
If there is punctuation or whitespace character just before the
final format letter, this character will be appended to the field
value if the value is not empty. For example, the format
\"%-12:c\" leads to \"Diary: \" if the category is \"Diary\". If
the category is empty, no additional colon is inserted.
The default value for the agenda sublist is \" %-12:c%?-12t% s\",
which means:
- Indent the line with two space characters
- Give the category a 12 chars wide field, padded with whitespace on
the right (because of `-'). Append a colon if there is a category
(because of `:').
- If there is a time-of-day, put it into a 12 chars wide field. If no
time, don't put in an empty field, just skip it (because of '?').
- Finally, put the scheduling information.
See also the variables `org-agenda-remove-times-when-in-prefix' and
`org-agenda-remove-tags'.
Custom commands can set this variable in the options section."
:type '(choice
(string :tag "General format")
(list :greedy t :tag "View dependent"
(cons (const agenda) (string :tag "Format"))
(cons (const todo) (string :tag "Format"))
(cons (const tags) (string :tag "Format"))
(cons (const search) (string :tag "Format"))))
:group 'org-agenda-line-format
:version "26.1"
:package-version '(Org . "9.1"))
(defcustom org-agenda-breadcrumbs-separator "->"
"The separator of breadcrumbs in agenda lines."
:group 'org-agenda-line-format
:package-version '(Org . "9.3")
:type 'string
:safe #'stringp)
(defvar org-prefix-format-compiled nil
"The compiled prefix format and associated variables.
This is a list where first element is a list of variable bindings, and second
element is the compiled format expression. See the variable
`org-agenda-prefix-format'.")
(defcustom org-agenda-todo-keyword-format "%-1s"
"Format for the TODO keyword in agenda lines.
Set this to something like \"%-12s\" if you want all TODO keywords
to occupy a fixed space in the agenda display."
:group 'org-agenda-line-format
:type 'string)
(defcustom org-agenda-diary-sexp-prefix nil
"A regexp that matches part of a diary sexp entry
which should be treated as scheduling/deadline information in
`org-agenda'.
For example, you can use this to extract the `diary-remind-message' from
`diary-remind' entries."
:group 'org-agenda-line-format
:type '(choice (const :tag "None" nil) (regexp :tag "Regexp")))
(defcustom org-agenda-timerange-leaders '("" "(%d/%d): ")
"Text preceding timerange entries in the agenda view.
This is a list with two strings. The first applies when the range
is entirely on one day. The second applies if the range spans several days.
The strings may have two \"%d\" format specifiers which will be filled
with the sequence number of the days, and the total number of days in the
range, respectively."
:group 'org-agenda-line-format
:type '(list
(string :tag "Deadline today ")
(choice :tag "Deadline relative"
(string :tag "Format string")
(function))))
(defcustom org-agenda-scheduled-leaders '("Scheduled: " "Sched.%2dx: ")
"Text preceding scheduled items in the agenda view.
This is a list with two strings. The first applies when the item is
scheduled on the current day. The second applies when it has been scheduled
previously, it may contain a %d indicating that this is the nth time that
this item is scheduled, due to automatic rescheduling of unfinished items
for the following day. So this number is one larger than the number of days
that passed since this item was scheduled first."
:group 'org-agenda-line-format
:version "24.4"
:package-version '(Org . "8.0")
:type '(list
(string :tag "Scheduled today ")
(string :tag "Scheduled previously")))
(defcustom org-agenda-inactive-leader "["
"Text preceding item pulled into the agenda by inactive time stamps.
These entries are added to the agenda when pressing \"[\"."
:group 'org-agenda-line-format
:version "24.1"
:type 'string)
(defcustom org-agenda-deadline-leaders '("Deadline: " "In %3d d.: " "%2d d. ago: ")
"Text preceding deadline items in the agenda view.
This is a list with three strings. The first applies when the item has its
deadline on the current day. The second applies when the deadline is in the
future, the third one when it is in the past. The strings may contain %d
to capture the number of days."
:group 'org-agenda-line-format
:version "24.4"
:package-version '(Org . "8.0")
:type '(list
(string :tag "Deadline today ")
(string :tag "Deadline in the future ")
(string :tag "Deadline in the past ")))
(defcustom org-agenda-remove-times-when-in-prefix t
"Non-nil means remove duplicate time specifications in agenda items.
When the format `org-agenda-prefix-format' contains a `%t' specifier, a
time-of-day specification in a headline or diary entry is extracted and
placed into the prefix. If this option is non-nil, the original specification
\(a timestamp or -range, or just a plain time(range) specification like
11:30-4pm) will be removed for agenda display. This makes the agenda less
cluttered.
The option can be t or nil. It may also be the symbol `beg', indicating
that the time should only be removed when it is located at the beginning of
the headline/diary entry."
:group 'org-agenda-line-format
:type '(choice
(const :tag "Always" t)
(const :tag "Never" nil)
(const :tag "When at beginning of entry" beg)))
(defcustom org-agenda-remove-timeranges-from-blocks nil
"Non-nil means remove time ranges specifications in agenda
items that span on several days."
:group 'org-agenda-line-format
:version "24.1"
:type 'boolean)
(defcustom org-agenda-default-appointment-duration nil
"Default duration for appointments that only have a starting time.
When nil, no duration is specified in such cases.
When non-nil, this must be the number of minutes, e.g. 60 for one hour."
:group 'org-agenda-line-format
:type '(choice
(integer :tag "Minutes")
(const :tag "No default duration")))
(defcustom org-agenda-show-inherited-tags t
"Non-nil means show inherited tags in each agenda line.
When this option is set to `always', it takes precedence over
`org-agenda-use-tag-inheritance' and inherited tags are shown
in every agenda.
When this option is set to t (the default), inherited tags are
shown when they are available, i.e. when the value of
`org-agenda-use-tag-inheritance' enables tag inheritance for the
given agenda type.
This can be set to a list of agenda types in which the agenda
must display the inherited tags. Available types are `todo',
`agenda' and `search'.
When set to nil, never show inherited tags in agenda lines."
:group 'org-agenda-line-format
:group 'org-agenda
:version "24.3"
:type '(choice
(const :tag "Show inherited tags when available" t)
(const :tag "Always show inherited tags" always)
(repeat :tag "Show inherited tags only in selected agenda types"
(symbol :tag "Agenda type"))))
(defcustom org-agenda-use-tag-inheritance '(todo search agenda)
"List of agenda view types where to use tag inheritance.
In tags/tags-todo/tags-tree agenda views, tag inheritance is
controlled by `org-use-tag-inheritance'. In other agenda types,
`org-use-tag-inheritance' is not used for the selection of the
agenda entries. Still, you may want the agenda to be aware of
the inherited tags anyway, e.g. for later tag filtering.
Allowed value are `todo', `search' and `agenda'.
This variable has no effect if `org-agenda-show-inherited-tags'
is set to `always'. In that case, the agenda is aware of those
tags.
The default value sets tags in every agenda type. Setting this
option to nil will speed up non-tags agenda view a lot."
:group 'org-agenda
:version "26.1"
:package-version '(Org . "9.1")
:type '(choice
(const :tag "Use tag inheritance in all agenda types" t)
(repeat :tag "Use tag inheritance in selected agenda types"
(symbol :tag "Agenda type"))))
(defcustom org-agenda-hide-tags-regexp nil
"Regular expression used to filter away specific tags in agenda views.
This means that these tags will be present, but not be shown in the agenda
line. Secondary filtering will still work on the hidden tags.
Nil means don't hide any tags."
:group 'org-agenda-line-format
:type '(choice
(const :tag "Hide none" nil)
(regexp :tag "Regexp ")))
(defvaralias 'org-agenda-remove-tags-when-in-prefix
'org-agenda-remove-tags)
(defcustom org-agenda-remove-tags nil
"Non-nil means remove the tags from the headline copy in the agenda.
When this is the symbol `prefix', only remove tags when
`org-agenda-prefix-format' contains a `%T' specifier."
:group 'org-agenda-line-format
:type '(choice
(const :tag "Always" t)
(const :tag "Never" nil)
(const :tag "When prefix format contains %T" prefix)))
(defvaralias 'org-agenda-align-tags-to-column 'org-agenda-tags-column)
(defcustom org-agenda-tags-column 'auto
"Shift tags in agenda items to this column.
If set to `auto', tags will be automatically aligned to the right
edge of the window.
If set to a positive number, tags will be left-aligned to that
column. If set to a negative number, tags will be right-aligned
to that column. For example, -80 works well for a normal 80
character screen."
:group 'org-agenda-line-format
:type '(choice
(const :tag "Automatically align to right edge of window" auto)
(integer :tag "Specific column" -80))
:package-version '(Org . "9.1")
:version "26.1")
(defcustom org-agenda-fontify-priorities 'cookies
"Non-nil means highlight low and high priorities in agenda.
When t, the highest priority entries are bold, lowest priority italic.
However, settings in `org-priority-faces' will overrule these faces.
When this variable is the symbol `cookies', only fontify the
cookies, not the entire task.
This may also be an association list of priority faces, whose
keys are the character values of `org-priority-highest',
`org-priority-default', and `org-priority-lowest' (the default values
are ?A, ?B, and ?C, respectively). The face may be a named face, a
color as a string, or a list like `(:background \"Red\")'.
If it is a color, the variable `org-faces-easy-properties'
determines if it is a foreground or a background color."
:group 'org-agenda-line-format
:type '(choice
(const :tag "Never" nil)
(const :tag "Defaults" t)
(const :tag "Cookies only" cookies)
(repeat :tag "Specify"
(list (character :tag "Priority" :value ?A)
(choice :tag "Face "
(string :tag "Color")
(sexp :tag "Face"))))))
(defcustom org-agenda-day-face-function nil
"Function called to determine what face should be used to display a day.
The only argument passed to that function is the day. It should
returns a face, or nil if does not want to specify a face and let
the normal rules apply."
:group 'org-agenda-line-format
:version "24.1"
:type '(choice (const nil) (function)))
(defcustom org-agenda-category-icon-alist nil
"Alist of category icon to be displayed in agenda views.
The icons are displayed in place of the %i placeholders in
`org-agenda-prefix-format', which see.
Each entry should have the following format:
(CATEGORY-REGEXP FILE-OR-DATA TYPE DATA-P PROPS)
Where CATEGORY-REGEXP is a regexp matching the categories where
the icon should be displayed.
FILE-OR-DATA either a file path or a string containing image data.
The other fields can be omitted safely if not needed:
TYPE indicates the image type.
DATA-P is a boolean indicating whether the FILE-OR-DATA string is
image data.
PROPS are additional image attributes to assign to the image,
like, e.g. `:ascent center'.
(\"Org\" \"/path/to/icon.png\" nil nil :ascent center)
If you want to set the display properties yourself, just put a
list as second element:
(CATEGORY-REGEXP (MY PROPERTY LIST))
For example, to display a 16px horizontal space for Emacs
category, you can use:
(\"Emacs\" \\='(space . (:width (16))))"
:group 'org-agenda-line-format
:version "24.1"
:type '(alist :key-type (regexp :tag "Regexp matching category")
:value-type (choice (list :tag "Icon"
(string :tag "File or data")
(symbol :tag "Type")
(boolean :tag "Data?")
(repeat :tag "Extra image properties" :inline t sexp))
(list :tag "Display properties" sexp))))
(defgroup org-agenda-column-view nil
"Options concerning column view in the agenda."
:tag "Org Agenda Column View"
:group 'org-agenda)
(defcustom org-agenda-view-columns-initially nil
"When non-nil, switch to columns view right after creating the agenda."
:group 'org-agenda-column-view
:type 'boolean
:version "26.1"
:package-version '(Org . "9.0")
:safe #'booleanp)
(defcustom org-agenda-columns-show-summaries t
"Non-nil means show summaries for columns displayed in the agenda view."
:group 'org-agenda-column-view
:type 'boolean)
(defcustom org-agenda-columns-compute-summary-properties t
"Non-nil means recompute all summary properties before column view.
When column view in the agenda is listing properties that have a summary
operator, it can go to all relevant buffers and recompute the summaries
there. This can mean overhead for the agenda column view, but is necessary
to have thing up to date.
As a special case, a CLOCKSUM property also makes sure that the clock
computations are current."
:group 'org-agenda-column-view
:type 'boolean)
(defcustom org-agenda-columns-add-appointments-to-effort-sum nil
"Non-nil means the duration of an appointment will add to day effort.
The property to which appointment durations will be added is the one given
in the option `org-effort-property'. If an appointment does not have
an end time, `org-agenda-default-appointment-duration' will be used. If that
is not set, an appointment without end time will not contribute to the time
estimate."
:group 'org-agenda-column-view
:type 'boolean)
(defcustom org-agenda-auto-exclude-function nil
"A function called with a tag to decide if it is filtered on \
\\`\\[org-agenda-filter-by-tag] RET'.
The sole argument to the function, which is called once for each
possible tag, is a string giving the name of the tag. The
function should return either nil if the tag should be included
as normal, \"-\" to exclude the tag, or \"+\" to exclude
lines not carrying this tag.
Note that for the purpose of tag filtering, only the lower-case version of
all tags will be considered, so that this function will only ever see
the lower-case version of all tags."
:group 'org-agenda
:type '(choice (const nil) (function)))
(defcustom org-agenda-bulk-custom-functions nil
"Alist of characters and custom functions for bulk actions.
For example, this makes those two functions available:
(setq org-agenda-bulk-custom-functions
\\='((?R set-category)
(?C bulk-cut)))
With selected entries in an agenda buffer, `B R' will call
the custom function `set-category' on the selected entries.
Note that functions in this alist don't need to be quoted.
You can also specify a function which collects arguments to be
used for each call to your bulk custom function. The argument
collecting function will be run once and should return a list of
arguments to pass to the bulk function. For example:
(setq org-agenda-bulk-custom-functions
\\='((?R set-category get-category)))
Now, `B R' will call the custom `get-category' which would prompt
the user once for a category. That category is then passed as an
argument to `set-category' for each entry it's called against."
:type
'(alist :key-type character
:value-type
(group (function :tag "Bulk Custom Function")
(choice (function :tag "Bulk Custom Argument Function")
(const :tag "No Bulk Custom Argument Function" nil))))
:package-version '(Org . "9.5")
:group 'org-agenda)
(defmacro org-agenda-with-point-at-orig-entry (string &rest body)
"Execute BODY with point at location given by `org-hd-marker' property.
If STRING is non-nil, the text property will be fetched from position 0
in that string. If STRING is nil, it will be fetched from the beginning
of the current line."
(declare (debug t) (indent 1))
(org-with-gensyms (marker)
`(let ((,marker (get-text-property (if ,string 0 (line-beginning-position))
'org-hd-marker ,string)))
(with-current-buffer (marker-buffer ,marker)
(save-excursion
(goto-char ,marker)
,@body)))))
(defun org-add-agenda-custom-command (entry)
"Replace or add a command in `org-agenda-custom-commands'.
This is mostly for hacking and trying a new command - once the command
works you probably want to add it to `org-agenda-custom-commands' for good."
(let ((ass (assoc (car entry) org-agenda-custom-commands)))
(if ass
(setcdr ass (cdr entry))
(push entry org-agenda-custom-commands))))
(defmacro org-agenda--insert-overriding-header (default)
"Insert header into agenda view.
The inserted header depends on `org-agenda-overriding-header'.
If the empty string, don't insert a header. If any other string,
insert it as a header. If nil, insert DEFAULT, which should
evaluate to a string. If a function, call it and insert the
string that it returns."
(declare (debug (form)) (indent defun))
`(cond
((not org-agenda-overriding-header) (insert ,default))
((equal org-agenda-overriding-header "") nil)
((stringp org-agenda-overriding-header)
(insert (propertize org-agenda-overriding-header
'face 'org-agenda-structure)
"\n"))
((functionp org-agenda-overriding-header)
(insert (funcall org-agenda-overriding-header)))
(t (user-error "Invalid value for `org-agenda-overriding-header': %S"
org-agenda-overriding-header))))
;;; Define the org-agenda-mode
(defvaralias 'org-agenda-keymap 'org-agenda-mode-map)
(defvar org-agenda-mode-map (make-sparse-keymap)
"Keymap for `org-agenda-mode'.")
(org-remap org-agenda-mode-map 'move-end-of-line 'org-agenda-end-of-line)
(defvar org-agenda-menu) ; defined later in this file.
(defvar org-agenda-restrict nil
"Non-nil means agenda restriction is active.
This is an internal flag indicating either temporary or extended
agenda restriction. Specifically, it is set to t if the agenda
is restricted to an entire file, and is set to the corresponding
buffer if the agenda is restricted to a part of a file, e.g. a
region or a subtree. In the latter case,
`org-agenda-restrict-begin' and `org-agenda-restrict-end' are set
to the beginning and the end of the part.
See also `org-agenda-set-restriction-lock'.")
(defvar org-agenda-follow-mode nil)
(defvar org-agenda-entry-text-mode nil)
(defvar org-agenda-clockreport-mode nil)
(defvar org-agenda-show-log nil
"When non-nil, show the log in the agenda.
Do not set this directly; instead use
`org-agenda-start-with-log-mode', which see.")
(defvar org-agenda-redo-command nil)
(defvar org-agenda-query-string nil)
(defvar org-agenda-mode-hook nil
"Hook run after `org-agenda-mode' is turned on.
The buffer is still writable when this hook is called.")
(defvar org-agenda-type nil)
(defvar org-agenda-force-single-file nil)
(defvar org-agenda-bulk-marked-entries nil
"List of markers that refer to marked entries in the agenda.")
(defvar org-agenda-current-date nil
"Active date when building the agenda.")
;;; Multiple agenda buffers support
(defcustom org-agenda-sticky nil
"Non-nil means agenda q key will bury agenda buffers.
Agenda commands will then show existing buffer instead of generating new ones.
When nil, `q' will kill the single agenda buffer."
:group 'org-agenda
:version "24.3"
:type 'boolean)
;;;###autoload
(defun org-toggle-sticky-agenda (&optional arg)
"Toggle `org-agenda-sticky'."
(interactive "P")
(let ((new-value (if arg
(> (prefix-numeric-value arg) 0)
(not org-agenda-sticky))))
(if (equal new-value org-agenda-sticky)
(and (called-interactively-p 'interactive)
(message "Sticky agenda was already %s"
(if org-agenda-sticky "enabled" "disabled")))
(setq org-agenda-sticky new-value)
(org-agenda-kill-all-agenda-buffers)
(and (called-interactively-p 'interactive)
(message "Sticky agenda %s"
(if org-agenda-sticky "enabled" "disabled"))))))
(defvar org-agenda-buffer nil
"Agenda buffer currently being generated.")
(defvar org-agenda-last-prefix-arg nil)
(defvar org-agenda-this-buffer-name nil)
(defvar org-agenda-doing-sticky-redo nil)
(defvar org-agenda-this-buffer-is-sticky nil)
(defvar org-agenda-last-indirect-buffer nil
"Last buffer loaded by `org-agenda-tree-to-indirect-buffer'.")
(defconst org-agenda-local-vars
'(org-agenda-this-buffer-name
org-agenda-undo-list
org-agenda-pending-undo-list
org-agenda-follow-mode
org-agenda-entry-text-mode
org-agenda-clockreport-mode
org-agenda-show-log
org-agenda-redo-command
org-agenda-query-string
org-agenda-type
org-agenda-bulk-marked-entries
org-agenda-undo-has-started-in
org-agenda-info
org-agenda-pre-window-conf
org-agenda-columns-active
org-agenda-tag-filter
org-agenda-category-filter
org-agenda-top-headline-filter
org-agenda-regexp-filter
org-agenda-effort-filter
org-agenda-filters-preset
org-agenda-markers
org-agenda-last-search-view-search-was-boolean
org-agenda-last-indirect-buffer
org-agenda-filtered-by-category
org-agenda-filter-form
org-agenda-cycle-counter
org-agenda-last-prefix-arg)
"Variables that must be local in agenda buffers to allow multiple buffers.")
(defun org-agenda-mode ()
"Mode for time-sorted view on action items in Org files.
The following commands are available:
\\{org-agenda-mode-map}"
(interactive)
(ignore-errors (require 'face-remap))
(let ((agenda-local-vars-to-keep
'(text-scale-mode-amount
text-scale-mode
text-scale-mode-lighter
face-remapping-alist))
(save (buffer-local-variables)))
(kill-all-local-variables)
(cl-flet ((reset-saved (var-set)
"Reset variables in VAR-SET to possibly stored value in SAVE."
(dolist (elem save)
(pcase elem
(`(,var . ,val) ;ignore unbound variables
(when (and val (memq var var-set))
(set var val)))))))
(cond (org-agenda-doing-sticky-redo
;; Refreshing sticky agenda-buffer
;;
;; Preserve the value of `org-agenda-local-vars' variables.
(mapc #'make-local-variable org-agenda-local-vars)
(reset-saved org-agenda-local-vars)
(setq-local org-agenda-this-buffer-is-sticky t))
(org-agenda-sticky
;; Creating a sticky Agenda buffer for the first time
(mapc #'make-local-variable org-agenda-local-vars)
(setq-local org-agenda-this-buffer-is-sticky t))
(t
;; Creating a non-sticky agenda buffer
(setq-local org-agenda-this-buffer-is-sticky nil)))
(mapc #'make-local-variable agenda-local-vars-to-keep)
(reset-saved agenda-local-vars-to-keep)))
(setq org-agenda-undo-list nil
org-agenda-pending-undo-list nil
org-agenda-bulk-marked-entries nil)
(setq major-mode 'org-agenda-mode)
;; Keep global-font-lock-mode from turning on font-lock-mode
(setq-local font-lock-global-modes (list 'not major-mode))
(setq mode-name "Org-Agenda")
(setq indent-tabs-mode nil)
(use-local-map org-agenda-mode-map)
(when org-startup-truncated (setq truncate-lines t))
(setq-local line-move-visual nil)
(add-hook 'post-command-hook #'org-agenda-update-agenda-type nil 'local)
(add-hook 'pre-command-hook #'org-unhighlight nil 'local)
;; Make sure properties are removed when copying text
(if (boundp 'filter-buffer-substring-functions)
(add-hook 'filter-buffer-substring-functions
(lambda (fun start end delete)
(substring-no-properties (funcall fun start end delete)))
nil t)
;; Emacs >= 24.4.
(add-function :filter-return (local 'filter-buffer-substring-function)
#'substring-no-properties))
(unless org-agenda-keep-modes
(setq org-agenda-follow-mode org-agenda-start-with-follow-mode
org-agenda-entry-text-mode org-agenda-start-with-entry-text-mode
org-agenda-show-log org-agenda-start-with-log-mode
org-agenda-clockreport-mode org-agenda-start-with-clockreport-mode
org-agenda-archives-mode org-agenda-start-with-archives-mode))
(add-to-invisibility-spec '(org-filtered))
(add-to-invisibility-spec '(org-link))
(easy-menu-change
'("Agenda") "Agenda Files"
(append
(list
(vector
(if (get 'org-agenda-files 'org-restrict)
"Restricted to single file"
"Edit File List")
'(org-edit-agenda-file-list)
(not (get 'org-agenda-files 'org-restrict)))
"--")
(mapcar #'org-file-menu-entry (org-agenda-files))))
(org-agenda-set-mode-name)
(run-mode-hooks 'org-agenda-mode-hook))
(substitute-key-definition #'undo #'org-agenda-undo
org-agenda-mode-map global-map)
(org-defkey org-agenda-mode-map "\C-i" #'org-agenda-goto)
(org-defkey org-agenda-mode-map [(tab)] #'org-agenda-goto)
(org-defkey org-agenda-mode-map "\C-m" #'org-agenda-switch-to)
(org-defkey org-agenda-mode-map "\C-k" #'org-agenda-kill)
(org-defkey org-agenda-mode-map "\C-c\C-w" #'org-agenda-refile)
(org-defkey org-agenda-mode-map [(meta down)] #'org-agenda-drag-line-forward)
(org-defkey org-agenda-mode-map [(meta up)] #'org-agenda-drag-line-backward)
(org-defkey org-agenda-mode-map "m" #'org-agenda-bulk-mark)
(org-defkey org-agenda-mode-map "\M-m" #'org-agenda-bulk-toggle)
(org-defkey org-agenda-mode-map "*" #'org-agenda-bulk-mark-all)
(org-defkey org-agenda-mode-map "\M-*" #'org-agenda-bulk-toggle-all)
(org-defkey org-agenda-mode-map "#" #'org-agenda-dim-blocked-tasks)
(org-defkey org-agenda-mode-map "%" #'org-agenda-bulk-mark-regexp)
(org-defkey org-agenda-mode-map "u" #'org-agenda-bulk-unmark)
(org-defkey org-agenda-mode-map "U" #'org-agenda-bulk-unmark-all)
(org-defkey org-agenda-mode-map "B" #'org-agenda-bulk-action)
(org-defkey org-agenda-mode-map "k" #'org-agenda-capture)
(org-defkey org-agenda-mode-map "A" #'org-agenda-append-agenda)
(org-defkey org-agenda-mode-map "\C-c\C-x!" #'org-reload)
(org-defkey org-agenda-mode-map "\C-c\C-x\C-a" #'org-agenda-archive-default)
(org-defkey org-agenda-mode-map "\C-c\C-xa" #'org-agenda-toggle-archive-tag)
(org-defkey org-agenda-mode-map "\C-c\C-xA" #'org-agenda-archive-to-archive-sibling)
(org-defkey org-agenda-mode-map "\C-c\C-x\C-s" #'org-agenda-archive)
(org-defkey org-agenda-mode-map "\C-c$" #'org-agenda-archive)
(org-defkey org-agenda-mode-map "$" #'org-agenda-archive)
(org-defkey org-agenda-mode-map "\C-c\C-o" #'org-agenda-open-link)
(org-defkey org-agenda-mode-map " " #'org-agenda-show-and-scroll-up)
(org-defkey org-agenda-mode-map [backspace] #'org-agenda-show-scroll-down)
(org-defkey org-agenda-mode-map "\d" #'org-agenda-show-scroll-down)
(org-defkey org-agenda-mode-map [(control shift right)] #'org-agenda-todo-nextset)
(org-defkey org-agenda-mode-map [(control shift left)] #'org-agenda-todo-previousset)
(org-defkey org-agenda-mode-map "\C-c\C-xb" #'org-agenda-tree-to-indirect-buffer)
(org-defkey org-agenda-mode-map "o" #'delete-other-windows)
(org-defkey org-agenda-mode-map "L" #'org-agenda-recenter)
(org-defkey org-agenda-mode-map "\C-c\C-t" #'org-agenda-todo)
(org-defkey org-agenda-mode-map "t" #'org-agenda-todo)
(org-defkey org-agenda-mode-map "a" #'org-agenda-archive-default-with-confirmation)
(org-defkey org-agenda-mode-map ":" #'org-agenda-set-tags)
(org-defkey org-agenda-mode-map "\C-c\C-q" #'org-agenda-set-tags)
(org-defkey org-agenda-mode-map "." #'org-agenda-goto-today)
(org-defkey org-agenda-mode-map "j" #'org-agenda-goto-date)
(org-defkey org-agenda-mode-map "d" #'org-agenda-day-view)
(org-defkey org-agenda-mode-map "w" #'org-agenda-week-view)
(org-defkey org-agenda-mode-map "y" #'org-agenda-year-view)
(org-defkey org-agenda-mode-map "\C-c\C-z" #'org-agenda-add-note)
(org-defkey org-agenda-mode-map "z" #'org-agenda-add-note)
(org-defkey org-agenda-mode-map [(shift right)] #'org-agenda-do-date-later)
(org-defkey org-agenda-mode-map [(shift left)] #'org-agenda-do-date-earlier)
(org-defkey org-agenda-mode-map [?\C-c ?\C-x (right)] #'org-agenda-do-date-later)
(org-defkey org-agenda-mode-map [?\C-c ?\C-x (left)] #'org-agenda-do-date-earlier)
(org-defkey org-agenda-mode-map ">" #'org-agenda-date-prompt)
(org-defkey org-agenda-mode-map "\C-c\C-s" #'org-agenda-schedule)
(org-defkey org-agenda-mode-map "\C-c\C-d" #'org-agenda-deadline)
(let ((l '(1 2 3 4 5 6 7 8 9 0)))
(while l (org-defkey org-agenda-mode-map
(number-to-string (pop l)) #'digit-argument)))
(org-defkey org-agenda-mode-map "F" #'org-agenda-follow-mode)
(org-defkey org-agenda-mode-map "R" #'org-agenda-clockreport-mode)
(org-defkey org-agenda-mode-map "E" #'org-agenda-entry-text-mode)
(org-defkey org-agenda-mode-map "l" #'org-agenda-log-mode)
(org-defkey org-agenda-mode-map "v" #'org-agenda-view-mode-dispatch)
(org-defkey org-agenda-mode-map "D" #'org-agenda-toggle-diary)
(org-defkey org-agenda-mode-map "!" #'org-agenda-toggle-deadlines)
(org-defkey org-agenda-mode-map "G" #'org-agenda-toggle-time-grid)
(org-defkey org-agenda-mode-map "r" #'org-agenda-redo)
(org-defkey org-agenda-mode-map "g" #'org-agenda-redo-all)
(org-defkey org-agenda-mode-map "e" #'org-agenda-set-effort)
(org-defkey org-agenda-mode-map "\C-c\C-xe" #'org-agenda-set-effort)
(org-defkey org-agenda-mode-map "\C-c\C-x\C-e"
#'org-clock-modify-effort-estimate)
(org-defkey org-agenda-mode-map "\C-c\C-xp" #'org-agenda-set-property)
(org-defkey org-agenda-mode-map "q" #'org-agenda-quit)
(org-defkey org-agenda-mode-map "Q" #'org-agenda-Quit)
(org-defkey org-agenda-mode-map "x" #'org-agenda-exit)
(org-defkey org-agenda-mode-map "\C-x\C-w" #'org-agenda-write)
(org-defkey org-agenda-mode-map "\C-x\C-s" #'org-save-all-org-buffers)
(org-defkey org-agenda-mode-map "s" #'org-save-all-org-buffers)
(org-defkey org-agenda-mode-map "T" #'org-agenda-show-tags)
(org-defkey org-agenda-mode-map "n" #'org-agenda-next-line)
(org-defkey org-agenda-mode-map "p" #'org-agenda-previous-line)
(org-defkey org-agenda-mode-map "N" #'org-agenda-next-item)
(org-defkey org-agenda-mode-map "P" #'org-agenda-previous-item)
(substitute-key-definition #'next-line #'org-agenda-next-line
org-agenda-mode-map global-map)
(substitute-key-definition #'previous-line #'org-agenda-previous-line
org-agenda-mode-map global-map)
(org-defkey org-agenda-mode-map "\C-c\C-a" #'org-attach)
(org-defkey org-agenda-mode-map "\C-c\C-n" #'org-agenda-next-date-line)
(org-defkey org-agenda-mode-map "\C-c\C-p" #'org-agenda-previous-date-line)
(org-defkey org-agenda-mode-map "\C-c," #'org-agenda-priority)
(org-defkey org-agenda-mode-map "," #'org-agenda-priority)
(org-defkey org-agenda-mode-map "i" #'org-agenda-diary-entry)
(org-defkey org-agenda-mode-map "c" #'org-agenda-goto-calendar)
(org-defkey org-agenda-mode-map "C" #'org-agenda-convert-date)
(org-defkey org-agenda-mode-map "M" #'org-agenda-phases-of-moon)
(org-defkey org-agenda-mode-map "S" #'org-agenda-sunrise-sunset)
(org-defkey org-agenda-mode-map "h" #'org-agenda-holidays)
(org-defkey org-agenda-mode-map "H" #'org-agenda-holidays)
(org-defkey org-agenda-mode-map "\C-c\C-x\C-i" #'org-agenda-clock-in)
(org-defkey org-agenda-mode-map "I" #'org-agenda-clock-in)
(org-defkey org-agenda-mode-map "\C-c\C-x\C-o" #'org-agenda-clock-out)
(org-defkey org-agenda-mode-map "O" #'org-agenda-clock-out)
(org-defkey org-agenda-mode-map "\C-c\C-x\C-x" #'org-agenda-clock-cancel)
(org-defkey org-agenda-mode-map "X" #'org-agenda-clock-cancel)
(org-defkey org-agenda-mode-map "\C-c\C-x\C-j" #'org-clock-goto)
(org-defkey org-agenda-mode-map "J" #'org-agenda-clock-goto)
(org-defkey org-agenda-mode-map "+" #'org-agenda-priority-up)
(org-defkey org-agenda-mode-map "-" #'org-agenda-priority-down)
(org-defkey org-agenda-mode-map [(shift up)] #'org-agenda-priority-up)
(org-defkey org-agenda-mode-map [(shift down)] #'org-agenda-priority-down)
(org-defkey org-agenda-mode-map [?\C-c ?\C-x (up)] #'org-agenda-priority-up)
(org-defkey org-agenda-mode-map [?\C-c ?\C-x (down)] #'org-agenda-priority-down)
(org-defkey org-agenda-mode-map "f" #'org-agenda-later)
(org-defkey org-agenda-mode-map "b" #'org-agenda-earlier)
(org-defkey org-agenda-mode-map "\C-c\C-x\C-c" #'org-agenda-columns)
(org-defkey org-agenda-mode-map "\C-c\C-x>" #'org-agenda-remove-restriction-lock)
(org-defkey org-agenda-mode-map "\C-c\C-x<" #'org-agenda-set-restriction-lock-from-agenda)
(org-defkey org-agenda-mode-map "[" #'org-agenda-manipulate-query-add)
(org-defkey org-agenda-mode-map "]" #'org-agenda-manipulate-query-subtract)
(org-defkey org-agenda-mode-map "{" #'org-agenda-manipulate-query-add-re)
(org-defkey org-agenda-mode-map "}" #'org-agenda-manipulate-query-subtract-re)
(org-defkey org-agenda-mode-map "\\" #'org-agenda-filter-by-tag)
(org-defkey org-agenda-mode-map "_" #'org-agenda-filter-by-effort)
(org-defkey org-agenda-mode-map "=" #'org-agenda-filter-by-regexp)
(org-defkey org-agenda-mode-map "/" #'org-agenda-filter)
(org-defkey org-agenda-mode-map "|" #'org-agenda-filter-remove-all)
(org-defkey org-agenda-mode-map "~" #'org-agenda-limit-interactively)
(org-defkey org-agenda-mode-map "<" #'org-agenda-filter-by-category)
(org-defkey org-agenda-mode-map "^" #'org-agenda-filter-by-top-headline)
(org-defkey org-agenda-mode-map ";" #'org-timer-set-timer)
(org-defkey org-agenda-mode-map "\C-c\C-x_" #'org-timer-stop)
(org-defkey org-agenda-mode-map "?" #'org-agenda-show-the-flagging-note)
(org-defkey org-agenda-mode-map "\C-c\C-x\C-mg" #'org-mobile-pull)
(org-defkey org-agenda-mode-map "\C-c\C-x\C-mp" #'org-mobile-push)
(org-defkey org-agenda-mode-map "\C-c\C-xI" #'org-info-find-node)
(org-defkey org-agenda-mode-map [mouse-2] #'org-agenda-goto-mouse)
(org-defkey org-agenda-mode-map [mouse-3] #'org-agenda-show-mouse)
(org-defkey org-agenda-mode-map [remap forward-paragraph] #'org-agenda-forward-block)
(org-defkey org-agenda-mode-map [remap backward-paragraph] #'org-agenda-backward-block)
(org-defkey org-agenda-mode-map "\C-c\C-c" #'org-agenda-ctrl-c-ctrl-c)
(when org-agenda-mouse-1-follows-link
(org-defkey org-agenda-mode-map [follow-link] 'mouse-face))
(easy-menu-define org-agenda-menu org-agenda-mode-map "Agenda menu."
'("Agenda"
("Agenda Files")
"--"
("Agenda Dates"
["Goto Today" org-agenda-goto-today (org-agenda-check-type nil 'agenda)]
["Next Dates" org-agenda-later (org-agenda-check-type nil 'agenda)]
["Previous Dates" org-agenda-earlier (org-agenda-check-type nil 'agenda)]
["Jump to date" org-agenda-goto-date (org-agenda-check-type nil 'agenda)])
"--"
("View"
["Day View" org-agenda-day-view
:active (org-agenda-check-type nil 'agenda)
:style radio :selected (eq org-agenda-current-span 'day)
:keys "v d (or just d)"]
["Week View" org-agenda-week-view
:active (org-agenda-check-type nil 'agenda)
:style radio :selected (eq org-agenda-current-span 'week)
:keys "v w"]
["Fortnight View" org-agenda-fortnight-view
:active (org-agenda-check-type nil 'agenda)
:style radio :selected (eq org-agenda-current-span 'fortnight)
:keys "v t"]
["Month View" org-agenda-month-view
:active (org-agenda-check-type nil 'agenda)
:style radio :selected (eq org-agenda-current-span 'month)
:keys "v m"]
["Year View" org-agenda-year-view
:active (org-agenda-check-type nil 'agenda)
:style radio :selected (eq org-agenda-current-span 'year)
:keys "v y"]
"--"
["Include Diary" org-agenda-toggle-diary
:style toggle :selected org-agenda-include-diary
:active (org-agenda-check-type nil 'agenda)]
["Include Deadlines" org-agenda-toggle-deadlines
:style toggle :selected org-agenda-include-deadlines
:active (org-agenda-check-type nil 'agenda)]
["Use Time Grid" org-agenda-toggle-time-grid
:style toggle :selected org-agenda-use-time-grid
:active (org-agenda-check-type nil 'agenda)]
"--"
["Show clock report" org-agenda-clockreport-mode
:style toggle :selected org-agenda-clockreport-mode
:active (org-agenda-check-type nil 'agenda)]
["Show some entry text" org-agenda-entry-text-mode
:style toggle :selected org-agenda-entry-text-mode
:active t]
"--"
["Show Logbook entries" org-agenda-log-mode
:style toggle :selected org-agenda-show-log
:active (org-agenda-check-type nil 'agenda)
:keys "v l (or just l)"]
["Include archived trees" org-agenda-archives-mode
:style toggle :selected org-agenda-archives-mode :active t
:keys "v a"]
["Include archive files" (org-agenda-archives-mode t)
:style toggle :selected (eq org-agenda-archives-mode t) :active t
:keys "v A"]
"--"
["Remove Restriction" org-agenda-remove-restriction-lock org-agenda-restrict])
("Filter current view"
["with generic interface" org-agenda-filter t]
"--"
["by category at cursor" org-agenda-filter-by-category t]
["by tag" org-agenda-filter-by-tag t]
["by effort" org-agenda-filter-by-effort t]
["by regexp" org-agenda-filter-by-regexp t]
["by top-level headline" org-agenda-filter-by-top-headline t]
"--"
["Remove all filtering" org-agenda-filter-remove-all t]
"--"
["limit" org-agenda-limit-interactively t])
["Rebuild buffer" org-agenda-redo t]
["Write view to file" org-agenda-write t]
["Save all Org buffers" org-save-all-org-buffers t]
"--"
["Show original entry" org-agenda-show t]
["Go To (other window)" org-agenda-goto t]
["Go To (this window)" org-agenda-switch-to t]
["Capture with cursor date" org-agenda-capture t]
["Follow Mode" org-agenda-follow-mode
:style toggle :selected org-agenda-follow-mode :active t]
;; ["Tree to indirect frame" org-agenda-tree-to-indirect-buffer t]
"--"
("TODO"
["Cycle TODO" org-agenda-todo t]
["Next TODO set" org-agenda-todo-nextset t]
["Previous TODO set" org-agenda-todo-previousset t]
["Add note" org-agenda-add-note t])
("Archive/Refile/Delete"
["Archive default" org-agenda-archive-default t]
["Archive default" org-agenda-archive-default-with-confirmation t]
["Toggle ARCHIVE tag" org-agenda-toggle-archive-tag t]
["Move to archive sibling" org-agenda-archive-to-archive-sibling t]
["Archive subtree" org-agenda-archive t]
"--"
["Refile" org-agenda-refile t]
"--"
["Delete subtree" org-agenda-kill t])
("Bulk action"
["Mark entry" org-agenda-bulk-mark t]
["Mark all" org-agenda-bulk-mark-all t]
["Unmark entry" org-agenda-bulk-unmark t]
["Unmark all" org-agenda-bulk-unmark-all :active t :keys "U"]
["Toggle mark" org-agenda-bulk-toggle t]
["Toggle all" org-agenda-bulk-toggle-all t]
["Mark regexp" org-agenda-bulk-mark-regexp t])
["Act on all marked" org-agenda-bulk-action t]
"--"
("Tags and Properties"
["Show all Tags" org-agenda-show-tags t]
["Set Tags current line" org-agenda-set-tags (not (org-region-active-p))]
["Change tag in region" org-agenda-set-tags (org-region-active-p)]
"--"
["Column View" org-columns t])
("Deadline/Schedule"
["Schedule" org-agenda-schedule t]
["Set Deadline" org-agenda-deadline t]
"--"
["Change Date +1 day" org-agenda-date-later (org-agenda-check-type nil 'agenda)]
["Change Date -1 day" org-agenda-date-earlier (org-agenda-check-type nil 'agenda)]
["Change Time +1 hour" org-agenda-do-date-later :active (org-agenda-check-type nil 'agenda) :keys "C-u S-right"]
["Change Time -1 hour" org-agenda-do-date-earlier :active (org-agenda-check-type nil 'agenda) :keys "C-u S-left"]
["Change Time + min" org-agenda-date-later :active (org-agenda-check-type nil 'agenda) :keys "C-u C-u S-right"]
["Change Time - min" org-agenda-date-earlier :active (org-agenda-check-type nil 'agenda) :keys "C-u C-u S-left"]
["Change Date to ..." org-agenda-date-prompt (org-agenda-check-type nil 'agenda)])
("Clock and Effort"
["Clock in" org-agenda-clock-in t]
["Clock out" org-agenda-clock-out t]
["Clock cancel" org-agenda-clock-cancel t]
["Goto running clock" org-clock-goto t]
"--"
["Set Effort" org-agenda-set-effort t]
["Change clocked effort" org-clock-modify-effort-estimate
(org-clock-is-active)])
("Priority"
["Set Priority" org-agenda-priority t]
["Increase Priority" org-agenda-priority-up t]
["Decrease Priority" org-agenda-priority-down t]
["Show Priority" org-priority-show t])
("Calendar/Diary"
["New Diary Entry" org-agenda-diary-entry (org-agenda-check-type nil 'agenda)]
["Goto Calendar" org-agenda-goto-calendar (org-agenda-check-type nil 'agenda)]
["Phases of the Moon" org-agenda-phases-of-moon (org-agenda-check-type nil 'agenda)]
["Sunrise/Sunset" org-agenda-sunrise-sunset (org-agenda-check-type nil 'agenda)]
["Holidays" org-agenda-holidays (org-agenda-check-type nil 'agenda)]
["Convert" org-agenda-convert-date (org-agenda-check-type nil 'agenda)]
"--"
["Create iCalendar File" org-icalendar-combine-agenda-files t])
"--"
["Undo Remote Editing" org-agenda-undo org-agenda-undo-list]
"--"
("MobileOrg"
["Push Files and Views" org-mobile-push t]
["Get Captured and Flagged" org-mobile-pull t]
["Find FLAGGED Tasks" (org-agenda nil "?") :active t :keys "\\[org-agenda] ?"]
["Show note / unflag" org-agenda-show-the-flagging-note t]
"--"
["Setup" (progn (require 'org-mobile) (customize-group 'org-mobile)) t])
"--"
["Quit" org-agenda-quit t]
["Exit and Release Buffers" org-agenda-exit t]
))
;;; Agenda undo
(defvar org-agenda-allow-remote-undo t
"Non-nil means allow remote undo from the agenda buffer.")
(defvar org-agenda-undo-has-started-in nil
"Buffers that have already seen `undo-start' in the current undo sequence.")
(defun org-agenda-undo ()
"Undo a remote editing step in the agenda.
This undoes changes both in the agenda buffer and in the remote buffer
that have been changed along."
(interactive)
(or org-agenda-allow-remote-undo
(user-error "Check the variable `org-agenda-allow-remote-undo' to activate remote undo"))
(when (not (eq this-command last-command))
(setq org-agenda-undo-has-started-in nil
org-agenda-pending-undo-list org-agenda-undo-list))
(when (not org-agenda-pending-undo-list)
(user-error "No further undo information"))
(let* ((entry (pop org-agenda-pending-undo-list))
buf line cmd rembuf)
(setq cmd (pop entry) line (pop entry))
(setq rembuf (nth 2 entry))
(org-with-remote-undo rembuf
(while (bufferp (setq buf (pop entry)))
(when (pop entry)
(with-current-buffer buf
(let (;; (last-undo-buffer buf)
(inhibit-read-only t))
(unless (memq buf org-agenda-undo-has-started-in)
(push buf org-agenda-undo-has-started-in)
(make-local-variable 'pending-undo-list)
(undo-start))
(while (and pending-undo-list
(listp pending-undo-list)
(not (car pending-undo-list)))
(pop pending-undo-list))
(undo-more 1))))))
(org-goto-line line)
(message "`%s' undone (buffer %s)" cmd (buffer-name rembuf))))
(defun org-verify-change-for-undo (l1 l2)
"Verify that a real change occurred between the undo lists L1 and L2."
(while (and l1 (listp l1) (null (car l1))) (pop l1))
(while (and l2 (listp l2) (null (car l2))) (pop l2))
(not (eq l1 l2)))
;;; Agenda dispatch
(defvar org-agenda-restrict-begin (make-marker)
"Internal variable used to mark the restriction beginning.
It is only relevant when `org-agenda-restrict' is a buffer.")
(defvar org-agenda-restrict-end (make-marker)
"Internal variable used to mark the restriction end.
It is only relevant when `org-agenda-restrict' is a buffer.")
(defvar org-agenda-overriding-restriction nil
"Non-nil means extended agenda restriction is active.
This is an internal flag set by `org-agenda-set-restriction-lock'.")
(defcustom org-agenda-custom-commands-contexts nil
"Alist of custom agenda keys and contextual rules.
For example, if you have a custom agenda command \"p\" and you
want this command to be accessible only from plain text files,
use this:
(setq org-agenda-custom-commands-contexts
\\='((\"p\" ((in-file . \"\\\\.txt\\\\'\")))))
Here are the available contexts definitions:
in-file: command displayed only in matching files
in-mode: command displayed only in matching modes
not-in-file: command not displayed in matching files
not-in-mode: command not displayed in matching modes
in-buffer: command displayed only in matching buffers
not-in-buffer: command not displayed in matching buffers
[function]: a custom function taking no argument
If you define several checks, the agenda command will be
accessible if there is at least one valid check.
You can also bind a key to another agenda custom command
depending on contextual rules.
(setq org-agenda-custom-commands-contexts
\\='((\"p\" \"q\" ((in-file . \"\\\\.txt\\\\'\")))))
Here it means: in .txt files, use \"p\" as the key for the
agenda command otherwise associated with \"q\". (The command
originally associated with \"q\" is not displayed to avoid
duplicates.)"
:version "24.3"
:group 'org-agenda-custom-commands
:type '(repeat (list :tag "Rule"
(string :tag " Agenda key")
(string :tag "Replace by command")
(repeat :tag "Available when"
(choice
(cons :tag "Condition"
(choice
(const :tag "In file" in-file)
(const :tag "Not in file" not-in-file)
(const :tag "In buffer" in-buffer)
(const :tag "Not in buffer" not-in-buffer)
(const :tag "In mode" in-mode)
(const :tag "Not in mode" not-in-mode))
(regexp))
(function :tag "Custom function"))))))
(defcustom org-agenda-max-entries nil
"Maximum number of entries to display in an agenda.
This can be nil (no limit) or an integer or an alist of agenda
types with an associated number of entries to display in this
type."
:version "24.4"
:package-version '(Org . "8.0")
:group 'org-agenda-custom-commands
:type '(choice (const :tag "No limit" nil)
(integer :tag "Max number of entries")
(repeat
(cons (choice :tag "Agenda type"
(const agenda)
(const todo)
(const tags)
(const search))
(integer :tag "Max number of entries")))))
(defcustom org-agenda-max-todos nil
"Maximum number of TODOs to display in an agenda.
This can be nil (no limit) or an integer or an alist of agenda
types with an associated number of entries to display in this
type."
:version "24.4"
:package-version '(Org . "8.0")
:group 'org-agenda-custom-commands
:type '(choice (const :tag "No limit" nil)
(integer :tag "Max number of TODOs")
(repeat
(cons (choice :tag "Agenda type"
(const agenda)
(const todo)
(const tags)
(const search))
(integer :tag "Max number of TODOs")))))
(defcustom org-agenda-max-tags nil
"Maximum number of tagged entries to display in an agenda.
This can be nil (no limit) or an integer or an alist of agenda
types with an associated number of entries to display in this
type."
:version "24.4"
:package-version '(Org . "8.0")
:group 'org-agenda-custom-commands
:type '(choice (const :tag "No limit" nil)
(integer :tag "Max number of tagged entries")
(repeat
(cons (choice :tag "Agenda type"
(const agenda)
(const todo)
(const tags)
(const search))
(integer :tag "Max number of tagged entries")))))
(defcustom org-agenda-max-effort nil
"Maximum cumulated effort duration for the agenda.
This can be nil (no limit) or a number of minutes (as an integer)
or an alist of agenda types with an associated number of minutes
to limit entries to in this type."
:version "24.4"
:package-version '(Org . "8.0")
:group 'org-agenda-custom-commands
:type '(choice (const :tag "No limit" nil)
(integer :tag "Max number of minutes")
(repeat
(cons (choice :tag "Agenda type"
(const agenda)
(const todo)
(const tags)
(const search))
(integer :tag "Max number of minutes")))))
(defvar org-agenda-keep-restricted-file-list nil)
(defvar org-keys nil)
(defvar org-match nil)
;;;###autoload
(defun org-agenda (&optional arg keys restriction)
"Dispatch agenda commands to collect entries to the agenda buffer.
Prompts for a command to execute. Any prefix arg will be passed
on to the selected command. The default selections are:
a Call `org-agenda-list' to display the agenda for current day or week.
t Call `org-todo-list' to display the global todo list.
T Call `org-todo-list' to display the global todo list, select only
entries with a specific TODO keyword (the user gets a prompt).
m Call `org-tags-view' to display headlines with tags matching
a condition (the user is prompted for the condition).
M Like `m', but select only TODO entries, no ordinary headlines.
e Export views to associated files.
s Search entries for keywords.
S Search entries for keywords, only with TODO keywords.
/ Multi occur across all agenda files and also files listed
in `org-agenda-text-search-extra-files'.
< Restrict agenda commands to buffer, subtree, or region.
Press several times to get the desired effect.
> Remove a previous restriction.
# List \"stuck\" projects.
! Configure what \"stuck\" means.
C Configure custom agenda commands.
More commands can be added by configuring the variable
`org-agenda-custom-commands'. In particular, specific tags and TODO keyword
searches can be pre-defined in this way.
If the current buffer is in Org mode and visiting a file, you can also
first press `<' once to indicate that the agenda should be temporarily
\(until the next use of `\\[org-agenda]') restricted to the current file.
Pressing `<' twice means to restrict to the current subtree or region
\(if active)."
(interactive "P")
(catch 'exit
(let* ((org-keys keys)
(prefix-descriptions nil)
(org-agenda-buffer-name org-agenda-buffer-name)
(org-agenda-window-setup (if (equal (buffer-name)
org-agenda-buffer-name)
'current-window
org-agenda-window-setup))
(org-agenda-custom-commands-orig org-agenda-custom-commands)
(org-agenda-custom-commands
;; normalize different versions
(delq nil
(mapcar
(lambda (x)
(cond ((stringp (cdr x))
(push x prefix-descriptions)
nil)
((stringp (nth 1 x)) x)
((not (nth 1 x)) (cons (car x) (cons "" (cddr x))))
(t (cons (car x) (cons "" (cdr x))))))
org-agenda-custom-commands)))
(org-agenda-custom-commands
(org-contextualize-keys
org-agenda-custom-commands org-agenda-custom-commands-contexts))
;; (buf (current-buffer))
(bfn (buffer-file-name (buffer-base-buffer)))
entry type org-match lprops ans) ;; key
;; Turn off restriction unless there is an overriding one,
(unless org-agenda-overriding-restriction
(unless org-agenda-keep-restricted-file-list
;; There is a request to keep the file list in place
(put 'org-agenda-files 'org-restrict nil))
(setq org-agenda-restrict nil)
(move-marker org-agenda-restrict-begin nil)
(move-marker org-agenda-restrict-end nil))
(unless org-keys
(setq ans (org-agenda-get-restriction-and-command prefix-descriptions)
org-keys (car ans)
restriction (cdr ans)))
;; If we have sticky agenda buffers, set a name for the buffer,
;; depending on the invoking keys. The user may still set this
;; as a command option, which will overwrite what we do here.
(when org-agenda-sticky
(setq org-agenda-buffer-name
(format "*Org Agenda(%s)*" org-keys)))
;; Establish the restriction, if any
(when (and (not org-agenda-overriding-restriction) restriction)
(put 'org-agenda-files 'org-restrict (list bfn))
(cond
((eq restriction 'region)
(setq org-agenda-restrict (current-buffer))
(move-marker org-agenda-restrict-begin (region-beginning))
(move-marker org-agenda-restrict-end (region-end)))
((eq restriction 'subtree)
(save-excursion
(setq org-agenda-restrict (current-buffer))
(org-back-to-heading t)
(move-marker org-agenda-restrict-begin (point))
(move-marker org-agenda-restrict-end
(progn (org-end-of-subtree t)))))
((eq restriction 'buffer)
(if (not (buffer-narrowed-p))
(setq org-agenda-restrict t)
(setq org-agenda-restrict (current-buffer))
(move-marker org-agenda-restrict-begin (point-min))
(move-marker org-agenda-restrict-end (point-max))))))
;; For example the todo list should not need it (but does...)
(cond
((setq entry (assoc org-keys org-agenda-custom-commands))
(if (or (symbolp (nth 2 entry)) (functionp (nth 2 entry)))
(progn
;; FIXME: Is (nth 3 entry) supposed to have access (via dynvars)
;; to some of the local variables? There's no doc about
;; that for `org-agenda-custom-commands'.
(setq type (nth 2 entry) org-match (eval (nth 3 entry) t)
lprops (nth 4 entry))
(when org-agenda-sticky
(setq org-agenda-buffer-name
(or (and (stringp org-match) (format "*Org Agenda(%s:%s)*" org-keys org-match))
(format "*Org Agenda(%s)*" org-keys))))
(cl-progv
(mapcar #'car lprops)
(mapcar (lambda (binding) (eval (cadr binding) t)) lprops)
(pcase type
(`agenda
(org-agenda-list arg))
(`agenda*
(org-agenda-list arg nil nil t))
(`alltodo
(org-todo-list arg))
(`search
(org-search-view arg org-match nil))
(`stuck
(org-agenda-list-stuck-projects arg))
(`tags
(org-tags-view arg org-match))
(`tags-todo
(org-tags-view '(4) org-match))
(`todo
(org-todo-list org-match))
(`tags-tree
(org-check-for-org-mode)
(org-match-sparse-tree arg org-match))
(`todo-tree
(org-check-for-org-mode)
(org-occur (concat "^" org-outline-regexp "[ \t]*"
(regexp-quote org-match) "\\(?:[\t ]\\|$\\)")))
(`occur-tree
(org-check-for-org-mode)
(org-occur org-match))
((pred functionp)
(funcall type org-match))
;; FIXME: Will signal an error since it's not `functionp'!
((pred fboundp) (funcall type org-match))
(_ (user-error "Invalid custom agenda command type %s" type))))
(let ((inhibit-read-only t))
(add-text-properties (point-min) (point-max)
`(org-lprops ,lprops))))
(org-agenda-run-series (nth 1 entry) (cddr entry))))
((equal org-keys "C")
(setq org-agenda-custom-commands org-agenda-custom-commands-orig)
(customize-variable 'org-agenda-custom-commands))
((equal org-keys "a") (call-interactively 'org-agenda-list))
((equal org-keys "s") (call-interactively 'org-search-view))
((equal org-keys "S") (org-call-with-arg 'org-search-view (or arg '(4))))
((equal org-keys "t") (call-interactively 'org-todo-list))
((equal org-keys "T") (org-call-with-arg 'org-todo-list (or arg '(4))))
((equal org-keys "m") (call-interactively 'org-tags-view))
((equal org-keys "M") (org-call-with-arg 'org-tags-view (or arg '(4))))
((equal org-keys "e") (call-interactively 'org-store-agenda-views))
((equal org-keys "?") (org-tags-view nil "+FLAGGED")
(add-hook
'post-command-hook
(lambda ()
(unless (current-message)
(let* ((m (org-agenda-get-any-marker))
(note (and m (org-entry-get m "THEFLAGGINGNOTE"))))
(when note
(message "FLAGGING-NOTE ([?] for more info): %s"
(org-add-props
(replace-regexp-in-string
"\\\\n" "//"
(copy-sequence note))
nil 'face 'org-warning))))))
t t))
((equal org-keys "#") (call-interactively 'org-agenda-list-stuck-projects))
((equal org-keys "/") (call-interactively 'org-occur-in-agenda-files))
((equal org-keys "!") (customize-variable 'org-stuck-projects))
(t (user-error "Invalid agenda key"))))))
(defvar org-agenda-multi)
(defun org-agenda-append-agenda ()
"Append another agenda view to the current one.
This function allows interactive building of block agendas.
Agenda views are separated by `org-agenda-block-separator'."
(interactive)
(unless (derived-mode-p 'org-agenda-mode)
(user-error "Can only append from within agenda buffer"))
(let ((org-agenda-multi t))
(org-agenda)
(widen)
(org-agenda-finalize)
(setq buffer-read-only t)
(org-agenda-fit-window-to-buffer)))
(defun org-agenda-normalize-custom-commands (cmds)
"Normalize custom commands CMDS."
(delq nil
(mapcar
(lambda (x)
(cond ((stringp (cdr x)) nil)
((stringp (nth 1 x)) x)
((not (nth 1 x)) (cons (car x) (cons "" (cddr x))))
(t (cons (car x) (cons "" (cdr x))))))
cmds)))
(defun org-agenda-get-restriction-and-command (prefix-descriptions)
"The user interface for selecting an agenda command."
(catch 'exit
(let* ((bfn (buffer-file-name (buffer-base-buffer)))
(restrict-ok (and bfn (derived-mode-p 'org-mode)))
(region-p (org-region-active-p))
(custom org-agenda-custom-commands)
(selstring "")
restriction second-time
c entry key type match prefixes rmheader header-end custom1 desc
line lines left right n n1)
(save-window-excursion
(pop-to-buffer " *Agenda Commands*" '(org-display-buffer-split))
(erase-buffer)
(insert (eval-when-compile
(let ((header
(copy-sequence
"Press key for an agenda command:
-------------------------------- < Buffer, subtree/region restriction
a Agenda for current week or day > Remove restriction
/ Multi-occur e Export agenda views
t List of all TODO entries T Entries with special TODO kwd
m Match a TAGS/PROP/TODO query M Like m, but only TODO entries
s Search for keywords S Like s, but only TODO entries
? Find :FLAGGED: entries C Configure custom agenda commands
* Toggle sticky agenda views # List stuck projects (!=configure)
"))
(start 0))
(while (string-match
"\\(^\\| \\|(\\)\\(\\S-\\)\\( \\|=\\)"
header start)
(setq start (match-end 0))
(add-text-properties (match-beginning 2) (match-end 2)
'(face bold) header))
header)))
(setq header-end (point-marker))
(unwind-protect
(while t
(setq custom1 custom)
(when (eq rmheader t)
(org-goto-line 1)
(re-search-forward ":" nil t)
(delete-region (match-end 0) (line-end-position))
(forward-char 1)
(looking-at "-+")
(delete-region (match-end 0) (line-end-position))
(move-marker header-end (match-end 0)))
(goto-char header-end)
(delete-region (point) (point-max))
;; Produce all the lines that describe custom commands and prefixes
(setq lines nil)
(while (setq entry (pop custom1))
(setq key (car entry) desc (nth 1 entry)
type (nth 2 entry)
match (nth 3 entry))
(if (> (length key) 1)
(cl-pushnew (string-to-char key) prefixes :test #'equal)
(setq line
(format
"%-4s%-14s"
(org-add-props (copy-sequence key)
'(face bold))
(cond
((string-match "\\S-" desc) desc)
((eq type 'agenda) "Agenda for current week or day")
((eq type 'agenda*) "Appointments for current week or day")
((eq type 'alltodo) "List of all TODO entries")
((eq type 'search) "Word search")
((eq type 'stuck) "List of stuck projects")
((eq type 'todo) "TODO keyword")
((eq type 'tags) "Tags query")
((eq type 'tags-todo) "Tags (TODO)")
((eq type 'tags-tree) "Tags tree")
((eq type 'todo-tree) "TODO kwd tree")
((eq type 'occur-tree) "Occur tree")
((functionp type) (if (symbolp type)
(symbol-name type)
"Lambda expression"))
(t "???"))))
(cond
((not (org-string-nw-p match)) nil)
(org-agenda-menu-show-matcher
(setq line
(concat line ": "
(cond
((stringp match)
(propertize match 'face 'org-warning))
((listp type)
(format "set of %d commands" (length type)))))))
(t
(org-add-props line nil 'help-echo (concat "Matcher: " match))))
(push line lines)))
(setq lines (nreverse lines))
(when prefixes
(mapc (lambda (x)
(push
(format "%s %s"
(org-add-props (char-to-string x)
nil 'face 'bold)
(or (cdr (assoc (concat selstring
(char-to-string x))
prefix-descriptions))
"Prefix key"))
lines))
prefixes))
;; Check if we should display in two columns
(if org-agenda-menu-two-columns
(progn
(setq n (length lines)
n1 (+ (/ n 2) (mod n 2))
right (nthcdr n1 lines)
left (copy-sequence lines))
(setcdr (nthcdr (1- n1) left) nil))
(setq left lines right nil))
(while left
(insert "\n" (pop left))
(when right
(if (< (current-column) 40)
(move-to-column 40 t)
(insert " "))
(insert (pop right))))
;; Make the window the right size
(goto-char (point-min))
(if second-time
(when (not (pos-visible-in-window-p (point-max)))
(org-fit-window-to-buffer))
(setq second-time t)
(org-fit-window-to-buffer))
;; Hint to navigation if window too small for all information
(setq header-line-format
(when (not (pos-visible-in-window-p (point-max)))
"Use C-v, M-v, C-n or C-p to navigate."))
;; Ask for selection
(cl-loop
do (progn
(message "Press key for agenda command%s:"
(if (or restrict-ok org-agenda-overriding-restriction)
(if org-agenda-overriding-restriction
" (restriction lock active)"
(if restriction
(format " (restricted to %s)" restriction)
" (unrestricted)"))
""))
(setq c (read-char-exclusive)))
until (not (memq c '(14 16 22 134217846)))
do (org-scroll c))
(message "")
(cond
((assoc (char-to-string c) custom)
(setq selstring (concat selstring (char-to-string c)))
(throw 'exit (cons selstring restriction)))
((memq c prefixes)
(setq selstring (concat selstring (char-to-string c))
prefixes nil
rmheader (or rmheader t)
custom (delq nil (mapcar
(lambda (x)
(if (or (= (length (car x)) 1)
(/= (string-to-char (car x)) c))
nil
(cons (substring (car x) 1) (cdr x))))
custom))))
((eq c ?*)
(call-interactively 'org-toggle-sticky-agenda)
(sit-for 2))
((and (not restrict-ok) (memq c '(?1 ?0 ?<)))
(message "Restriction is only possible in Org buffers")
(ding) (sit-for 1))
((eq c ?1)
(org-agenda-remove-restriction-lock 'noupdate)
(setq restriction 'buffer))
((eq c ?0)
(org-agenda-remove-restriction-lock 'noupdate)
(setq restriction (if region-p 'region 'subtree)))
((eq c ?<)
(org-agenda-remove-restriction-lock 'noupdate)
(setq restriction
(cond
((eq restriction 'buffer)
(if region-p 'region 'subtree))
((memq restriction '(subtree region))
nil)
(t 'buffer))))
((eq c ?>)
(org-agenda-remove-restriction-lock 'noupdate)
(setq restriction nil))
((and (equal selstring "") (memq c '(?s ?S ?a ?t ?m ?L ?C ?e ?T ?M ?# ?! ?/ ??)))
(throw 'exit (cons (setq selstring (char-to-string c)) restriction)))
((and (> (length selstring) 0) (eq c ?\d))
(delete-window)
(org-agenda-get-restriction-and-command prefix-descriptions))
((equal c ?q) (user-error "Abort"))
(t (user-error "Invalid key %c" c))))
;; Close *Agenda Commands* window.
(quit-window 'kill))))))
(defun org-agenda-fit-window-to-buffer ()
"Fit the window to the buffer size."
(and (memq org-agenda-window-setup '(reorganize-frame))
(fboundp 'fit-window-to-buffer)
(if (and (= (cdr org-agenda-window-frame-fractions) 1.0)
(= (car org-agenda-window-frame-fractions) 1.0))
(display-buffer (current-buffer) '(org-display-buffer-full-frame))
(org-fit-window-to-buffer
nil
(floor (* (frame-height) (cdr org-agenda-window-frame-fractions)))
(floor (* (frame-height) (car org-agenda-window-frame-fractions)))))))
(defvar org-cmd nil)
(defvar org-agenda-overriding-cmd nil)
(defvar org-agenda-overriding-arguments nil)
(defvar org-agenda-overriding-cmd-arguments nil)
(defun org-agenda-run-series (name series)
"Run agenda NAME as a SERIES of agenda commands."
(let* ((gprops (nth 1 series))
(gvars (mapcar #'car gprops))
(gvals (mapcar (lambda (binding) (eval (cadr binding) t)) gprops)))
(cl-progv gvars gvals (org-agenda-prepare name))
;; We need to reset agenda markers here, because when constructing a
;; block agenda, the individual blocks do not do that.
(org-agenda-reset-markers)
(with-no-warnings
(defvar match)) ;Used via the `eval' below.
(let* ((org-agenda-multi t)
;; FIXME: Redo should contain lists of (FUNS . ARGS) rather
;; than expressions, so you don't need to `quote' the args
;; and you just need to `apply' instead of `eval' when using it.
(redo (list 'org-agenda-run-series name (list 'quote series)))
(cmds (car series))
match
org-cmd type lprops)
(while (setq org-cmd (pop cmds))
(setq type (car org-cmd))
(setq match (eval (nth 1 org-cmd) t))
(setq lprops (nth 2 org-cmd))
(let ((org-agenda-overriding-arguments
(if (eq org-agenda-overriding-cmd org-cmd)
(or org-agenda-overriding-arguments
org-agenda-overriding-cmd-arguments)))
(lvars (mapcar #'car lprops))
(lvals (mapcar (lambda (binding) (eval (cadr binding) t)) lprops)))
(cl-progv (append gvars lvars) (append gvals lvals)
(pcase type
(`agenda
(call-interactively 'org-agenda-list))
(`agenda*
(funcall 'org-agenda-list nil nil nil t))
(`alltodo
(call-interactively 'org-todo-list))
(`search
(org-search-view current-prefix-arg match nil))
(`stuck
(call-interactively 'org-agenda-list-stuck-projects))
(`tags
(org-tags-view current-prefix-arg match))
(`tags-todo
(org-tags-view '(4) match))
(`todo
(org-todo-list match))
((pred fboundp)
(funcall type match))
(_ (error "Invalid type in command series"))))))
(widen)
(let ((inhibit-read-only t))
(add-text-properties (point-min) (point-max)
`(org-series t org-series-redo-cmd ,redo)))
(setq org-agenda-redo-command redo)
(goto-char (point-min)))
(org-agenda-fit-window-to-buffer)
(cl-progv gvars gvals (org-agenda-finalize))))
(defun org-agenda--split-plist (plist)
;; We could/should arguably use `map-keys' and `map-values'.
(let (keys vals)
(while plist
(push (pop plist) keys)
(push (pop plist) vals))
(cons (nreverse keys) (nreverse vals))))
;;;###autoload
(defmacro org-batch-agenda (cmd-key &rest parameters)
"Run an agenda command in batch mode and send the result to STDOUT.
If CMD-KEY is a string of length 1, it is used as a key in
`org-agenda-custom-commands' and triggers this command. If it is a
longer string it is used as a tags/todo match string.
Parameters are alternating variable names and values that will be bound
before running the agenda command."
(pcase-let ((`(,vars . ,exps) (org-agenda--split-plist parameters)))
`(org--batch-agenda ,cmd-key ',vars (list ,@exps))))
(defun org--batch-agenda (cmd-key vars vals)
;; `org-batch-agenda' is a macro because every other "parameter" is
;; a variable name rather than an expression to evaluate. Yuck!
(cl-progv vars vals
(let (org-agenda-sticky)
(if (> (length cmd-key) 1)
(org-tags-view nil cmd-key)
(org-agenda nil cmd-key))))
(set-buffer org-agenda-buffer-name)
(princ (buffer-string)))
(defvar org-agenda-info nil)
;;;###autoload
(defmacro org-batch-agenda-csv (cmd-key &rest parameters)
"Run an agenda command in batch mode and send the result to STDOUT.
If CMD-KEY is a string of length 1, it is used as a key in
`org-agenda-custom-commands' and triggers this command. If it is a
longer string it is used as a tags/todo match string.
Parameters are alternating variable names and values that will be bound
before running the agenda command.
The output gives a line for each selected agenda item. Each
item is a list of comma-separated values, like this:
category,head,type,todo,tags,date,time,extra,priority-l,priority-n
category The category of the item
head The headline, without TODO kwd, TAGS and PRIORITY
type The type of the agenda entry, can be
todo selected in TODO match
tagsmatch selected in tags match
diary imported from diary
deadline a deadline on given date
scheduled scheduled on given date
timestamp entry has timestamp on given date
closed entry was closed on given date
upcoming-deadline warning about deadline
past-scheduled forwarded scheduled item
block entry has date block including g. date
todo The todo keyword, if any
tags All tags including inherited ones, separated by colons
date The relevant date, like 2007-2-14
time The time, like 15:00-16:50
extra String with extra planning info
priority-l The priority letter if any was given
priority-n The computed numerical priority
agenda-day The day in the agenda where this is listed"
(pcase-let ((`(,vars . ,exps) (org-agenda--split-plist parameters)))
`(org--batch-agenda-csv ,cmd-key ',vars (list ,@exps))))
(defun org--batch-agenda-csv (cmd-key vars vals)
;; `org-batch-agenda-csv' is a macro because every other "parameter" is
;; a variable name rather than an expression to evaluate. Yuck!
(let ((org-agenda-remove-tags t))
(cl-progv vars vals
;; FIXME: Shouldn't this be 1 (see commit 10173ad6d610b)?
(if (> (length cmd-key) 2)
(org-tags-view nil cmd-key)
(org-agenda nil cmd-key))))
(set-buffer org-agenda-buffer-name)
(let ((lines (org-split-string (buffer-string) "\n")))
(dolist (line lines)
(when (get-text-property 0 'org-category line)
(setq org-agenda-info
(org-fix-agenda-info (text-properties-at 0 line)))
(princ
(mapconcat #'org-agenda-export-csv-mapper
'(org-category txt type todo tags date time extra
priority-letter priority agenda-day)
","))
(princ "\n")))))
(defun org-fix-agenda-info (props)
"Make sure all properties on an agenda item have a canonical form.
This ensures the export commands can easily use it."
(let (tmp re)
(when (setq tmp (plist-get props 'tags))
(setq props (plist-put props 'tags (mapconcat #'identity tmp ":"))))
(when (setq tmp (plist-get props 'date))
(when (integerp tmp) (setq tmp (calendar-gregorian-from-absolute tmp)))
(let ((calendar-date-display-form
'((format "%s-%.2d-%.2d" year
(string-to-number month)
(string-to-number day)))))
(setq tmp (calendar-date-string tmp)))
(setq props (plist-put props 'date tmp)))
(when (setq tmp (plist-get props 'day))
(when (integerp tmp) (setq tmp (calendar-gregorian-from-absolute tmp)))
(let ((calendar-date-display-form
'((format "%s-%.2d-%.2d" year
(string-to-number month)
(string-to-number day)))))
(setq tmp (calendar-date-string tmp)))
(setq props (plist-put props 'day tmp))
(setq props (plist-put props 'agenda-day tmp)))
(when (setq tmp (plist-get props 'txt))
(when (string-match "\\[#\\([A-Z0-9]\\)\\] ?" tmp)
(plist-put props 'priority-letter (match-string 1 tmp))
(setq tmp (replace-match "" t t tmp)))
(when (and (setq re (plist-get props 'org-todo-regexp))
(setq re (concat "\\`\\.*" re " ?"))
(let ((case-fold-search nil)) (string-match re tmp)))
(plist-put props 'todo (match-string 1 tmp))
(setq tmp (replace-match "" t t tmp)))
(plist-put props 'txt tmp)))
props)
(defun org-agenda-export-csv-mapper (prop)
(let ((res (plist-get org-agenda-info prop)))
(setq res
(cond
((not res) "")
((stringp res) res)
(t (prin1-to-string res))))
(org-trim (replace-regexp-in-string "," ";" res nil t))))
;;;###autoload
(defun org-store-agenda-views (&rest _parameters)
"Store agenda views."
(interactive)
(org--batch-store-agenda-views nil nil))
;;;###autoload
(defmacro org-batch-store-agenda-views (&rest parameters)
"Run all custom agenda commands that have a file argument."
(pcase-let ((`(,vars . ,exps) (org-agenda--split-plist parameters)))
`(org--batch-store-agenda-views ',vars (list ,@exps))))
(defun org--batch-store-agenda-views (vars vals)
(let ((cmds (org-agenda-normalize-custom-commands org-agenda-custom-commands))
(pop-up-frames nil)
(dir default-directory)
cmd thiscmdkey thiscmdcmd match files opts cmd-or-set
seriesp bufname)
(save-window-excursion
(while cmds
(setq cmd (pop cmds)
thiscmdkey (car cmd)
thiscmdcmd (cdr cmd)
match (nth 2 thiscmdcmd)
bufname (if org-agenda-sticky
(or (and (stringp match)
(format "*Org Agenda(%s:%s)*" thiscmdkey match))
(format "*Org Agenda(%s)*" thiscmdkey))
org-agenda-buffer-name)
;; series: (0:key 1:desc 2:(cmd1 cmd2 ...) 3:general-settings 4:files)
;; non-series: (0:key 1:desc 2:type 3:match 4:settings 5:files)
cmd-or-set (nth 2 cmd)
seriesp (not (or (symbolp cmd-or-set) (functionp cmd-or-set)))
opts (nth (if seriesp 3 4) cmd)
files (nth (if seriesp 4 5) cmd))
(if (stringp files) (setq files (list files)))
(when files
(let* ((opts (append org-agenda-exporter-settings opts))
(vars (append (mapcar #'car opts) vars))
(vals (append (mapcar (lambda (binding) (eval (cadr binding) t))
opts)
vals)))
(cl-progv vars vals
(org-agenda nil thiscmdkey))
(set-buffer bufname)
(while files
(cl-progv vars vals
(org-agenda-write (expand-file-name (pop files) dir)
nil t bufname))))
(and (get-buffer bufname)
(kill-buffer bufname)))))))
(defvar org-agenda-current-span nil
"The current span used in the agenda view.") ; local variable in the agenda buffer
(defun org-agenda-mark-header-line (pos)
"Mark the line at POS as an agenda structure header."
(save-excursion
(goto-char pos)
(put-text-property (line-beginning-position) (line-end-position)
'org-agenda-structural-header t)
(when org-agenda-title-append
(put-text-property (line-beginning-position) (line-end-position)
'org-agenda-title-append org-agenda-title-append))))
(defvar org-mobile-creating-agendas) ; defined in org-mobile.el
(defvar org-agenda-write-buffer-name "Agenda View")
(defun org-agenda-write (file &optional open nosettings agenda-bufname)
"Write the current buffer (an agenda view) as a file.
Depending on the extension of the file name, plain text (.txt),
HTML (.html or .htm), PDF (.pdf) or Postscript (.ps) is produced.
If the extension is .ics, translate visible agenda into iCalendar
format. If the extension is .org, collect all subtrees
corresponding to the agenda entries and add them in an .org file.
With prefix argument OPEN, open the new file immediately. If
NOSETTINGS is given, do not scope the settings of
`org-agenda-exporter-settings' into the export commands. This is
used when the settings have already been scoped and we do not
wish to overrule other, higher priority settings. If
AGENDA-BUFFER-NAME is provided, use this as the buffer name for
the agenda to write."
(interactive "FWrite agenda to file: \nP")
(if (or (not (file-writable-p file))
(and (file-exists-p file)
(if (called-interactively-p 'any)
(not (y-or-n-p (format "Overwrite existing file %s? " file))))))
(user-error "Cannot write agenda to file %s" file))
(cl-progv
(if nosettings nil (mapcar #'car org-agenda-exporter-settings))
(if nosettings nil (mapcar (lambda (binding) (eval (cadr binding) t))
org-agenda-exporter-settings))
(save-excursion
(save-window-excursion
(let ((bs (copy-sequence (buffer-string)))
(extension (file-name-extension file))
(default-directory (file-name-directory file))
) ;; beg content
(with-temp-buffer
(rename-buffer org-agenda-write-buffer-name t)
(set-buffer-modified-p nil)
(insert bs)
(org-agenda-remove-marked-text 'invisible 'org-filtered)
(run-hooks 'org-agenda-before-write-hook)
(cond
((bound-and-true-p org-mobile-creating-agendas)
(org-mobile-write-agenda-for-mobile file))
((string= "org" extension)
(let (content p m message-log-max)
(goto-char (point-min))
(while (setq p (next-single-property-change (point) 'org-hd-marker nil))
(goto-char p)
(setq m (get-text-property (point) 'org-hd-marker))
(when m
(cl-pushnew (with-current-buffer (marker-buffer m)
(goto-char m)
(org-copy-subtree 1 nil t t)
org-subtree-clip)
content
:test #'equal)))
(find-file file)
(erase-buffer)
(dolist (s content) (org-paste-subtree 1 s))
(write-file file)
(kill-buffer (current-buffer))
(message "Org file written to %s" file)))
((member extension '("html" "htm"))
(org-require-package 'htmlize)
(declare-function htmlize-buffer "htmlize" (&optional buffer))
(set-buffer (htmlize-buffer (current-buffer)))
(when org-agenda-export-html-style
;; replace "))
(insert org-agenda-export-html-style))
(write-file file)
(kill-buffer (current-buffer))
(message "HTML written to %s" file))
((string= "ps" extension)
(require 'ps-print)
(ps-print-buffer-with-faces file)
(message "Postscript written to %s" file))
((string= "pdf" extension)
(require 'ps-print)
(ps-print-buffer-with-faces
(concat (file-name-sans-extension file) ".ps"))
(call-process "ps2pdf" nil nil nil
(expand-file-name
(concat (file-name-sans-extension file) ".ps"))
(expand-file-name file))
(delete-file (concat (file-name-sans-extension file) ".ps"))
(message "PDF written to %s" file))
((string= "ics" extension)
(require 'ox-icalendar)
(declare-function org-icalendar-export-current-agenda
"ox-icalendar" (file))
(org-icalendar-export-current-agenda (expand-file-name file)))
(t
(write-region nil nil file)
(message "Plain text written to %s" file)))))))
(set-buffer (or agenda-bufname
;; FIXME: I'm pretty sure called-interactively-p
;; doesn't do what we want here!
(and (called-interactively-p 'any) (buffer-name))
org-agenda-buffer-name)))
(when open (org-open-file file)))
(defun org-agenda-remove-marked-text (property &optional value)
"Delete all text marked with VALUE of PROPERTY.
VALUE defaults to t."
(let (beg)
(setq value (or value t))
(while (setq beg (text-property-any (point-min) (point-max)
property value))
(delete-region
beg (or (next-single-property-change beg property)
(point-max))))))
(defun org-agenda-add-entry-text ()
"Add entry text to agenda lines.
This will add a maximum of `org-agenda-add-entry-text-maxlines' lines of the
entry text following headings shown in the agenda.
Drawers will be excluded, also the line with scheduling/deadline info."
(when (and (> org-agenda-add-entry-text-maxlines 0)
(not (bound-and-true-p org-mobile-creating-agendas)))
(let (m txt)
(goto-char (point-min))
(while (not (eobp))
(if (not (setq m (org-get-at-bol 'org-hd-marker)))
(forward-line 1)
(setq txt (org-agenda-get-some-entry-text
m org-agenda-add-entry-text-maxlines " > "))
(end-of-line 1)
(if (string-match "\\S-" txt)
(insert "\n" txt)
(or (eobp) (forward-char 1))))))))
(defun org-agenda-get-some-entry-text (marker n-lines &optional indent
&rest keep)
"Extract entry text from MARKER, at most N-LINES lines.
This will ignore drawers etc, just get the text.
If INDENT is given, prefix every line with this string. If KEEP is
given, it is a list of symbols, defining stuff that should not be
removed from the entry content. Currently only `planning' is allowed here."
(let (txt drawer-re kwd-time-re ind)
(save-excursion
(with-current-buffer (marker-buffer marker)
(if (not (derived-mode-p 'org-mode))
(setq txt "")
(org-with-wide-buffer
(goto-char marker)
(end-of-line 1)
(setq txt (buffer-substring
(min (1+ (point)) (point-max))
(progn (outline-next-heading) (point)))
drawer-re org-drawer-regexp
kwd-time-re (concat "^[ \t]*" org-keyword-time-regexp
".*\n?"))
(with-temp-buffer
(insert txt)
(when org-agenda-add-entry-text-descriptive-links
(goto-char (point-min))
(while (org-activate-links (point-max))
(goto-char (match-end 0))))
(goto-char (point-min))
(while (re-search-forward org-link-bracket-re (point-max) t)
(set-text-properties (match-beginning 0) (match-end 0)
nil))
(goto-char (point-min))
(while (re-search-forward drawer-re nil t)
(delete-region
(match-beginning 0)
(progn (re-search-forward
"^[ \t]*:END:.*\n?" nil 'move)
(point))))
(unless (member 'planning keep)
(goto-char (point-min))
(while (re-search-forward kwd-time-re nil t)
(replace-match "")))
(goto-char (point-min))
(when org-agenda-entry-text-exclude-regexps
(let ((re-list org-agenda-entry-text-exclude-regexps) re)
(while (setq re (pop re-list))
(goto-char (point-min))
(while (re-search-forward re nil t)
(replace-match "")))))
(goto-char (point-max))
(skip-chars-backward " \t\n")
(when (looking-at "[ \t\n]+\\'") (replace-match ""))
;; find and remove min common indentation
(goto-char (point-min))
(untabify (point-min) (point-max))
(setq ind (org-current-text-indentation))
(while (not (eobp))
(unless (looking-at "[ \t]*$")
(setq ind (min ind (org-current-text-indentation))))
(forward-line 1))
(goto-char (point-min))
(while (not (eobp))
(unless (looking-at "[ \t]*$")
(move-to-column ind)
(delete-region (line-beginning-position) (point)))
(forward-line 1))
(run-hooks 'org-agenda-entry-text-cleanup-hook)
(goto-char (point-min))
(when indent
(while (and (not (eobp)) (re-search-forward "^" nil t))
(replace-match indent t t)))
(goto-char (point-min))
(while (looking-at "[ \t]*\n") (replace-match ""))
(goto-char (point-max))
(when (> (org-current-line)
n-lines)
(org-goto-line (1+ n-lines))
(backward-char 1))
(setq txt (buffer-substring (point-min) (point))))))))
txt))
(defun org-check-for-org-mode ()
"Make sure current buffer is in Org mode. Error if not."
(or (derived-mode-p 'org-mode)
(error "Cannot execute Org agenda command on buffer in %s"
major-mode)))
;;; Agenda prepare and finalize
(defvar org-agenda-multi nil) ; dynamically scoped
(defvar org-agenda-pre-window-conf nil)
(defvar org-agenda-columns-active nil)
(defvar org-agenda-name nil)
(defvar org-agenda-tag-filter nil)
(defvar org-agenda-category-filter nil)
(defvar org-agenda-regexp-filter nil)
(defvar org-agenda-effort-filter nil)
(defvar org-agenda-top-headline-filter nil)
(defvar org-agenda-represented-categories nil
"Cache for the list of all categories in the agenda.")
(defvar org-agenda-represented-tags nil
"Cache for the list of all categories in the agenda.")
(defvar org-agenda-tag-filter-preset nil
"A preset of the tags filter used for secondary agenda filtering.
This must be a list of strings, each string must be a single tag preceded
by \"+\" or \"-\".
This variable should not be set directly, but agenda custom commands can
bind it in the options section. The preset filter is a global property of
the entire agenda view. In a block agenda, it will not work reliably to
define a filter for one of the individual blocks. You need to set it in
the global options and expect it to be applied to the entire view.")
(defvar org-agenda-filters-preset nil
"Alist of filter types and associated preset of filters.
This variable is local in `org-agenda' buffers. See `org-agenda-local-vars'.")
(defconst org-agenda-filter-variables
'((category . org-agenda-category-filter)
(tag . org-agenda-tag-filter)
(effort . org-agenda-effort-filter)
(regexp . org-agenda-regexp-filter))
"Alist of filter types and associated variables.")
(defun org-agenda-filter-any ()
"Is any filter active?"
(cl-some (lambda (x)
(or (symbol-value (cdr x))
(assoc-default (car x) org-agenda-filters-preset)))
org-agenda-filter-variables))
(defvar org-agenda-category-filter-preset nil
"A preset of the category filter used for secondary agenda filtering.
This must be a list of strings, each string must be a single category
preceded by \"+\" or \"-\".
This variable should not be set directly, but agenda custom commands can
bind it in the options section. The preset filter is a global property of
the entire agenda view. In a block agenda, it will not work reliably to
define a filter for one of the individual blocks. You need to set it in
the global options and expect it to be applied to the entire view.")
(defvar org-agenda-regexp-filter-preset nil
"A preset of the regexp filter used for secondary agenda filtering.
This must be a list of strings, each string must be a single regexp
preceded by \"+\" or \"-\".
This variable should not be set directly, but agenda custom commands can
bind it in the options section. The preset filter is a global property of
the entire agenda view. In a block agenda, it will not work reliably to
define a filter for one of the individual blocks. You need to set it in
the global options and expect it to be applied to the entire view.")
(defvar org-agenda-effort-filter-preset nil
"A preset of the effort condition used for secondary agenda filtering.
This must be a list of strings, each string must be a single regexp
preceded by \"+\" or \"-\".
This variable should not be set directly, but agenda custom commands can
bind it in the options section. The preset filter is a global property of
the entire agenda view. In a block agenda, it will not work reliably to
define a filter for one of the individual blocks. You need to set it in
the global options and expect it to be applied to the entire view.")
(defun org-agenda-use-sticky-p ()
"Return non-nil if an agenda buffer named
`org-agenda-buffer-name' exists and should be shown instead of
generating a new one."
(and
;; turned off by user
org-agenda-sticky
;; For multi-agenda buffer already exists
(not org-agenda-multi)
;; buffer found
(get-buffer org-agenda-buffer-name)
;; C-u parameter is same as last call
(with-current-buffer org-agenda-buffer-name
(and
(equal current-prefix-arg
org-agenda-last-prefix-arg)
;; In case user turned stickiness on, while having existing
;; Agenda buffer active, don't reuse that buffer, because it
;; does not have org variables local
org-agenda-this-buffer-is-sticky))))
(defvar org-agenda-buffer-tmp-name nil)
(defun org-agenda--get-buffer-name (sticky-name)
(or org-agenda-buffer-tmp-name
(and org-agenda-doing-sticky-redo org-agenda-buffer-name)
sticky-name
"*Org Agenda*"))
(defun org-agenda-prepare-window (abuf filter-alist)
"Setup agenda buffer in the window.
ABUF is the buffer for the agenda window.
FILTER-ALIST is an alist of filters we need to apply when
`org-agenda-persistent-filter' is non-nil."
(let* ((awin (get-buffer-window abuf)) wconf)
(cond
((equal (current-buffer) abuf) nil)
(awin (select-window awin))
((not (setq wconf (current-window-configuration))))
((eq org-agenda-window-setup 'current-window)
(pop-to-buffer-same-window abuf))
((eq org-agenda-window-setup 'other-window)
(switch-to-buffer-other-window abuf))
((eq org-agenda-window-setup 'other-frame)
(switch-to-buffer-other-frame abuf))
((eq org-agenda-window-setup 'other-tab)
(if (fboundp 'switch-to-buffer-other-tab)
(switch-to-buffer-other-tab abuf)
(user-error "Your version of Emacs does not have tab bar support")))
((eq org-agenda-window-setup 'only-window)
(pop-to-buffer abuf '(org-display-buffer-full-frame)))
((eq org-agenda-window-setup 'reorganize-frame)
(pop-to-buffer abuf '(org-display-buffer-split))))
(setq org-agenda-tag-filter (cdr (assq 'tag filter-alist)))
(setq org-agenda-category-filter (cdr (assq 'cat filter-alist)))
(setq org-agenda-effort-filter (cdr (assq 'effort filter-alist)))
(setq org-agenda-regexp-filter (cdr (assq 're filter-alist)))
;; Additional test in case agenda is invoked from within agenda
;; buffer via elisp link.
(unless (equal (current-buffer) abuf)
(pop-to-buffer-same-window abuf))
(setq org-agenda-pre-window-conf
(or wconf org-agenda-pre-window-conf))))
(defun org-agenda-prepare (&optional name)
(let ((filter-alist (when org-agenda-persistent-filter
(with-current-buffer
(get-buffer-create org-agenda-buffer-name)
`((tag . ,org-agenda-tag-filter)
(re . ,org-agenda-regexp-filter)
(effort . ,org-agenda-effort-filter)
(cat . ,org-agenda-category-filter))))))
(if (org-agenda-use-sticky-p)
(progn
;; Popup existing buffer
(org-agenda-prepare-window (get-buffer org-agenda-buffer-name)
filter-alist)
(message "Sticky Agenda buffer, use `r' to refresh")
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
(throw 'exit "Sticky Agenda buffer, use `r' to refresh"))
(if org-agenda-multi
(progn
(setq buffer-read-only nil)
(goto-char (point-max))
(unless (or (bobp) org-agenda-compact-blocks
(not org-agenda-block-separator))
(insert "\n"
(if (stringp org-agenda-block-separator)
org-agenda-block-separator
(make-string (window-max-chars-per-line) org-agenda-block-separator))
"\n"))
(narrow-to-region (point) (point-max)))
(setq org-todo-keywords-for-agenda nil)
(setq org-done-keywords-for-agenda nil)
;; Setting any org variables that are in org-agenda-local-vars
;; list need to be done after the prepare call
(org-agenda-prepare-window
(get-buffer-create org-agenda-buffer-name) filter-alist)
(setq buffer-read-only nil)
(org-agenda-reset-markers)
(let ((inhibit-read-only t)) (erase-buffer))
(org-agenda-mode)
(setq org-agenda-buffer (current-buffer))
(setq org-agenda-contributing-files nil)
(setq org-agenda-columns-active nil)
(setq org-agenda-filters-preset
`((tag . ,org-agenda-tag-filter-preset)
(category . ,org-agenda-category-filter-preset)
(regexp . ,org-agenda-regexp-filter-preset)
(effort . ,org-agenda-effort-filter-preset)))
(org-agenda-prepare-buffers (org-agenda-files nil 'ifmode))
(setq org-todo-keywords-for-agenda
(org-uniquify org-todo-keywords-for-agenda))
(setq org-done-keywords-for-agenda
(org-uniquify org-done-keywords-for-agenda))
(setq org-agenda-last-prefix-arg current-prefix-arg)
(setq org-agenda-this-buffer-name org-agenda-buffer-name)
(and name (not org-agenda-name)
(setq-local org-agenda-name name)))
(setq buffer-read-only nil))))
(defvar org-overriding-columns-format)
(defvar org-local-columns-format)
(defun org-agenda-finalize ()
"Finishing touch for the agenda buffer.
This function is called just before displaying the agenda. If
you want to add your own functions to the finalization of the
agenda display, configure `org-agenda-finalize-hook'."
(unless org-agenda-multi
(let ((inhibit-read-only t))
(save-excursion
(goto-char (point-min))
(save-excursion
(while (org-activate-links (point-max))
(goto-char (match-end 0))))
(unless (eq org-agenda-remove-tags t)
(org-agenda-align-tags))
(unless org-agenda-with-colors
(remove-text-properties (point-min) (point-max) '(face nil)))
(when (bound-and-true-p org-overriding-columns-format)
(setq-local org-local-columns-format
org-overriding-columns-format))
(when org-agenda-view-columns-initially
(org-agenda-columns))
(when org-agenda-fontify-priorities
(org-agenda-fontify-priorities))
(when (and org-agenda-dim-blocked-tasks org-blocker-hook)
(org-agenda-dim-blocked-tasks))
(org-agenda-mark-clocking-task)
(when org-agenda-entry-text-mode
(org-agenda-entry-text-hide)
(org-agenda-entry-text-show))
(when (and (featurep 'org-habit)
(save-excursion (next-single-property-change (point-min) 'org-habit-p)))
(org-habit-insert-consistency-graphs))
(setq org-agenda-type (org-get-at-bol 'org-agenda-type))
(unless (or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
(memq org-agenda-type org-agenda-show-inherited-tags))
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(and (listp org-agenda-use-tag-inheritance)
(not (memq org-agenda-type
org-agenda-use-tag-inheritance))))))
(let (mrk)
(save-excursion
(goto-char (point-min))
(while (equal (forward-line) 0)
(when (setq mrk (get-text-property (point) 'org-hd-marker))
(put-text-property (line-beginning-position) (line-end-position)
'tags
(org-with-point-at mrk
(org-get-tags))))))))
(setq org-agenda-represented-tags nil
org-agenda-represented-categories nil)
(when org-agenda-top-headline-filter
(org-agenda-filter-top-headline-apply
org-agenda-top-headline-filter))
(when org-agenda-tag-filter
(org-agenda-filter-apply org-agenda-tag-filter 'tag t))
(when (assoc-default 'tag org-agenda-filters-preset)
(org-agenda-filter-apply
(assoc-default 'tag org-agenda-filters-preset) 'tag t))
(when org-agenda-category-filter
(org-agenda-filter-apply org-agenda-category-filter 'category))
(when (assoc-default 'category org-agenda-filters-preset)
(org-agenda-filter-apply
(assoc-default 'category org-agenda-filters-preset) 'category))
(when org-agenda-regexp-filter
(org-agenda-filter-apply org-agenda-regexp-filter 'regexp))
(when (assoc-default 'regexp org-agenda-filters-preset)
(org-agenda-filter-apply
(assoc-default 'regexp org-agenda-filters-preset) 'regexp))
(when org-agenda-effort-filter
(org-agenda-filter-apply org-agenda-effort-filter 'effort))
(when (assoc-default 'effort org-agenda-filters-preset)
(org-agenda-filter-apply
(assoc-default 'effort org-agenda-filters-preset) 'effort))
(add-hook 'kill-buffer-hook #'org-agenda-reset-markers 'append 'local))
(run-hooks 'org-agenda-finalize-hook))))
(defun org-agenda-mark-clocking-task ()
"Mark the current clock entry in the agenda if it is present."
;; We need to widen when `org-agenda-finalize' is called from
;; `org-agenda-change-all-lines' (e.g. in `org-agenda-clock-in').
(when (bound-and-true-p org-clock-current-task)
(save-restriction
(widen)
(org-agenda-unmark-clocking-task)
(when (marker-buffer org-clock-hd-marker)
(save-excursion
(goto-char (point-min))
(let (s ov)
(while (setq s (next-single-property-change (point) 'org-hd-marker))
(goto-char s)
(when (equal (org-get-at-bol 'org-hd-marker)
org-clock-hd-marker)
(setq ov (make-overlay (line-beginning-position)
(1+ (line-end-position))))
(overlay-put ov 'type 'org-agenda-clocking)
(overlay-put ov 'face 'org-agenda-clocking)
(overlay-put ov 'help-echo
"The clock is running in this item")))))))))
(defun org-agenda-unmark-clocking-task ()
"Unmark the current clocking task."
(mapc (lambda (o)
(when (eq (overlay-get o 'type) 'org-agenda-clocking)
(delete-overlay o)))
(overlays-in (point-min) (point-max))))
(defun org-agenda-fontify-priorities ()
"Make highest priority lines bold, and lowest italic."
(interactive)
(mapc (lambda (o) (when (eq (overlay-get o 'org-type) 'org-priority)
(delete-overlay o)))
(overlays-in (point-min) (point-max)))
(save-excursion
(let (b e p ov h l)
(goto-char (point-min))
(while (re-search-forward org-priority-regexp nil t)
(setq h (or (get-char-property (point) 'org-priority-highest)
org-priority-highest)
l (or (get-char-property (point) 'org-priority-lowest)
org-priority-lowest)
p (string-to-char (match-string 2))
b (match-beginning 1)
e (if (eq org-agenda-fontify-priorities 'cookies)
(1+ (match-end 2))
(line-end-position))
ov (make-overlay b e))
(overlay-put
ov 'face
(let ((special-face
(cond ((org-face-from-face-or-color
'priority 'org-priority
(cdr (assoc p org-priority-faces))))
((and (listp org-agenda-fontify-priorities)
(org-face-from-face-or-color
'priority 'org-priority
(cdr (assoc p org-agenda-fontify-priorities)))))
((equal p l) 'italic)
((equal p h) 'bold))))
(if special-face (list special-face 'org-priority) 'org-priority)))
(overlay-put ov 'org-type 'org-priority)))))
(defvar org-depend-tag-blocked)
(defun org-agenda-dim-blocked-tasks (&optional _invisible)
"Dim currently blocked TODOs in the agenda display.
When INVISIBLE is non-nil, hide currently blocked TODO instead of
dimming them." ;FIXME: The arg isn't used, actually!
(interactive "P")
(when (called-interactively-p 'interactive)
(message "Dim or hide blocked tasks..."))
(dolist (o (overlays-in (point-min) (point-max)))
(when (eq (overlay-get o 'face) 'org-agenda-dimmed-todo-face)
(delete-overlay o)))
(save-excursion
(let ((inhibit-read-only t))
(goto-char (point-min))
(while (let ((pos (text-property-not-all
(point) (point-max) 'org-todo-blocked nil)))
(when pos (goto-char pos)))
(let* ((invisible
(eq (org-get-at-bol 'org-todo-blocked) 'invisible))
(todo-blocked
(eq (org-get-at-bol 'org-filter-type) 'todo-blocked))
(ov (make-overlay (if invisible
(line-end-position 0)
(line-beginning-position))
(line-end-position))))
(when todo-blocked
(overlay-put ov 'face 'org-agenda-dimmed-todo-face)
;; Override other overlays.
(overlay-put ov 'priority 50))
(when invisible
(org-agenda-filter-hide-line 'todo-blocked)))
(if (= (point-max) (line-end-position))
(goto-char (point-max))
(move-beginning-of-line 2)))))
(when (called-interactively-p 'interactive)
(message "Dim or hide blocked tasks...done")))
(defun org-agenda--mark-blocked-entry (entry)
"If ENTRY is blocked, mark it for fontification or invisibility.
If the header at `org-hd-marker' is blocked according to
`org-entry-blocked-p', then if `org-agenda-dim-blocked-tasks' is
`invisible' and the header is not blocked by checkboxes, set the
text property `org-todo-blocked' to `invisible', otherwise set it
to t."
(when (get-text-property 0 'todo-state entry)
(let ((entry-marker (get-text-property 0 'org-hd-marker entry))
(org-blocked-by-checkboxes nil)
;; Necessary so that `org-entry-blocked-p' does not change
;; the buffer.
(org-depend-tag-blocked nil))
(when entry-marker
(let ((blocked
(with-current-buffer (marker-buffer entry-marker)
(save-excursion
(goto-char entry-marker)
(org-entry-blocked-p)))))
(when blocked
(let ((really-invisible
(and (not org-blocked-by-checkboxes)
(eq org-agenda-dim-blocked-tasks 'invisible))))
(put-text-property
0 (length entry) 'org-todo-blocked
(if really-invisible 'invisible t)
entry)
(put-text-property
0 (length entry) 'org-filter-type 'todo-blocked entry)))))))
entry)
(defvar org-agenda-skip-function nil
"Function to be called at each match during agenda construction.
If this function returns nil, the current match should not be skipped.
Otherwise, the function must return a position from where the search
should be continued.
This may also be a Lisp form that will be evaluated. Useful
forms include `org-agenda-skip-entry-if' and
`org-agenda-skip-subtree-if'. See the Info node `(org) Special
Agenda Views' for more details and examples.
Never set this variable using `setq' or similar, because then it
will apply to all future agenda commands. If you want a global
skipping condition, use the option `org-agenda-skip-function-global'
instead.
The correct way to use `org-agenda-skip-function' is to bind it with `let'
to scope it dynamically into the agenda-constructing command.
A good way to set it is through options in `org-agenda-custom-commands'.")
(defun org-agenda-skip (&optional element)
"Throw to `:skip' in places that should be skipped.
Also moves point to the end of the skipped region, so that search can
continue from there.
Optional argument ELEMENT contains element at point."
(save-match-data
(when (or
(if element
(org-element-type-p element 'comment)
(save-excursion
(goto-char (line-beginning-position))
(looking-at comment-start-skip)))
(and org-agenda-skip-archived-trees (not org-agenda-archives-mode)
(or (and (save-match-data (org-in-archived-heading-p nil element))
(org-end-of-subtree t element))
(and (member org-archive-tag org-file-tags)
(goto-char (point-max)))))
(and org-agenda-skip-comment-trees
(org-in-commented-heading-p nil element)
(org-end-of-subtree t element))
(let ((to (or (org-agenda-skip-eval org-agenda-skip-function-global)
(org-agenda-skip-eval org-agenda-skip-function))))
(and to (goto-char to)))
(org-in-src-block-p t element))
(throw :skip t))))
(defun org-agenda-skip-eval (form)
"If FORM is a function or a list, call (or eval) it and return the result.
`save-excursion' and `save-match-data' are wrapped around the call, so point
and match data are returned to the previous state no matter what these
functions do."
(let (fp)
(and form
(or (setq fp (functionp form))
(consp form))
(save-excursion
(save-match-data
(if fp
(funcall form)
(eval form t)))))))
(defvar org-agenda-markers nil
"List of all currently active markers created by `org-agenda'.")
(defvar org-agenda-last-marker-time (float-time)
"Creation time of the last agenda marker.")
(defun org-agenda-new-marker (&optional pos)
"Return a new agenda marker.
Marker is at point, or at POS if non-nil. Org mode keeps a list
of these markers and resets them when they are no longer in use."
(let ((m (copy-marker (or pos (point)) t)))
(setq org-agenda-last-marker-time (float-time))
(if (and org-agenda-buffer (buffer-live-p org-agenda-buffer))
(with-current-buffer org-agenda-buffer
(push m org-agenda-markers))
(push m org-agenda-markers))
m))
(defun org-agenda-reset-markers ()
"Reset markers created by `org-agenda'."
(while org-agenda-markers
(move-marker (pop org-agenda-markers) nil)))
(defun org-agenda-save-markers-for-cut-and-paste (beg end)
"Save relative positions of markers in region.
This check for agenda markers in all agenda buffers currently active."
(dolist (buf (buffer-list))
(with-current-buffer buf
(when (eq major-mode 'org-agenda-mode)
(mapc (lambda (m) (org-check-and-save-marker m beg end))
org-agenda-markers)))))
;;; Entry text mode
(defun org-agenda-entry-text-show-here ()
"Add some text from the entry as context to the current line."
(let (m txt o)
(setq m (org-get-at-bol 'org-hd-marker))
(unless (marker-buffer m)
(error "No marker points to an entry here"))
(setq txt (concat "\n" (org-no-properties
(org-agenda-get-some-entry-text
m org-agenda-entry-text-maxlines
org-agenda-entry-text-leaders))))
(when (string-match "\\S-" txt)
(setq o (make-overlay (line-beginning-position) (line-end-position)))
(overlay-put o 'evaporate t)
(overlay-put o 'org-overlay-type 'agenda-entry-content)
(overlay-put o 'after-string txt))))
(defun org-agenda-entry-text-show ()
"Add entry context for all agenda lines."
(interactive)
(save-excursion
(goto-char (point-max))
(forward-line 0)
(while (not (bobp))
(when (org-get-at-bol 'org-hd-marker)
(org-agenda-entry-text-show-here))
(forward-line -1))))
(defun org-agenda-entry-text-hide ()
"Remove any shown entry context."
(mapc (lambda (o)
(when (eq (overlay-get o 'org-overlay-type)
'agenda-entry-content)
(delete-overlay o)))
(overlays-in (point-min) (point-max))))
(defun org-agenda-get-day-face (date)
"Return the face DATE should be displayed with."
(cond ((and (functionp org-agenda-day-face-function)
(funcall org-agenda-day-face-function date)))
((and (org-agenda-today-p date)
(memq (calendar-day-of-week date) org-agenda-weekend-days))
'org-agenda-date-weekend-today)
((org-agenda-today-p date) 'org-agenda-date-today)
((memq (calendar-day-of-week date) org-agenda-weekend-days)
'org-agenda-date-weekend)
(t 'org-agenda-date)))
(defvar org-agenda-show-log-scoped)
;;; Agenda Daily/Weekly
(defvar org-agenda-start-day nil ; dynamically scoped parameter
"Start day for the agenda view.
Custom commands can set this variable in the options section.
This is usually a string like \"2007-11-01\", \"+2d\" or any other
input allowed when reading a date through the Org calendar.
See the docstring of `org-read-date' for details.
This variable has no effect when `org-agenda-start-on-weekday' is set
and agenda spans 7 or 14 days.")
(defvar org-starting-day nil) ; local variable in the agenda buffer
(defvar org-arg-loc nil) ; local variable
;;;###autoload
(defun org-agenda-list (&optional arg start-day span with-hour)
"Produce a daily/weekly view from all files in variable `org-agenda-files'.
The view will be for the current day or week, but from the overview buffer
you will be able to go to other days/weeks.
With a numeric prefix argument in an interactive call, the agenda will
span ARG days. Lisp programs should instead specify SPAN to change
the number of days. SPAN defaults to `org-agenda-span'.
START-DAY defaults to TODAY, or to the most recent match for the weekday
given in `org-agenda-start-on-weekday'.
When WITH-HOUR is non-nil, only include scheduled and deadline
items if they have an hour specification like [h]h:mm."
(interactive "P")
(when org-agenda-overriding-arguments
(setq arg (car org-agenda-overriding-arguments)
start-day (nth 1 org-agenda-overriding-arguments)
span (nth 2 org-agenda-overriding-arguments)))
(when (and (integerp arg) (> arg 0))
(setq span arg arg nil))
(when (numberp span)
(unless (< 0 span)
(user-error "Agenda creation impossible for this span(=%d days)" span)))
(catch 'exit
(setq org-agenda-buffer-name
(org-agenda--get-buffer-name
(and org-agenda-sticky
(cond ((and org-keys (stringp org-match))
(format "*Org Agenda(%s:%s)*" org-keys org-match))
(org-keys
(format "*Org Agenda(%s)*" org-keys))
(t "*Org Agenda(a)*")))))
(org-agenda-prepare "Day/Week")
(setq start-day (or start-day org-agenda-start-day))
(when (stringp start-day)
;; Convert to an absolute day number
(setq start-day (time-to-days (org-read-date nil t start-day))))
(org-compile-prefix-format 'agenda)
(org-set-sorting-strategy 'agenda)
(let* ((span (org-agenda-ndays-to-span (or span org-agenda-span)))
(today (org-today))
(sd (or start-day today))
(ndays (org-agenda-span-to-ndays span sd))
(org-agenda-start-on-weekday
(and (or (eq ndays 7) (eq ndays 14))
org-agenda-start-on-weekday))
(thefiles (org-agenda-files nil 'ifmode))
(files thefiles)
(start (if (or (null org-agenda-start-on-weekday)
(< ndays 7))
sd
(let* ((nt (calendar-day-of-week
(calendar-gregorian-from-absolute sd)))
(n1 org-agenda-start-on-weekday)
(d (- nt n1)))
(- sd (+ (if (< d 0) 7 0) d)))))
(day-numbers (list start))
(day-cnt 0)
;; FIXME: This may cause confusion when users are trying to
;; debug agenda. The debugger will not trigger without
;; redisplay.
(inhibit-redisplay (not debug-on-error))
(org-agenda-show-log-scoped org-agenda-show-log)
s rtn rtnall file date d start-pos end-pos todayp ;; e
clocktable-start clocktable-end) ;; filter
(setq org-agenda-redo-command
(list 'org-agenda-list (list 'quote arg) start-day (list 'quote span) with-hour))
(dotimes (_ (1- ndays))
(push (1+ (car day-numbers)) day-numbers))
(setq day-numbers (nreverse day-numbers))
(setq clocktable-start (car day-numbers)
clocktable-end (1+ (or (org-last day-numbers) 0)))
(setq-local org-starting-day (car day-numbers))
(setq-local org-arg-loc arg)
(setq-local org-agenda-current-span (org-agenda-ndays-to-span span))
(unless org-agenda-compact-blocks
(let* ((d1 (car day-numbers))
(d2 (org-last day-numbers))
(w1 (org-days-to-iso-week d1))
(w2 (org-days-to-iso-week d2)))
(setq s (point))
(org-agenda--insert-overriding-header
(concat (org-agenda-span-name span)
"-agenda"
(cond ((<= 350 (- d2 d1)) "")
((= w1 w2) (format " (W%02d)" w1))
(t (format " (W%02d-W%02d)" w1 w2)))
":\n")))
;; Add properties if we actually inserted a header.
(when (> (point) s)
(add-text-properties s (1- (point))
(list 'face 'org-agenda-structure
'org-date-line t))
(org-agenda-mark-header-line s)))
(while (setq d (pop day-numbers))
(setq date (calendar-gregorian-from-absolute d)
s (point))
(if (or (setq todayp (= d today))
(and (not start-pos) (= d sd)))
(setq start-pos (point))
(when (and start-pos (not end-pos))
(setq end-pos (point))))
(setq files thefiles
rtnall nil)
(while (setq file (pop files))
(catch 'nextfile
(org-check-agenda-file file)
(let ((org-agenda-entry-types org-agenda-entry-types))
;; Starred types override non-starred equivalents
(when (member :deadline* org-agenda-entry-types)
(setq org-agenda-entry-types
(delq :deadline org-agenda-entry-types)))
(when (member :scheduled* org-agenda-entry-types)
(setq org-agenda-entry-types
(delq :scheduled org-agenda-entry-types)))
;; Honor with-hour
(when with-hour
(when (member :deadline org-agenda-entry-types)
(setq org-agenda-entry-types
(delq :deadline org-agenda-entry-types))
(push :deadline* org-agenda-entry-types))
(when (member :scheduled org-agenda-entry-types)
(setq org-agenda-entry-types
(delq :scheduled org-agenda-entry-types))
(push :scheduled* org-agenda-entry-types)))
(unless org-agenda-include-deadlines
(setq org-agenda-entry-types
(delq :deadline* (delq :deadline org-agenda-entry-types))))
(cond
((memq org-agenda-show-log-scoped '(only clockcheck))
(setq rtn (org-agenda-get-day-entries
file date :closed)))
(org-agenda-show-log-scoped
(setq rtn (apply #'org-agenda-get-day-entries
file date
(append '(:closed) org-agenda-entry-types))))
(t
(setq rtn (apply #'org-agenda-get-day-entries
file date
org-agenda-entry-types)))))
(setq rtnall (append rtnall rtn)))) ;; all entries
(when org-agenda-include-diary
(let ((org-agenda-search-headline-for-time t))
(require 'diary-lib)
(setq rtn (org-get-entries-from-diary date))
(setq rtnall (append rtnall rtn))))
(when (or rtnall org-agenda-show-all-dates)
(setq day-cnt (1+ day-cnt))
(insert
(if (stringp org-agenda-format-date)
(format-time-string org-agenda-format-date
(org-time-from-absolute date))
(funcall org-agenda-format-date date))
"\n")
(put-text-property s (1- (point)) 'face
(org-agenda-get-day-face date))
(put-text-property s (1- (point)) 'org-date-line t)
(put-text-property s (1- (point)) 'org-agenda-date-header t)
(put-text-property s (1- (point)) 'org-day-cnt day-cnt)
(when todayp
(put-text-property s (1- (point)) 'org-today t))
(setq rtnall
(org-agenda-add-time-grid-maybe rtnall ndays todayp))
(when rtnall (insert ;; all entries
(org-agenda-finalize-entries rtnall 'agenda)
"\n"))
(put-text-property s (1- (point)) 'day d)
(put-text-property s (1- (point)) 'org-day-cnt day-cnt)))
(when (and org-agenda-clockreport-mode clocktable-start)
(let ((org-agenda-files (org-agenda-files nil 'ifmode))
;; the above line is to ensure the restricted range!
(p (copy-sequence org-agenda-clockreport-parameter-plist))
tbl)
(setq p (org-plist-delete p :block))
(setq p (plist-put p :tstart clocktable-start))
(setq p (plist-put p :tend clocktable-end))
(setq p (plist-put p :scope 'agenda))
(setq tbl (apply #'org-clock-get-clocktable p))
(when org-agenda-clock-report-header
(insert (propertize org-agenda-clock-report-header 'face 'org-agenda-structure))
(unless (string-suffix-p "\n" org-agenda-clock-report-header)
(insert "\n")))
(insert tbl)))
(goto-char (point-min))
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
(unless (or (not (get-buffer-window org-agenda-buffer-name))
(and (pos-visible-in-window-p (point-min))
(pos-visible-in-window-p (point-max))))
(goto-char (1- (point-max)))
(recenter -1)
(when (not (pos-visible-in-window-p (or start-pos 1)))
(goto-char (or start-pos 1))
(recenter 1)))
(goto-char (or start-pos 1))
(add-text-properties (point-min) (point-max)
`(org-agenda-type agenda
org-last-args (,arg ,start-day ,span)
org-redo-cmd ,org-agenda-redo-command
org-series-cmd ,org-cmd))
(when (eq org-agenda-show-log-scoped 'clockcheck)
(org-agenda-show-clocking-issues))
(org-agenda-finalize)
(setq buffer-read-only t)
(message ""))))
(defun org-agenda-ndays-to-span (n)
"Return a span symbol for a span of N days, or N if none matches."
(cond ((symbolp n) n)
((= n 1) 'day)
((= n 7) 'week)
((= n 14) 'fortnight)
(t n)))
(defun org-agenda-span-to-ndays (span &optional start-day)
"Return ndays from SPAN, possibly starting at START-DAY.
START-DAY is an absolute time value."
(cond ((numberp span) span)
((eq span 'day) 1)
((eq span 'week) 7)
((eq span 'fortnight) 14)
((eq span 'month)
(let ((date (calendar-gregorian-from-absolute start-day)))
(calendar-last-day-of-month (car date) (cl-caddr date))))
((eq span 'year)
(let ((date (calendar-gregorian-from-absolute start-day)))
(if (calendar-leap-year-p (cl-caddr date)) 366 365)))))
(defun org-agenda-span-name (span)
"Return a SPAN name."
(if (null span)
""
(if (symbolp span)
(capitalize (symbol-name span))
(format "%d days" span))))
;;; Agenda word search
(defvar org-agenda-search-history nil)
(defvar org-search-syntax-table nil
"Special syntax table for Org search.
In this table, we have single quotes not as word constituents, to
that when \"+Ameli\" is searched as a work, it will also match \"Ameli's\"")
(defvar org-mode-syntax-table) ; From org.el
(defun org-search-syntax-table ()
(unless org-search-syntax-table
(setq org-search-syntax-table (copy-syntax-table org-mode-syntax-table))
(modify-syntax-entry ?' "." org-search-syntax-table)
(modify-syntax-entry ?` "." org-search-syntax-table))
org-search-syntax-table)
(defvar org-agenda-last-search-view-search-was-boolean nil)
;;;###autoload
(defun org-search-view (&optional todo-only string edit-at)
"Show all entries that contain a phrase or words or regular expressions.
With optional prefix argument TODO-ONLY, only consider entries that are
TODO entries. The argument STRING can be used to pass a default search
string into this function. If EDIT-AT is non-nil, it means that the
user should get a chance to edit this string, with cursor at position
EDIT-AT.
The search string can be viewed either as a phrase that should be found as
is, or it can be broken into a number of snippets, each of which must match
in a Boolean way to select an entry. The default depends on the variable
`org-agenda-search-view-always-boolean'.
Even if this is turned off (the default) you can always switch to
Boolean search dynamically by preceding the first word with \"+\" or \"-\".
The default is a direct search of the whole phrase, where each space in
the search string can expand to an arbitrary amount of whitespace,
including newlines.
If using a Boolean search, the search string is split on whitespace and
each snippet is searched separately, with logical AND to select an entry.
Words prefixed with a minus must *not* occur in the entry. Words without
a prefix or prefixed with a plus must occur in the entry. Matching is
case-insensitive. Words are enclosed by word delimiters (i.e. they must
match whole words, not parts of a word) if
`org-agenda-search-view-force-full-words' is set (default is nil).
Boolean search snippets enclosed by curly braces are interpreted as
regular expressions that must or (when preceded with \"-\") must not
match in the entry. Snippets enclosed into double quotes will be taken
as a whole, to include whitespace.
- If the search string starts with an asterisk, search only in headlines.
- If (possibly after the leading star) the search string starts with an
exclamation mark, this also means to look at TODO entries only, an effect
that can also be achieved with a prefix argument.
- If (possibly after star and exclamation mark) the search string starts
with a colon, this will mean that the (non-regexp) snippets of the
Boolean search must match as full words.
This command searches the agenda files, and in addition the files
listed in `org-agenda-text-search-extra-files' unless a restriction lock
is active."
(interactive "P")
(when org-agenda-overriding-arguments
(setq todo-only (car org-agenda-overriding-arguments)
string (nth 1 org-agenda-overriding-arguments)
edit-at (nth 2 org-agenda-overriding-arguments)))
(let* ((props (list 'face nil
'done-face 'org-agenda-done
'org-not-done-regexp org-not-done-regexp
'org-todo-regexp org-todo-regexp
'org-complex-heading-regexp org-complex-heading-regexp
'mouse-face 'highlight
'help-echo "mouse-2 or RET jump to location"))
(full-words org-agenda-search-view-force-full-words)
(org-agenda-text-search-extra-files org-agenda-text-search-extra-files)
regexp rtn rtnall files file pos inherited-tags
marker category level tags c neg re boolean
ee txt beg end last-search-end words regexps+ regexps- hdl-only buffer beg1 str)
(unless (and (not edit-at)
(stringp string)
(string-match "\\S-" string))
(setq string (read-string
(if org-agenda-search-view-always-boolean
"[+-]Word/{Regexp} ...: "
"Phrase or [+-]Word/{Regexp} ...: ")
(cond
((integerp edit-at) (cons string edit-at))
(edit-at string))
'org-agenda-search-history)))
(catch 'exit
(setq org-agenda-buffer-name
(org-agenda--get-buffer-name
(and org-agenda-sticky
(if (stringp string)
(format "*Org Agenda(%s:%s)*"
(or org-keys (or (and todo-only "S") "s"))
string)
(format "*Org Agenda(%s)*"
(or (and todo-only "S") "s"))))))
(org-agenda-prepare "SEARCH")
(org-compile-prefix-format 'search)
(org-set-sorting-strategy 'search)
(setq org-agenda-redo-command
(list 'org-search-view (if todo-only t nil)
(list 'if 'current-prefix-arg nil string)))
(setq org-agenda-query-string string)
(if (equal (string-to-char string) ?*)
(setq hdl-only t
words (substring string 1))
(setq words string))
(when (equal (string-to-char words) ?!)
(setq todo-only t
words (substring words 1)))
(when (equal (string-to-char words) ?:)
(setq full-words t
words (substring words 1)))
(when (or org-agenda-search-view-always-boolean
(member (string-to-char words) '(?- ?+ ?\{)))
(setq boolean t))
(setq words (split-string words))
(let (www w)
(while (setq w (pop words))
(while (and (string-match "\\\\\\'" w) words)
(setq w (concat (substring w 0 -1) " " (pop words))))
(push w www))
(setq words (nreverse www) www nil)
(while (setq w (pop words))
(when (and (string-match "\\`[-+]?{" w)
(not (string-match "}\\'" w)))
(while (and words (not (string-match "}\\'" (car words))))
(setq w (concat w " " (pop words))))
(setq w (concat w " " (pop words))))
(push w www))
(setq words (nreverse www)))
(setq org-agenda-last-search-view-search-was-boolean boolean)
(when boolean
(let (wds w)
(while (setq w (pop words))
(when (or (equal (substring w 0 1) "\"")
(and (> (length w) 1)
(member (substring w 0 1) '("+" "-"))
(equal (substring w 1 2) "\"")))
(while (and words (not (equal (substring w -1) "\"")))
(setq w (concat w " " (pop words)))))
(and (string-match "\\`\\([-+]?\\)\"" w)
(setq w (replace-match "\\1" nil nil w)))
(and (equal (substring w -1) "\"") (setq w (substring w 0 -1)))
(push w wds))
(setq words (nreverse wds))))
(if boolean
(mapc (lambda (w)
(setq c (string-to-char w))
(if (equal c ?-)
(setq neg t w (substring w 1))
(if (equal c ?+)
(setq neg nil w (substring w 1))
(setq neg nil)))
(if (string-match "\\`{.*}\\'" w)
(setq re (substring w 1 -1))
(if full-words
(setq re (concat "\\<" (regexp-quote (downcase w)) "\\>"))
(setq re (regexp-quote (downcase w)))))
(if neg (push re regexps-) (push re regexps+)))
words)
(push (mapconcat #'regexp-quote words "\\s-+")
regexps+))
(setq regexps+ (sort regexps+ (lambda (a b) (> (length a) (length b)))))
(if (not regexps+)
(setq regexp org-outline-regexp-bol)
(setq regexp (pop regexps+))
(when hdl-only (setq regexp (concat org-outline-regexp-bol ".*?"
regexp))))
(setq files (org-agenda-files nil 'ifmode))
;; Add `org-agenda-text-search-extra-files' unless there is some
;; restriction.
(when (eq (car org-agenda-text-search-extra-files) 'agenda-archives)
(pop org-agenda-text-search-extra-files)
(unless (get 'org-agenda-files 'org-restrict)
(setq files (org-add-archive-files files))))
;; Uniquify files. However, let `org-check-agenda-file' handle
;; non-existent ones.
(setq files (cl-remove-duplicates
(append files org-agenda-text-search-extra-files)
:test (lambda (a b)
(and (file-exists-p a)
(file-exists-p b)
(file-equal-p a b))))
rtnall nil)
(while (setq file (pop files))
(setq ee nil)
(catch 'nextfile
(org-check-agenda-file file)
(setq buffer (if (file-exists-p file)
(org-get-agenda-file-buffer file)
(error "No such file %s" file)))
(unless buffer
;; If file does not exist, make sure an error message is sent
(setq rtn (list (format "ORG-AGENDA-ERROR: No such org-file %s"
file))))
(with-current-buffer buffer
(with-syntax-table (org-search-syntax-table)
(unless (derived-mode-p 'org-mode)
(error "Agenda file %s is not in Org mode" file))
(let ((case-fold-search t))
(save-excursion
(save-restriction
(if (eq buffer org-agenda-restrict)
(narrow-to-region org-agenda-restrict-begin
org-agenda-restrict-end)
(widen))
(goto-char (point-min))
(unless (or (org-at-heading-p)
(outline-next-heading))
(throw 'nextfile t))
(goto-char (max (point-min) (1- (point))))
(while (re-search-forward regexp nil t)
(setq last-search-end (point))
(org-back-to-heading t)
(while (and (not (zerop org-agenda-search-view-max-outline-level))
(> (org-reduced-level (org-outline-level))
org-agenda-search-view-max-outline-level)
(forward-line -1)
(org-back-to-heading t)))
(skip-chars-forward "* ")
(setq beg (line-beginning-position)
beg1 (point)
end (progn
(outline-next-heading)
(while (and (not (zerop org-agenda-search-view-max-outline-level))
(> (org-reduced-level (org-outline-level))
org-agenda-search-view-max-outline-level)
(forward-line 1)
(outline-next-heading)))
(point)))
(catch :skip
(goto-char beg)
(org-agenda-skip)
(setq str (buffer-substring-no-properties
(line-beginning-position)
(if hdl-only (line-end-position) end)))
(mapc (lambda (wr) (when (string-match wr str)
(goto-char (1- end))
(throw :skip t)))
regexps-)
(mapc (lambda (wr) (unless (string-match wr str)
(goto-char (1- end))
(throw :skip t)))
(if todo-only
(cons (concat "^\\*+[ \t]+"
org-not-done-regexp)
regexps+)
regexps+))
(goto-char beg)
(setq marker (org-agenda-new-marker (point))
category (org-get-category)
level (make-string (org-reduced-level (org-outline-level)) ? )
inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
(memq 'todo org-agenda-show-inherited-tags))
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'todo org-agenda-use-tag-inheritance))))
tags (org-get-tags nil (not inherited-tags))
txt (org-agenda-format-item
""
(buffer-substring-no-properties
beg1 (line-end-position))
level category tags t))
(org-add-props txt props
'org-marker marker 'org-hd-marker marker
'org-todo-regexp org-todo-regexp
'level level
'org-complex-heading-regexp org-complex-heading-regexp
'urgency 1000
'priority 1000
'type "search")
(push txt ee)
(goto-char (max (1- end) last-search-end))))))))))
(setq rtn (nreverse ee))
(setq rtnall (append rtnall rtn)))
(org-agenda--insert-overriding-header
(with-temp-buffer
(insert "Search words: ")
(add-text-properties (point-min) (1- (point))
(list 'face 'org-agenda-structure))
(setq pos (point))
(insert string "\n")
(add-text-properties pos (1- (point)) (list 'face 'org-agenda-structure-filter))
(setq pos (point))
(unless org-agenda-multi
(insert (substitute-command-keys "\\\
Press `\\[org-agenda-manipulate-query-add]', \
`\\[org-agenda-manipulate-query-subtract]' to add/sub word, \
`\\[org-agenda-manipulate-query-add-re]', \
`\\[org-agenda-manipulate-query-subtract-re]' to add/sub regexp, \
`\\[universal-argument] \\[org-agenda-redo]' for a fresh search\n"))
(add-text-properties pos (1- (point))
(list 'face 'org-agenda-structure-secondary)))
(buffer-string)))
(org-agenda-mark-header-line (point-min))
(when rtnall
(insert (org-agenda-finalize-entries rtnall 'search) "\n"))
(goto-char (point-min))
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
(add-text-properties (point-min) (point-max)
`(org-agenda-type search
org-last-args (,todo-only ,string ,edit-at)
org-redo-cmd ,org-agenda-redo-command
org-series-cmd ,org-cmd))
(org-agenda-finalize)
(setq buffer-read-only t))))
;;; Agenda TODO list
(defun org-agenda-propertize-selected-todo-keywords (keywords)
"Use `org-todo-keyword-faces' for the selected todo KEYWORDS."
(concat
(if (or (equal keywords "ALL") (not keywords))
(propertize "ALL" 'face 'org-agenda-structure-filter)
(mapconcat
(lambda (kw)
(propertize kw 'face (list (org-get-todo-face kw) 'org-agenda-structure)))
(org-split-string keywords "|")
"|"))
"\n"))
(defvar org-select-this-todo-keyword nil
"Keyword selector for todo agenda.
Should either be a keyword, \"*\", or \"|\"-separated list of todo
keywords.")
(defvar org-last-arg nil)
(defvar crm-separator)
;;;###autoload
(defun org-todo-list (&optional arg)
"Show all (not done) TODO entries from all agenda files in a single list.
The prefix arg can be used to select a specific TODO keyword and limit
the list to these. When using `\\[universal-argument]', you will be prompted
for a keyword. A numeric prefix directly selects the Nth keyword in
`org-todo-keywords-1'."
(interactive "P")
(when org-agenda-overriding-arguments
(setq arg org-agenda-overriding-arguments))
(when (and (stringp arg) (not (string-match "\\S-" arg)))
(setq arg nil))
(let* ((today (calendar-gregorian-from-absolute (org-today)))
(completion-ignore-case t)
todo-keywords org-select-this-todo-keyword todo-entries all-todo-entries files file pos)
(catch 'exit
(setq org-agenda-buffer-name
(org-agenda--get-buffer-name
(when org-agenda-sticky
(if (stringp org-select-this-todo-keyword)
(format "*Org Agenda(%s:%s)*" (or org-keys "t")
org-select-this-todo-keyword)
(format "*Org Agenda(%s)*" (or org-keys "t"))))))
(org-agenda-prepare "TODO")
(setq todo-keywords org-todo-keywords-for-agenda
org-select-this-todo-keyword (cond ((stringp arg) arg)
((and (integerp arg) (> arg 0))
(nth (1- arg) todo-keywords))))
(when (equal arg '(4))
(setq org-select-this-todo-keyword
(mapconcat #'identity
(let ((crm-separator "|"))
(completing-read-multiple
"Keyword (or KWD1|KWD2|...): "
(mapcar #'list todo-keywords) nil nil))
"|")))
(when (equal arg 0)
(setq org-select-this-todo-keyword nil))
(org-compile-prefix-format 'todo)
(org-set-sorting-strategy 'todo)
(setq org-agenda-redo-command
`(org-todo-list (or (and (numberp current-prefix-arg) current-prefix-arg)
,org-select-this-todo-keyword
current-prefix-arg
,arg)))
(setq files (org-agenda-files nil 'ifmode)
all-todo-entries nil)
(while (setq file (pop files))
(catch 'nextfile
(org-check-agenda-file file)
(setq todo-entries (org-agenda-get-day-entries file today :todo))
(setq all-todo-entries (append all-todo-entries todo-entries))))
(org-agenda--insert-overriding-header
(with-temp-buffer
(insert "Global list of TODO items of type: ")
(add-text-properties (point-min) (1- (point))
(list 'face 'org-agenda-structure
'short-heading
(concat "ToDo: "
(or org-select-this-todo-keyword "ALL"))))
(org-agenda-mark-header-line (point-min))
(insert (org-agenda-propertize-selected-todo-keywords
org-select-this-todo-keyword))
(setq pos (point))
(unless org-agenda-multi
(insert (substitute-command-keys "Press \
\\`N \\[org-agenda-redo]' (e.g. `0 \\[org-agenda-redo]') \
to search again: (0)[ALL]"))
(let ((n 0))
(dolist (k todo-keywords)
(let ((s (format "(%d)%s" (cl-incf n) k)))
(when (> (+ (current-column) (string-width s) 1) (window-max-chars-per-line))
(insert "\n "))
(insert " " s))))
(insert "\n"))
(add-text-properties pos (1- (point)) (list 'face 'org-agenda-structure-secondary))
(buffer-string)))
(org-agenda-mark-header-line (point-min))
(when all-todo-entries
(insert (org-agenda-finalize-entries all-todo-entries 'todo) "\n"))
(goto-char (point-min))
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
(add-text-properties (point-min) (point-max)
`(org-agenda-type todo
org-last-args ,arg
org-redo-cmd ,org-agenda-redo-command
org-series-cmd ,org-cmd))
(org-agenda-finalize)
(setq buffer-read-only t))))
;;; Agenda tags match
;;;###autoload
(defun org-tags-view (&optional todo-only match)
"Show all headlines for all `org-agenda-files' matching a TAGS criterion.
The prefix arg TODO-ONLY limits the search to TODO entries."
(interactive "P")
(when org-agenda-overriding-arguments
(setq todo-only (car org-agenda-overriding-arguments)
match (nth 1 org-agenda-overriding-arguments)))
(let* ((org-tags-match-list-sublevels
org-tags-match-list-sublevels)
(completion-ignore-case t)
(org--matcher-tags-todo-only todo-only)
rtn rtnall files file pos matcher
buffer)
(when (and (stringp match) (not (string-match "\\S-" match)))
(setq match nil))
(catch 'exit
(setq org-agenda-buffer-name
(org-agenda--get-buffer-name
(and org-agenda-sticky
(if (stringp match)
(format "*Org Agenda(%s:%s)*"
(or org-keys (or (and todo-only "M") "m"))
match)
(format "*Org Agenda(%s)*"
(or (and todo-only "M") "m"))))))
(setq matcher (org-make-tags-matcher match))
;; Prepare agendas (and `org-tag-alist-for-agenda') before
;; expanding tags within `org-make-tags-matcher'
(org-agenda-prepare (concat "TAGS " match))
(setq match (car matcher)
matcher (cdr matcher))
(org-compile-prefix-format 'tags)
(org-set-sorting-strategy 'tags)
(setq org-agenda-query-string match)
(setq org-agenda-redo-command
(list 'org-tags-view
`(quote ,org--matcher-tags-todo-only)
`(if current-prefix-arg nil ,org-agenda-query-string)))
(setq files (org-agenda-files nil 'ifmode)
rtnall nil)
(while (setq file (pop files))
(catch 'nextfile
(org-check-agenda-file file)
(setq buffer (if (file-exists-p file)
(org-get-agenda-file-buffer file)
(error "No such file %s" file)))
(if (not buffer)
;; If file does not exist, error message to agenda
(setq rtn (list
(format "ORG-AGENDA-ERROR: No such org-file %s" file))
rtnall (append rtnall rtn))
(with-current-buffer buffer
(unless (derived-mode-p 'org-mode)
(error "Agenda file %s is not in Org mode" file))
(save-excursion
(save-restriction
(if (eq buffer org-agenda-restrict)
(narrow-to-region org-agenda-restrict-begin
org-agenda-restrict-end)
(widen))
(setq rtn (org-scan-tags 'agenda
matcher
org--matcher-tags-todo-only))
(setq rtnall (append rtnall rtn))))))))
(org-agenda--insert-overriding-header
(with-temp-buffer
(insert "Headlines with TAGS match: ")
(add-text-properties (point-min) (1- (point))
(list 'face 'org-agenda-structure
'short-heading
(concat "Match: " match)))
(setq pos (point))
(insert match "\n")
(add-text-properties pos (1- (point)) (list 'face 'org-agenda-structure-filter))
(setq pos (point))
(unless org-agenda-multi
(insert (substitute-command-keys
"Press \
\\`\\[universal-argument] \\[org-agenda-redo]' \
to search again\n")))
(add-text-properties pos (1- (point))
(list 'face 'org-agenda-structure-secondary))
(buffer-string)))
(org-agenda-mark-header-line (point-min))
(when rtnall
(insert (org-agenda-finalize-entries rtnall 'tags) "\n"))
(goto-char (point-min))
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
(add-text-properties
(point-min) (point-max)
`(org-agenda-type tags
org-last-args (,org--matcher-tags-todo-only ,match)
org-redo-cmd ,org-agenda-redo-command
org-series-cmd ,org-cmd))
(org-agenda-finalize)
(setq buffer-read-only t))))
;;; Agenda Finding stuck projects
(defvar org-agenda-skip-regexp nil
"Regular expression used in skipping subtrees for the agenda.
This is basically a temporary global variable that can be set and then
used by user-defined selections using `org-agenda-skip-function'.")
(defvar org-agenda-overriding-header nil
"When set during agenda, todo and tags searches it replaces the header.
If an empty string, no header will be inserted. If any other
string, it will be inserted as a header. If a function, insert
the string returned by the function as a header. If nil, a
header will be generated automatically according to the command.
This variable should not be set directly, but custom commands can
bind it in the options section.")
(defun org-agenda-skip-entry-if (&rest conditions)
"Skip entry if any of CONDITIONS is true.
See `org-agenda-skip-if' for details about CONDITIONS.
This function can be put into `org-agenda-skip-function' for the
duration of a command."
(org-agenda-skip-if nil conditions))
(defun org-agenda-skip-subtree-if (&rest conditions)
"Skip subtree if any of CONDITIONS is true.
See `org-agenda-skip-if' for details about CONDITIONS.
This function can be put into `org-agenda-skip-function' for the
duration of a command."
(org-agenda-skip-if t conditions))
(defun org-agenda-skip-if (subtree conditions)
"Check current entity for CONDITIONS.
If SUBTREE is non-nil, the entire subtree is checked. Otherwise, only
the entry (i.e. the text before the next heading) is checked.
CONDITIONS is a list of symbols, boolean OR is used to combine the results
from different tests. Valid conditions are:
scheduled Check if there is a scheduled cookie
notscheduled Check if there is no scheduled cookie
deadline Check if there is a deadline
notdeadline Check if there is no deadline
timestamp Check if there is a timestamp (also deadline or scheduled)
nottimestamp Check if there is no timestamp (also deadline or scheduled)
regexp Check if regexp matches
notregexp Check if regexp does not match.
todo Check if TODO keyword matches
nottodo Check if TODO keyword does not match
The regexp is taken from the conditions list, and must come right
after the `regexp' or `notregexp' element.
`todo' and `nottodo' accept as an argument a list of todo
keywords, which may include \"*\" to match any todo keyword.
(org-agenda-skip-entry-if \\='todo \\='(\"TODO\" \"WAITING\"))
would skip all entries with \"TODO\" or \"WAITING\" keywords.
Instead of a list, a keyword class may be given. For example:
(org-agenda-skip-entry-if \\='nottodo \\='done)
would skip entries that haven't been marked with any of \"DONE\"
keywords. Possible classes are: `todo', `done', `any'.
If any of these conditions is met, this function returns the end point of
the entity, causing the search to continue from there. This is a function
that can be put into `org-agenda-skip-function' for the duration of a command."
(org-back-to-heading t)
(let* (;; (beg (point))
(end (if subtree (save-excursion (org-end-of-subtree t) (point))
(org-entry-end-position)))
(planning-end (if subtree end (line-end-position 2)))
m)
(and
(or (and (memq 'scheduled conditions)
(re-search-forward org-scheduled-time-regexp planning-end t))
(and (memq 'notscheduled conditions)
(not
(save-excursion
(re-search-forward org-scheduled-time-regexp planning-end t))))
(and (memq 'deadline conditions)
(re-search-forward org-deadline-time-regexp planning-end t))
(and (memq 'notdeadline conditions)
(not
(save-excursion
(re-search-forward org-deadline-time-regexp planning-end t))))
(and (memq 'timestamp conditions)
(re-search-forward org-ts-regexp end t))
(and (memq 'nottimestamp conditions)
(not (save-excursion (re-search-forward org-ts-regexp end t))))
(and (setq m (memq 'regexp conditions))
(stringp (nth 1 m))
(re-search-forward (nth 1 m) end t))
(and (setq m (memq 'notregexp conditions))
(stringp (nth 1 m))
(not (save-excursion (re-search-forward (nth 1 m) end t))))
(and (or
(setq m (memq 'nottodo conditions))
(setq m (memq 'todo-unblocked conditions))
(setq m (memq 'nottodo-unblocked conditions))
(setq m (memq 'todo conditions)))
(org-agenda-skip-if-todo m end)))
end)))
(defun org-agenda-skip-if-todo (args end)
"Helper function for `org-agenda-skip-if', do not use it directly.
ARGS is a list with first element either `todo', `nottodo',
`todo-unblocked' or `nottodo-unblocked'. The remainder is either
a list of TODO keywords, or a state symbol `todo' or `done' or
`any'."
(let ((todo-re
(concat "^\\*+[ \t]+"
(regexp-opt
(pcase args
(`(,_ todo)
(org-delete-all org-done-keywords
(copy-sequence org-todo-keywords-1)))
(`(,_ done) org-done-keywords)
(`(,_ any) org-todo-keywords-1)
(`(,_ ,(pred atom))
(error "Invalid TODO class or type: %S" args))
(`(,_ ,(pred (member "*"))) org-todo-keywords-1)
(`(,_ ,todo-list) todo-list))
'words))))
(pcase args
(`(todo . ,_)
(let (case-fold-search) (re-search-forward todo-re end t)))
(`(nottodo . ,_)
(not (let (case-fold-search) (re-search-forward todo-re end t))))
(`(todo-unblocked . ,_)
(catch :unblocked
(while (let (case-fold-search) (re-search-forward todo-re end t))
(when (org-entry-blocked-p) (throw :unblocked t)))
nil))
(`(nottodo-unblocked . ,_)
(catch :unblocked
(while (let (case-fold-search) (re-search-forward todo-re end t))
(when (org-entry-blocked-p) (throw :unblocked nil)))
t))
(`(,type . ,_) (error "Unknown TODO skip type: %S" type)))))
;;;###autoload
(defun org-agenda-list-stuck-projects (&rest _ignore)
"Create agenda view for projects that are stuck.
Stuck projects are project that have no next actions. For the definitions
of what a project is and how to check if it stuck, customize the variable
`org-stuck-projects'."
(interactive)
(let* ((org-agenda-overriding-header
(or org-agenda-overriding-header "List of stuck projects: "))
(matcher (nth 0 org-stuck-projects))
(todo (nth 1 org-stuck-projects))
(tags (nth 2 org-stuck-projects))
(gen-re (org-string-nw-p (nth 3 org-stuck-projects)))
(todo-wds
(if (not (member "*" todo)) todo
(org-agenda-prepare-buffers (org-agenda-files nil 'ifmode))
(org-delete-all org-done-keywords-for-agenda
(copy-sequence org-todo-keywords-for-agenda))))
(todo-re (and todo
(format "^\\*+[ \t]+\\(%s\\)\\(?:[ \t]\\|$\\)"
(mapconcat #'regexp-quote todo-wds "\\|"))))
(tags-re (cond ((null tags) nil)
((member "*" tags) org-tag-line-re)
(tags
(let ((other-tags (format "\\(?:%s:\\)*" org-tag-re)))
(concat org-outline-regexp-bol
".*?[ \t]:"
other-tags
(regexp-opt tags t)
":" other-tags "[ \t]*$")))
(t nil)))
(re-list (delq nil (list todo-re tags-re gen-re)))
(skip-re
(if (null re-list)
(error "Missing information to identify unstuck projects")
(mapconcat #'identity re-list "\\|")))
(org-agenda-skip-function
;; Skip entry if `org-agenda-skip-regexp' matches anywhere
;; in the subtree.
(lambda ()
(and (save-excursion
(let ((case-fold-search nil))
(re-search-forward
skip-re (save-excursion (org-end-of-subtree t)) t)))
(progn (outline-next-heading) (point))))))
(org-tags-view nil matcher)
(setq org-agenda-buffer-name (buffer-name))
(with-current-buffer org-agenda-buffer-name
(setq org-agenda-redo-command
`(org-agenda-list-stuck-projects ,current-prefix-arg))
(let ((inhibit-read-only t))
(add-text-properties
(point-min) (point-max)
`(org-redo-cmd ,org-agenda-redo-command))))))
;;; Diary integration
(defvar org-disable-agenda-to-diary nil) ;Dynamically-scoped param.
(defvar diary-list-entries-hook)
(defvar diary-time-regexp)
(defvar diary-modify-entry-list-string-function)
(defvar diary-file-name-prefix)
(defvar diary-display-function)
(defun org-get-entries-from-diary (date)
"Get the (Emacs Calendar) diary entries for DATE."
(require 'diary-lib)
(declare-function diary-fancy-display "diary-lib" ())
(let* ((diary-fancy-buffer "*temporary-fancy-diary-buffer*")
(diary-display-function #'diary-fancy-display)
(pop-up-frames nil)
(diary-list-entries-hook
(cons 'org-diary-default-entry diary-list-entries-hook))
(diary-file-name-prefix nil) ; turn this feature off
(diary-modify-entry-list-string-function
#'org-modify-diary-entry-string)
(diary-time-regexp (concat "^" diary-time-regexp))
entries
(org-disable-agenda-to-diary t))
(save-excursion
(save-window-excursion
(diary-list-entries date 1)))
(if (not (get-buffer diary-fancy-buffer))
(setq entries nil)
(with-current-buffer diary-fancy-buffer
(setq buffer-read-only nil)
(if (zerop (buffer-size))
;; No entries
(setq entries nil)
;; Omit the date and other unnecessary stuff
(org-agenda-cleanup-fancy-diary)
;; Add prefix to each line and extend the text properties
(if (zerop (buffer-size))
(setq entries nil)
(setq entries (buffer-substring (point-min) (- (point-max) 1)))
(setq entries
(with-temp-buffer
(insert entries) (goto-char (point-min))
(while (re-search-forward "\n[ \t]+\\(.+\\)$" nil t)
(unless (save-match-data (string-match diary-time-regexp (match-string 1)))
(replace-match (concat "; " (match-string 1)))))
(buffer-string)))))
(set-buffer-modified-p nil)
(kill-buffer diary-fancy-buffer)))
(when entries
(setq entries (org-split-string entries "\n"))
(setq entries
(mapcar
(lambda (x)
(setq x (org-agenda-format-item "" x nil "Diary" nil 'time))
;; Extend the text properties to the beginning of the line
(org-add-props x (text-properties-at (1- (length x)) x)
'type "diary" 'date date 'face 'org-agenda-diary))
entries)))))
(defvar org-agenda-cleanup-fancy-diary-hook nil
"Hook run when the fancy diary buffer is cleaned up.")
(defun org-agenda-cleanup-fancy-diary ()
"Remove unwanted stuff in buffer created by `diary-fancy-display'.
This gets rid of the date, the underline under the date, and the
dummy entry installed by Org mode to ensure non-empty diary for
each date. It also removes lines that contain only whitespace."
(goto-char (point-min))
(if (looking-at ".*?:[ \t]*")
(progn
(replace-match "")
(re-search-forward "\n=+$" nil t)
(replace-match "")
(while (re-search-backward "^ +\n?" nil t) (replace-match "")))
(re-search-forward "\n=+$" nil t)
(delete-region (point-min) (min (point-max) (1+ (match-end 0)))))
(goto-char (point-min))
(while (re-search-forward "^ +\n" nil t)
(replace-match ""))
(goto-char (point-min))
(when (re-search-forward "^Org mode dummy\n?" nil t)
(replace-match ""))
(run-hooks 'org-agenda-cleanup-fancy-diary-hook))
(defun org-modify-diary-entry-string (string)
"Add text properties to string, allowing Org to act on it."
(org-add-props string nil
'mouse-face 'highlight
'help-echo (if buffer-file-name
(format "mouse-2 or RET jump to diary file %s"
(abbreviate-file-name buffer-file-name))
"")
'org-agenda-diary-link t
'org-marker (org-agenda-new-marker (line-beginning-position))))
(defun org-diary-default-entry ()
"Add a dummy entry to the diary.
Needed to avoid empty dates which mess up holiday display."
;; Catch the error if dealing with the new add-to-diary-alist
(when org-disable-agenda-to-diary
(diary-add-to-list original-date "Org mode dummy" "")))
(defvar org-diary-last-run-time nil)
;;;###autoload
(defun org-diary (&rest args)
"Return diary information from org files.
This function can be used in a \"sexp\" diary entry in the Emacs calendar.
It accesses org files and extracts information from those files to be
listed in the diary. The function accepts arguments specifying what
items should be listed. For a list of arguments allowed here, see the
variable `org-agenda-entry-types'.
The call in the diary file should look like this:
&%%(org-diary) ~/path/to/some/orgfile.org
Use a separate line for each org file to check. Or, if you omit the file name,
all files listed in `org-agenda-files' will be checked automatically:
&%%(org-diary)
If you don't give any arguments (as in the example above), the default value
of `org-agenda-entry-types' is used: (:deadline :scheduled :timestamp :sexp).
So the example above may also be written as
&%%(org-diary :deadline :timestamp :sexp :scheduled)
The function expects the lisp variables `entry' and `date' to be provided
by the caller, because this is how the calendar works. Don't use this
function from a program - use `org-agenda-get-day-entries' instead."
(with-no-warnings (defvar date) (defvar entry))
(when (> (- (float-time)
org-agenda-last-marker-time)
5)
;; I am not sure if this works with sticky agendas, because the marker
;; list is then no longer a global variable.
(org-agenda-reset-markers))
(org-compile-prefix-format 'agenda)
(org-set-sorting-strategy 'agenda)
(setq args (or args org-agenda-entry-types))
(let* ((files (if (and entry (stringp entry) (string-match "\\S-" entry))
(list entry)
(org-agenda-files t)))
(time (float-time))
file rtn results)
(when (or (not org-diary-last-run-time)
(> (- time
org-diary-last-run-time)
3))
(org-agenda-prepare-buffers files))
(setq org-diary-last-run-time time)
;; If this is called during org-agenda, don't return any entries to
;; the calendar. Org Agenda will list these entries itself.
(when org-disable-agenda-to-diary (setq files nil))
(while (setq file (pop files))
(setq rtn (apply #'org-agenda-get-day-entries file date args))
(setq results (append results rtn)))
(when results
(setq results
(mapcar (lambda (i) (replace-regexp-in-string
org-link-bracket-re "\\2" i))
results))
(concat (org-agenda-finalize-entries results) "\n"))))
;;; Agenda entry finders
(defun org-agenda--timestamp-to-absolute (&rest args)
"Call `org-time-string-to-absolute' with ARGS.
However, throw `:skip' whenever an error is raised."
(condition-case e
(apply #'org-time-string-to-absolute args)
(org-diary-sexp-no-match (throw :skip nil))
(error
(message "%s; Skipping entry" (error-message-string e))
(throw :skip nil))))
(defun org-agenda-get-day-entries (file date &rest args)
"Does the work for `org-diary' and `org-agenda'.
FILE is the path to a file to be checked for entries. DATE is date like
the one returned by `calendar-current-date'. ARGS are symbols indicating
which kind of entries should be extracted. For details about these, see
the documentation of `org-diary'."
(let* ((org-startup-folded nil)
(org-startup-align-all-tables nil)
(buffer (if (file-exists-p file) (org-get-agenda-file-buffer file)
(error "No such file %s" file))))
(if (not buffer)
;; If file does not exist, signal it in diary nonetheless.
(list (format "ORG-AGENDA-ERROR: No such org-file %s" file))
(with-current-buffer buffer
(unless (derived-mode-p 'org-mode)
(error "Agenda file %s is not in Org mode" file))
(setq org-agenda-buffer (or org-agenda-buffer buffer))
(setf org-agenda-current-date date)
(save-excursion
(save-restriction
(if (eq buffer org-agenda-restrict)
(narrow-to-region org-agenda-restrict-begin
org-agenda-restrict-end)
(widen))
;; Rationalize ARGS. Also make sure `:deadline' comes
;; first in order to populate DEADLINES before passing it.
;;
;; We use `delq' since `org-uniquify' duplicates ARGS,
;; guarding us from modifying `org-agenda-entry-types'.
(setf args (org-uniquify (or args org-agenda-entry-types)))
(when (and (memq :scheduled args) (memq :scheduled* args))
(setf args (delq :scheduled* args)))
(cond
((memq :deadline args)
(setf args (cons :deadline
(delq :deadline (delq :deadline* args)))))
((memq :deadline* args)
(setf args (cons :deadline* (delq :deadline* args)))))
;; Collect list of headlines. Return them flattened.
(let ((case-fold-search nil) results deadlines)
(org-dlet
((date date))
(dolist (arg args (apply #'nconc (nreverse results)))
(pcase arg
((and :todo (guard (org-agenda-today-p date)))
(push (org-agenda-get-todos) results))
(:timestamp
(push (org-agenda-get-blocks) results)
(push (org-agenda-get-timestamps deadlines) results))
(:sexp
(push (org-agenda-get-sexps) results))
(:scheduled
(push (org-agenda-get-scheduled deadlines) results))
(:scheduled*
(push (org-agenda-get-scheduled deadlines t) results))
(:closed
(push (org-agenda-get-progress) results))
(:deadline
(setf deadlines (org-agenda-get-deadlines))
(push deadlines results))
(:deadline*
(setf deadlines (org-agenda-get-deadlines t))
(push deadlines results))))))))))))
(defsubst org-em (x y list)
"Is X or Y a member of LIST?"
(or (memq x list) (memq y list)))
(defvar org-heading-keyword-regexp-format) ; defined in org.el
(defvar org-agenda-sorting-strategy-selected nil)
(defun org-agenda-entry-get-agenda-timestamp (epom)
"Retrieve timestamp information for sorting agenda views.
Given an element, point, or marker EPOM, returns a cons cell of the
timestamp and the timestamp type relevant for the sorting strategy in
`org-agenda-sorting-strategy-selected'."
(let (ts ts-date-type)
(save-match-data
(cond ((org-em 'scheduled-up 'scheduled-down
org-agenda-sorting-strategy-selected)
(setq ts (org-entry-get epom "SCHEDULED")
ts-date-type " scheduled"))
((org-em 'deadline-up 'deadline-down
org-agenda-sorting-strategy-selected)
(setq ts (org-entry-get epom "DEADLINE")
ts-date-type " deadline"))
((org-em 'ts-up 'ts-down
org-agenda-sorting-strategy-selected)
(setq ts (org-entry-get epom "TIMESTAMP")
ts-date-type " timestamp"))
((org-em 'tsia-up 'tsia-down
org-agenda-sorting-strategy-selected)
(setq ts (org-entry-get epom "TIMESTAMP_IA")
ts-date-type " timestamp_ia"))
((org-em 'timestamp-up 'timestamp-down
org-agenda-sorting-strategy-selected)
(setq ts (or (org-entry-get epom "SCHEDULED")
(org-entry-get epom "DEADLINE")
(org-entry-get epom "TIMESTAMP")
(org-entry-get epom "TIMESTAMP_IA"))
ts-date-type ""))
(t (setq ts-date-type "")))
(cons (when ts (ignore-errors (org-time-string-to-absolute ts)))
ts-date-type))))
(defun org-agenda-get-todos ()
"Return the TODO information for agenda display."
(let* ((props (list 'face nil
'done-face 'org-agenda-done
'org-not-done-regexp org-not-done-regexp
'org-todo-regexp org-todo-regexp
'org-complex-heading-regexp org-complex-heading-regexp
'mouse-face 'highlight
'help-echo
(format "mouse-2 or RET jump to org file %s"
(abbreviate-file-name buffer-file-name))))
(case-fold-search nil)
(regexp (format org-heading-keyword-regexp-format
(cond
((and org-select-this-todo-keyword
(equal org-select-this-todo-keyword "*"))
org-todo-regexp)
(org-select-this-todo-keyword
(concat "\\("
(mapconcat #'regexp-quote
(org-split-string
org-select-this-todo-keyword
"|")
"\\|")
"\\)"))
(t org-not-done-regexp))))
marker priority urgency category level tags todo-state
ts-date ts-date-type ts-date-pair
ee txt beg end inherited-tags todo-state-end-pos
effort effort-minutes)
(goto-char (point-min))
(while (re-search-forward regexp nil t)
(catch :skip
(save-match-data
(forward-line 0)
(org-agenda-skip)
(setq beg (point) end (save-excursion (outline-next-heading) (point)))
(unless (and (setq todo-state (org-get-todo-state))
(setq todo-state-end-pos (match-end 2)))
(goto-char end)
(throw :skip nil))
(when (org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item end)
(goto-char (1+ beg))
(or org-agenda-todo-list-sublevels (org-end-of-subtree 'invisible))
(throw :skip nil)))
(goto-char (match-beginning 2))
(setq marker (org-agenda-new-marker (match-beginning 0))
category (save-match-data (org-get-category))
effort (save-match-data (or (get-text-property (point) 'effort)
(org-entry-get (point) org-effort-property)))
effort-minutes (when effort (save-match-data (org-duration-to-minutes effort)))
ts-date-pair (org-agenda-entry-get-agenda-timestamp (point))
ts-date (car ts-date-pair)
ts-date-type (cdr ts-date-pair)
txt (org-trim (buffer-substring (match-beginning 2) (match-end 0)))
inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
(memq 'todo org-agenda-show-inherited-tags))
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'todo org-agenda-use-tag-inheritance))))
tags (org-get-tags nil (not inherited-tags))
level (make-string (org-reduced-level (org-outline-level)) ? )
txt (org-agenda-format-item
""
(org-add-props txt nil
'effort effort
'effort-minutes effort-minutes)
level category tags t)
urgency (1+ (org-get-priority txt))
priority (org-get-priority txt))
(org-add-props txt props
'org-marker marker 'org-hd-marker marker
'priority priority
'urgency urgency
'effort effort 'effort-minutes effort-minutes
'level level
'ts-date ts-date
'type (concat "todo" ts-date-type) 'todo-state todo-state)
(push txt ee)
(if org-agenda-todo-list-sublevels
(goto-char todo-state-end-pos)
(org-end-of-subtree 'invisible))))
(nreverse ee)))
(defun org-agenda-todo-custom-ignore-p (time n)
"Check whether timestamp is farther away than n number of days.
This function is invoked if `org-agenda-todo-ignore-deadlines',
`org-agenda-todo-ignore-scheduled' or
`org-agenda-todo-ignore-timestamp' is set to an integer."
(let ((days (org-timestamp-to-now
time org-agenda-todo-ignore-time-comparison-use-seconds)))
(if (>= n 0)
(>= days n)
(<= days n))))
;;;###autoload
(defun org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item
(&optional end)
"Do we have a reason to ignore this TODO entry because it has a time stamp?"
(when (or org-agenda-todo-ignore-with-date
org-agenda-todo-ignore-scheduled
org-agenda-todo-ignore-deadlines
org-agenda-todo-ignore-timestamp)
(setq end (or end (save-excursion (outline-next-heading) (point))))
(save-excursion
(or (and org-agenda-todo-ignore-with-date
(re-search-forward org-ts-regexp end t))
(and org-agenda-todo-ignore-scheduled
(re-search-forward org-scheduled-time-regexp end t)
(cond
((eq org-agenda-todo-ignore-scheduled 'future)
(> (org-timestamp-to-now
(match-string 1) org-agenda-todo-ignore-time-comparison-use-seconds)
0))
((eq org-agenda-todo-ignore-scheduled 'past)
(<= (org-timestamp-to-now
(match-string 1) org-agenda-todo-ignore-time-comparison-use-seconds)
0))
((numberp org-agenda-todo-ignore-scheduled)
(org-agenda-todo-custom-ignore-p
(match-string 1) org-agenda-todo-ignore-scheduled))
(t)))
(and org-agenda-todo-ignore-deadlines
(re-search-forward org-deadline-time-regexp end t)
(cond
((eq org-agenda-todo-ignore-deadlines 'all) t)
((eq org-agenda-todo-ignore-deadlines 'far)
(not (org-deadline-close-p (match-string 1))))
((eq org-agenda-todo-ignore-deadlines 'future)
(> (org-timestamp-to-now
(match-string 1) org-agenda-todo-ignore-time-comparison-use-seconds)
0))
((eq org-agenda-todo-ignore-deadlines 'past)
(<= (org-timestamp-to-now
(match-string 1) org-agenda-todo-ignore-time-comparison-use-seconds)
0))
((numberp org-agenda-todo-ignore-deadlines)
(org-agenda-todo-custom-ignore-p
(match-string 1) org-agenda-todo-ignore-deadlines))
(t (org-deadline-close-p (match-string 1)))))
(and org-agenda-todo-ignore-timestamp
(let ((buffer (current-buffer))
(regexp
(concat
org-scheduled-time-regexp "\\|" org-deadline-time-regexp))
(start (point)))
;; Copy current buffer into a temporary one
(with-temp-buffer
(insert-buffer-substring buffer start end)
(goto-char (point-min))
;; Delete SCHEDULED and DEADLINE items
(while (re-search-forward regexp end t)
(delete-region (match-beginning 0) (match-end 0)))
(goto-char (point-min))
;; No search for timestamp left
(when (re-search-forward org-ts-regexp nil t)
(cond
((eq org-agenda-todo-ignore-timestamp 'future)
(> (org-timestamp-to-now
(match-string 1) org-agenda-todo-ignore-time-comparison-use-seconds)
0))
((eq org-agenda-todo-ignore-timestamp 'past)
(<= (org-timestamp-to-now
(match-string 1) org-agenda-todo-ignore-time-comparison-use-seconds)
0))
((numberp org-agenda-todo-ignore-timestamp)
(org-agenda-todo-custom-ignore-p
(match-string 1) org-agenda-todo-ignore-timestamp))
(t))))))))))
(defun org-agenda-get-timestamps (&optional deadlines)
"Return the date stamp information for agenda display.
Optional argument DEADLINES is a list of deadline items to be
displayed in agenda view."
(with-no-warnings (defvar date))
(let* ((props (list 'face 'org-agenda-calendar-event
'org-not-done-regexp org-not-done-regexp
'org-todo-regexp org-todo-regexp
'org-complex-heading-regexp org-complex-heading-regexp
'mouse-face 'highlight
'help-echo
(format "mouse-2 or RET jump to Org file %s"
(abbreviate-file-name buffer-file-name))))
(current (calendar-absolute-from-gregorian date))
(today (org-today))
(deadline-position-alist
(mapcar (lambda (d)
(let ((m (get-text-property 0 'org-hd-marker d)))
(and m (marker-position m))))
deadlines))
;; Match timestamps set to current date, timestamps with
;; a repeater, and S-exp timestamps.
(regexp
(concat
(if org-agenda-include-inactive-timestamps "[[<]" "<")
(regexp-quote
(format-time-string
"%Y-%m-%d" ; We do not use `org-time-stamp-format' to not demand day name in timestamps.
(org-encode-time ; DATE bound by calendar
0 0 0 (nth 1 date) (car date) (nth 2 date))))
"\\|\\(<[0-9]+-[0-9]+-[0-9]+[^>\n]+?\\+[0-9]+[hdwmy]>\\)"
"\\|\\(<%%\\(([^>\n]+)\\)\\([^\n>]*\\)>\\)"))
timestamp-items)
(goto-char (point-min))
(while (re-search-forward regexp nil t)
;; Skip date ranges, scheduled and deadlines, which are handled
;; specially. Also skip timestamps before first headline as
;; there would be no entry to add to the agenda. Eventually,
;; ignore clock entries.
(catch :skip
(save-match-data
(when (or (org-at-date-range-p t)
(org-at-planning-p)
(org-before-first-heading-p)
(and org-agenda-include-inactive-timestamps
(org-at-clock-log-p))
(not (org-at-timestamp-p 'agenda)))
(throw :skip nil))
(org-agenda-skip (org-element-at-point)))
(let* ((pos (match-beginning 0))
(repeat (match-string 1))
(sexp-entry (match-string 3))
(timestamp (if (or repeat sexp-entry) (match-string 0)
(save-excursion
(goto-char pos)
(looking-at org-ts-regexp-both)
(match-string 0))))
(todo-state (org-get-todo-state))
(warntime (org-entry-get (point) "APPT_WARNTIME" 'selective))
(done? (member todo-state org-done-keywords)))
;; Possibly skip done tasks.
(when (and done? org-agenda-skip-timestamp-if-done)
(throw :skip t))
;; S-exp entry doesn't match current day: skip it.
(when (and sexp-entry (not (org-diary-sexp-entry sexp-entry "" date)))
(throw :skip nil))
(when repeat
(let* ((past
;; A repeating time stamp is shown at its base
;; date and every repeated date up to TODAY. If
;; `org-agenda-prefer-last-repeat' is non-nil,
;; however, only the last repeat before today
;; (inclusive) is shown.
(org-agenda--timestamp-to-absolute
repeat
(if (or (> current today)
(eq org-agenda-prefer-last-repeat t)
(member todo-state org-agenda-prefer-last-repeat))
today
current)
'past (current-buffer) pos))
(future
;; Display every repeated date past TODAY
;; (exclusive) unless
;; `org-agenda-show-future-repeats' is nil. If
;; this variable is set to `next', only display
;; the first repeated date after TODAY
;; (exclusive).
(cond
((<= current today) past)
((not org-agenda-show-future-repeats) past)
(t
(let ((base (if (eq org-agenda-show-future-repeats 'next)
(1+ today)
current)))
(org-agenda--timestamp-to-absolute
repeat base 'future (current-buffer) pos))))))
(when (and (/= current past) (/= current future))
(throw :skip nil))))
(save-excursion
(re-search-backward org-outline-regexp-bol nil t)
;; Possibly skip timestamp when a deadline is set.
(when (and org-agenda-skip-timestamp-if-deadline-is-shown
(assq (point) deadline-position-alist))
(throw :skip nil))
(let* ((category (org-get-category pos))
(effort (org-entry-get pos org-effort-property))
(effort-minutes (when effort (save-match-data (org-duration-to-minutes effort))))
(inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (consp org-agenda-show-inherited-tags)
(memq 'agenda org-agenda-show-inherited-tags))
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda
org-agenda-use-tag-inheritance)))))
(tags (org-get-tags nil (not inherited-tags)))
(level (make-string (org-reduced-level (org-outline-level))
?\s))
(head (and (looking-at "\\*+[ \t]+\\(.*\\)")
(match-string 1)))
(inactive? (= (char-after pos) ?\[))
(habit? (and (fboundp 'org-is-habit-p) (org-is-habit-p)))
(item
(org-agenda-format-item
(and inactive? org-agenda-inactive-leader)
(org-add-props head nil
'effort effort
'effort-minutes effort-minutes)
level category tags timestamp org-ts-regexp habit?)))
(org-add-props item props
'urgency (if habit?
(org-habit-get-urgency (org-habit-parse-todo))
(org-get-priority item))
'priority (org-get-priority item)
'org-marker (org-agenda-new-marker pos)
'org-hd-marker (org-agenda-new-marker)
'date date
'level level
'effort effort 'effort-minutes effort-minutes
'ts-date (if repeat (org-agenda--timestamp-to-absolute repeat)
current)
'todo-state todo-state
'warntime warntime
'type "timestamp")
(push item timestamp-items))))
(when org-agenda-skip-additional-timestamps-same-entry
(outline-next-heading))))
(nreverse timestamp-items)))
(defun org-agenda-get-sexps ()
"Return the sexp information for agenda display."
(require 'diary-lib)
(with-no-warnings (defvar date) (defvar entry))
(let* ((props (list 'face 'org-agenda-calendar-sexp
'mouse-face 'highlight
'help-echo
(format "mouse-2 or RET jump to org file %s"
(abbreviate-file-name buffer-file-name))))
(regexp "^&?%%(")
;; FIXME: Is this `entry' binding intended to be dynamic,
;; so as to "hide" any current binding for it?
marker category extra level ee txt tags entry
result beg b sexp sexp-entry todo-state warntime inherited-tags
effort effort-minutes)
(goto-char (point-min))
(while (re-search-forward regexp nil t)
(catch :skip
;; We do not run `org-agenda-skip' right away because every single sexp
;; in the buffer is matched here, unlike day-specific search
;; in ordinary timestamps. Most of the sexps will not match
;; the agenda day and it is quicker to run `org-agenda-skip' only for
;; matching sexps later on.
(setq beg (match-beginning 0))
(goto-char (1- (match-end 0)))
(setq b (point))
(forward-sexp 1)
(setq sexp (buffer-substring b (point)))
(setq sexp-entry (if (looking-at "[ \t]*\\(\\S-.*\\)")
(buffer-substring
(match-beginning 1)
(save-excursion
(goto-char (match-end 1))
(skip-chars-backward "[:blank:]")
(point)))
""))
(setq result (org-diary-sexp-entry sexp sexp-entry date))
(when result
;; Only check if entry should be skipped on matching sexps.
(org-agenda-skip (org-element-at-point))
(setq marker (org-agenda-new-marker beg)
level (make-string (org-reduced-level (org-outline-level)) ? )
category (org-get-category beg)
effort (save-match-data (or (get-text-property (point) 'effort)
(org-entry-get (point) org-effort-property)))
inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
(memq 'agenda org-agenda-show-inherited-tags))
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda org-agenda-use-tag-inheritance))))
tags (org-get-tags nil (not inherited-tags))
todo-state (org-get-todo-state)
warntime (org-entry-get (point) "APPT_WARNTIME" 'selective)
extra nil)
(setq effort-minutes (when effort (save-match-data (org-duration-to-minutes effort))))
(dolist (r (if (stringp result)
(list result)
result)) ;; we expect a list here
(when (and org-agenda-diary-sexp-prefix
(string-match org-agenda-diary-sexp-prefix r))
(setq extra (match-string 0 r)
r (replace-match "" nil nil r)))
(if (string-match "\\S-" r)
(setq txt r)
(setq txt "SEXP entry returned empty string"))
(setq txt (org-agenda-format-item extra
(org-add-props txt nil
'effort effort
'effort-minutes effort-minutes)
level category tags 'time))
(org-add-props txt props 'org-marker marker
'date date 'todo-state todo-state
'effort effort 'effort-minutes effort-minutes
'level level 'type "sexp" 'warntime warntime)
(push txt ee)))))
(nreverse ee)))
;; Calendar sanity: define some functions that are independent of
;; `calendar-date-style'.
(defun org-anniversary (year month day &optional mark)
"Like `diary-anniversary', but with fixed (ISO) order of arguments."
(with-no-warnings
(let ((calendar-date-style 'iso))
(diary-anniversary year month day mark))))
(defun org-cyclic (N year month day &optional mark)
"Like `diary-cyclic', but with fixed (ISO) order of arguments."
(with-no-warnings
(let ((calendar-date-style 'iso))
(diary-cyclic N year month day mark))))
(defun org-block (Y1 M1 D1 Y2 M2 D2 &optional mark)
"Like `diary-block', but with fixed (ISO) order of arguments."
(with-no-warnings
(let ((calendar-date-style 'iso))
(diary-block Y1 M1 D1 Y2 M2 D2 mark))))
(defun org-date (year month day &optional mark)
"Like `diary-date', but with fixed (ISO) order of arguments."
(with-no-warnings
(let ((calendar-date-style 'iso))
(diary-date year month day mark))))
;; Define the `org-class' function
(defun org-class (y1 m1 d1 y2 m2 d2 dayname &rest skip-weeks)
"Entry applies if date is between dates on DAYNAME, but skips SKIP-WEEKS.
DAYNAME is a number between 0 (Sunday) and 6 (Saturday).
SKIP-WEEKS is any number of ISO weeks in the block period for which the
item should be skipped. If any of the SKIP-WEEKS arguments is the symbol
`holidays', then any date that is known by the Emacs calendar to be a
holiday will also be skipped. If SKIP-WEEKS arguments are holiday strings,
then those holidays will be skipped."
(with-no-warnings (defvar date) (defvar entry))
(let* ((date1 (calendar-absolute-from-gregorian (list m1 d1 y1)))
(date2 (calendar-absolute-from-gregorian (list m2 d2 y2)))
(d (calendar-absolute-from-gregorian date))
(h (when skip-weeks (calendar-check-holidays date))))
(and
(<= date1 d)
(<= d date2)
(= (calendar-day-of-week date) dayname)
(or (not skip-weeks)
(progn
(require 'cal-iso)
(not (member (car (calendar-iso-from-absolute d)) skip-weeks))))
(not (or (and h (memq 'holidays skip-weeks))
(delq nil (mapcar (lambda(g) (member g skip-weeks)) h))))
entry)))
(defalias 'org-get-closed #'org-agenda-get-progress)
(defun org-agenda-get-progress ()
"Return the logged TODO entries for agenda display."
(with-no-warnings (defvar date))
(let* ((props (list 'mouse-face 'highlight
'org-not-done-regexp org-not-done-regexp
'org-todo-regexp org-todo-regexp
'org-complex-heading-regexp org-complex-heading-regexp
'help-echo
(format "mouse-2 or RET jump to org file %s"
(abbreviate-file-name buffer-file-name))))
(items (if (consp org-agenda-show-log-scoped)
org-agenda-show-log-scoped
(if (eq org-agenda-show-log-scoped 'clockcheck)
'(clock)
org-agenda-log-mode-items)))
(parts
(delq nil
(list
(when (memq 'closed items) (concat "\\<" org-closed-string))
(when (memq 'clock items) (concat "\\<" org-clock-string))
(when (memq 'state items)
(format "- +State \"%s\".*?" org-todo-regexp)))))
(parts-re (if parts (mapconcat #'identity parts "\\|")
(error "`org-agenda-log-mode-items' is empty")))
(regexp (concat
"\\(" parts-re "\\)"
" *\\["
(regexp-quote
(format-time-string
"%Y-%m-%d" ; We do not use `org-time-stamp-format' to not demand day name in timestamps.
(org-encode-time ; DATE bound by calendar
0 0 0 (nth 1 date) (car date) (nth 2 date))))))
(org-agenda-search-headline-for-time nil)
marker hdmarker priority category level tags closedp type
statep clockp state ee txt extra timestr rest clocked inherited-tags
effort effort-minutes)
(goto-char (point-min))
(while (re-search-forward regexp nil t)
(catch :skip
(org-agenda-skip)
(setq marker (org-agenda-new-marker (match-beginning 0))
closedp (equal (match-string 1) org-closed-string)
statep (equal (string-to-char (match-string 1)) ?-)
clockp (not (or closedp statep))
state (and statep (match-string 2))
category (save-match-data (org-get-category (match-beginning 0)))
timestr (buffer-substring (match-beginning 0) (line-end-position))
effort (save-match-data (or (get-text-property (point) 'effort)
(org-entry-get (point) org-effort-property))))
(setq effort-minutes (when effort (save-match-data (org-duration-to-minutes effort))))
(when (string-match org-ts-regexp-inactive timestr)
;; substring should only run to end of time stamp
(setq rest (substring timestr (match-end 0))
timestr (substring timestr 0 (match-end 0)))
(if (and (not closedp) (not statep)
(string-match "\\([0-9]\\{1,2\\}:[0-9]\\{2\\}\\)\\].*?\\([0-9]\\{1,2\\}:[0-9]\\{2\\}\\)"
rest))
(progn (setq timestr (concat (substring timestr 0 -1)
"-" (match-string 1 rest) "]"))
(setq clocked (match-string 2 rest)))
(setq clocked "-")))
(save-excursion
(setq extra
(cond
((not org-agenda-log-mode-add-notes) nil)
(statep
(and (looking-at ".*\\\\\n[ \t]*\\([^-\n \t].*?\\)[ \t]*$")
(match-string 1)))
(clockp
(and (looking-at ".*\n[ \t]*-[ \t]+\\([^-\n \t].*?\\)[ \t]*$")
(match-string 1)))))
(if (not (re-search-backward org-outline-regexp-bol nil t))
(throw :skip nil)
(goto-char (match-beginning 0))
(setq hdmarker (org-agenda-new-marker)
inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
(memq 'todo org-agenda-show-inherited-tags))
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'todo org-agenda-use-tag-inheritance))))
tags (org-get-tags nil (not inherited-tags))
level (make-string (org-reduced-level (org-outline-level)) ? ))
(looking-at "\\*+[ \t]+\\([^\r\n]+\\)")
(setq txt (match-string 1))
(when extra
(if (string-match "\\([ \t]+\\)\\(:[^ \n\t]*?:\\)[ \t]*$" txt)
(setq txt (concat (substring txt 0 (match-beginning 1))
" - " extra " " (match-string 2 txt)))
(setq txt (concat txt " - " extra))))
(setq txt (org-agenda-format-item
(cond
(closedp "Closed: ")
(statep (concat "State: (" state ")"))
(t (concat "Clocked: (" clocked ")")))
(org-add-props txt nil
'effort effort
'effort-minutes effort-minutes)
level category tags timestr)))
(setq type (cond (closedp "closed")
(statep "state")
(t "clock")))
(setq priority 100000)
(org-add-props txt props
'org-marker marker 'org-hd-marker hdmarker 'face 'org-agenda-done
'urgency priority 'priority priority 'level level
'effort effort 'effort-minutes effort-minutes
'type type 'date date
'undone-face 'org-warning 'done-face 'org-agenda-done)
(push txt ee))
(goto-char (line-end-position))))
(nreverse ee)))
(defun org-agenda-show-clocking-issues ()
"Add overlays, showing issues with clocking.
See also the user option `org-agenda-clock-consistency-checks'."
(interactive)
(let* ((pl org-agenda-clock-consistency-checks)
(re (concat "^[ \t]*"
org-clock-string
"[ \t]+"
"\\(\\[.*?\\]\\)" ; group 1 is first stamp
"\\(-\\{1,3\\}\\(\\[.*?\\]\\)\\)?")) ; group 3 is second
(tlstart 0.)
(tlend 0.)
(maxtime (org-duration-to-minutes
(or (plist-get pl :max-duration) "24:00")))
(mintime (org-duration-to-minutes
(or (plist-get pl :min-duration) 0)))
(maxgap (org-duration-to-minutes
;; default 30:00 means never complain
(or (plist-get pl :max-gap) "30:00")))
(gapok (mapcar #'org-duration-to-minutes
(plist-get pl :gap-ok-around)))
(def-face (or (plist-get pl :default-face)
'((:background "DarkRed") (:foreground "white"))))
issue face m te ts dt ov)
(goto-char (point-min))
(while (re-search-forward " Clocked: +(\\(?:-\\|\\([0-9]+:[0-9]+\\)\\))" nil t)
(setq issue nil face def-face)
(catch 'next
(setq m (org-get-at-bol 'org-marker)
te nil ts nil)
(unless (and m (markerp m))
(setq issue "No valid clock line") (throw 'next t))
(org-with-point-at m
(save-excursion
(goto-char (line-beginning-position))
(unless (looking-at re)
(error "No valid Clock line")
(throw 'next t))
(unless (match-end 3)
(setq issue
(format
"No end time: (%s)"
(org-duration-from-minutes
(floor
(- (float-time (org-current-time))
(float-time (org-time-string-to-time (match-string 1))))
60)))
face (or (plist-get pl :no-end-time-face) face))
(throw 'next t))
(setq ts (match-string 1)
te (match-string 3)
ts (float-time (org-time-string-to-time ts))
te (float-time (org-time-string-to-time te))
dt (- te ts))))
(cond
((> dt (* 60 maxtime))
;; a very long clocking chunk
(setq issue (format "Clocking interval is very long: %s"
(org-duration-from-minutes (floor dt 60)))
face (or (plist-get pl :long-face) face)))
((< dt (* 60 mintime))
;; a very short clocking chunk
(setq issue (format "Clocking interval is very short: %s"
(org-duration-from-minutes (floor dt 60)))
face (or (plist-get pl :short-face) face)))
((and (> tlend 0) (< ts tlend))
;; Two clock entries are overlapping
(setq issue (format "Clocking overlap: %d minutes"
(/ (- tlend ts) 60))
face (or (plist-get pl :overlap-face) face)))
((and (> tlend 0) (> ts (+ tlend (* 60 maxgap))))
;; There is a gap, lets see if we need to report it
(unless (org-agenda-check-clock-gap tlend ts gapok)
(setq issue (format "Clocking gap: %d minutes"
(/ (- ts tlend) 60))
face (or (plist-get pl :gap-face) face))))
(t nil)))
(setq tlend (or te tlend) tlstart (or ts tlstart))
(when issue
;; OK, there was some issue, add an overlay to show the issue
(setq ov (make-overlay (line-beginning-position) (line-end-position)))
(overlay-put ov 'before-string
(concat
(org-add-props
(format "%-43s" (concat " " issue))
nil
'face face)
"\n"))
(overlay-put ov 'evaporate t)))))
(defun org-agenda-check-clock-gap (t1 t2 ok-list)
"Check if gap T1 -> T2 contains one of the OK-LIST time-of-day values."
(catch 'exit
(unless ok-list
;; there are no OK times for gaps...
(throw 'exit nil))
(when (> (- (/ t2 36000) (/ t1 36000)) 24)
;; This is more than 24 hours, so it is OK.
;; because we have at least one OK time, that must be in the
;; 24 hour interval.
(throw 'exit t))
;; We have a shorter gap.
;; Now we have to get the minute of the day when these times are
(let* ((t1dec (decode-time t1))
(t2dec (decode-time t2))
;; compute the minute on the day
(min1 (+ (nth 1 t1dec) (* 60 (nth 2 t1dec))))
(min2 (+ (nth 1 t2dec) (* 60 (nth 2 t2dec)))))
(when (< min2 min1)
;; if min2 is smaller than min1, this means it is on the next day.
;; Wrap it to after midnight.
(setq min2 (+ min2 1440)))
;; Now check if any of the OK times is in the gap
(mapc (lambda (x)
;; Wrap the time to after midnight if necessary
(when (< x min1) (setq x (+ x 1440)))
;; Check if in interval
(and (<= min1 x) (>= min2 x) (throw 'exit t)))
ok-list)
;; Nope, this gap is not OK
nil)))
(defun org-agenda-get-deadlines (&optional with-hour)
"Return the deadline information for agenda display.
When WITH-HOUR is non-nil, only return deadlines with an hour
specification like [h]h:mm."
(with-no-warnings (defvar date))
(let* ((props (list 'mouse-face 'highlight
'org-not-done-regexp org-not-done-regexp
'org-todo-regexp org-todo-regexp
'org-complex-heading-regexp org-complex-heading-regexp
'help-echo
(format "mouse-2 or RET jump to org file %s"
(abbreviate-file-name buffer-file-name))))
(regexp (if with-hour
org-deadline-time-hour-regexp
org-deadline-time-regexp))
(today (org-today))
(today? (org-agenda-today-p date)) ; DATE bound by calendar.
(current (calendar-absolute-from-gregorian date))
deadline-items)
(org-element-cache-map
(lambda (el)
(when (and (org-element-property :deadline el)
;; Only consider active timestamp values.
(memq (org-element-property
:type
(org-element-property :deadline el))
'(diary active active-range))
(or (not with-hour)
(org-element-property
:hour-start
(org-element-property :deadline el))
(org-element-property
:hour-end
(org-element-property :deadline el))))
(goto-char (org-element-contents-begin el))
(catch :skip
(org-agenda-skip el)
(let* ((s (substring (org-element-property
:raw-value
(org-element-property :deadline el))
1 -1))
(pos (save-excursion
(goto-char (org-element-contents-begin el))
;; We intentionally leave NOERROR
;; argument in `re-search-forward' nil. If
;; the search fails here, something went
;; wrong and we are looking at
;; non-matching headline.
(re-search-forward regexp (line-end-position))
(1- (match-beginning 1))))
(todo-state (org-element-property :todo-keyword el))
(done? (eq 'done (org-element-property :todo-type el)))
(sexp? (eq 'diary
(org-element-property
:type (org-element-property :deadline el))))
;; DEADLINE is the deadline date for the entry. It is
;; either the base date or the last repeat, according
;; to `org-agenda-prefer-last-repeat'.
(deadline
(cond
(sexp? (org-agenda--timestamp-to-absolute s current))
((or (eq org-agenda-prefer-last-repeat t)
(member todo-state org-agenda-prefer-last-repeat))
(org-agenda--timestamp-to-absolute
s today 'past (current-buffer) pos))
(t (org-agenda--timestamp-to-absolute s))))
;; REPEAT is the future repeat closest from CURRENT,
;; according to `org-agenda-show-future-repeats'. If
;; the latter is nil, or if the time stamp has no
;; repeat part, default to DEADLINE.
(repeat
(cond
(sexp? deadline)
((<= current today) deadline)
((not org-agenda-show-future-repeats) deadline)
(t
(let ((base (if (eq org-agenda-show-future-repeats 'next)
(1+ today)
current)))
(org-agenda--timestamp-to-absolute
s base 'future (current-buffer) pos)))))
(diff (- deadline current))
(max-warning-days
(let ((scheduled
(and org-agenda-skip-deadline-prewarning-if-scheduled
(org-element-property
:raw-value
(org-element-property :scheduled el)))))
(cond
((not scheduled) most-positive-fixnum)
;; The current item has a scheduled date, so
;; evaluate its prewarning lead time.
((integerp org-agenda-skip-deadline-prewarning-if-scheduled)
;; Use global prewarning-restart lead time.
org-agenda-skip-deadline-prewarning-if-scheduled)
((eq org-agenda-skip-deadline-prewarning-if-scheduled
'pre-scheduled)
;; Set pre-warning to no earlier than SCHEDULED.
(min (- deadline
(org-agenda--timestamp-to-absolute scheduled))
org-deadline-warning-days))
;; Set pre-warning to deadline.
(t 0))))
(warning-days (min max-warning-days (org-get-wdays s))))
(cond
;; Only display deadlines at their base date, at future
;; repeat occurrences or in today agenda.
((= current deadline) nil)
((= current repeat) nil)
((not today?) (throw :skip nil))
;; Upcoming deadline: display within warning period WARNING-DAYS.
((> deadline current) (when (> diff warning-days) (throw :skip nil)))
;; Overdue deadline: warn about it for
;; `org-deadline-past-days' duration.
(t (when (< org-deadline-past-days (- diff)) (throw :skip nil))))
;; Possibly skip done tasks.
(when (and done?
(or org-agenda-skip-deadline-if-done
(/= deadline current)))
(throw :skip nil))
(save-excursion
(goto-char (org-element-begin el))
(let* ((category (org-get-category))
(effort (save-match-data (or (get-text-property (point) 'effort)
(org-element-property (intern (concat ":" (upcase org-effort-property))) el))))
(effort-minutes (when effort (save-match-data (org-duration-to-minutes effort))))
(level (make-string (org-element-property :level el)
?\s))
(head (save-excursion
(goto-char (org-element-begin el))
(re-search-forward org-outline-regexp-bol)
(buffer-substring-no-properties (point) (line-end-position))))
(inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
(memq 'agenda org-agenda-show-inherited-tags))
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda
org-agenda-use-tag-inheritance)))))
(tags (org-get-tags el (not inherited-tags)))
(time
(cond
;; No time of day designation if it is only
;; a reminder.
((and (/= current deadline) (/= current repeat)) nil)
((string-match " \\([012]?[0-9]:[0-9][0-9]\\)" s)
(concat (substring s (match-beginning 1)) " "))
(t 'time)))
(item
(org-agenda-format-item
;; Insert appropriate suffixes before deadlines.
;; Those only apply to today agenda.
(pcase-let ((`(,now ,future ,past)
org-agenda-deadline-leaders))
(cond
((and today? (< deadline today)) (format past (- diff)))
((and today? (> deadline today)) (format future diff))
(t now)))
(org-add-props head nil
'effort effort
'effort-minutes effort-minutes)
level category tags time))
(face (org-agenda-deadline-face
(- 1 (/ (float diff) (max warning-days 1)))))
(upcoming? (and today? (> deadline today)))
(warntime (org-entry-get (point) "APPT_WARNTIME" 'selective)))
(org-add-props item props
'org-marker (org-agenda-new-marker pos)
'org-hd-marker (org-agenda-new-marker (line-beginning-position))
'warntime warntime
'level level
'effort effort 'effort-minutes effort-minutes
'ts-date deadline
'urgency
;; Adjust urgency to today reminders about deadlines.
;; Overdue deadlines get the highest urgency
;; increase, then imminent deadlines and eventually
;; more distant deadlines.
(let ((adjust (if today? (- diff) 0)))
(+ adjust (org-get-priority item)))
'priority (org-get-priority item)
'todo-state todo-state
'type (if upcoming? "upcoming-deadline" "deadline")
'date (if upcoming? date deadline)
'face (if done? 'org-agenda-done face)
'undone-face face
'done-face 'org-agenda-done)
(push item deadline-items)))))))
:next-re regexp
:fail-re regexp
:narrow t)
(nreverse deadline-items)))
(defun org-agenda-deadline-face (fraction)
"Return the face to displaying a deadline item.
FRACTION is what fraction of the head-warning time has passed."
(assoc-default fraction org-agenda-deadline-faces #'<=))
(defun org-agenda-get-scheduled (&optional deadlines with-hour)
"Return the scheduled information for agenda display.
Optional argument DEADLINES is a list of deadline items to be
displayed in agenda view. When WITH-HOUR is non-nil, only return
scheduled items with an hour specification like [h]h:mm."
(with-no-warnings (defvar date))
(let* ((props (list 'org-not-done-regexp org-not-done-regexp
'org-todo-regexp org-todo-regexp
'org-complex-heading-regexp org-complex-heading-regexp
'done-face 'org-agenda-done
'mouse-face 'highlight
'help-echo
(format "mouse-2 or RET jump to Org file %s"
(abbreviate-file-name buffer-file-name))))
(regexp (if with-hour
org-scheduled-time-hour-regexp
org-scheduled-time-regexp))
(today (org-today))
(todayp (org-agenda-today-p date)) ; DATE bound by calendar.
(current (calendar-absolute-from-gregorian date))
(deadline-pos
(mapcar (lambda (d)
(let ((m (get-text-property 0 'org-hd-marker d)))
(and m (marker-position m))))
deadlines))
scheduled-items)
(org-element-cache-map
(lambda (el)
(when (and (org-element-property :scheduled el)
;; Only consider active timestamp values.
(memq (org-element-property
:type
(org-element-property :scheduled el))
'(diary active active-range))
(or (not with-hour)
(org-element-property
:hour-start
(org-element-property :scheduled el))
(org-element-property
:hour-end
(org-element-property :scheduled el))))
(goto-char (org-element-contents-begin el))
(catch :skip
(org-agenda-skip el)
(let* ((s (substring (org-element-property
:raw-value
(org-element-property :scheduled el))
1 -1))
(pos (save-excursion
(goto-char (org-element-contents-begin el))
;; We intentionally leave NOERROR
;; argument in `re-search-forward' nil. If
;; the search fails here, something went
;; wrong and we are looking at
;; non-matching headline.
(re-search-forward regexp (line-end-position))
(1- (match-beginning 1))))
(todo-state (org-element-property :todo-keyword el))
(donep (eq 'done (org-element-property :todo-type el)))
(sexp? (eq 'diary
(org-element-property
:type (org-element-property :scheduled el))))
;; SCHEDULE is the scheduled date for the entry. It is
;; either the bare date or the last repeat, according
;; to `org-agenda-prefer-last-repeat'.
(schedule
(cond
(sexp? (org-agenda--timestamp-to-absolute s current))
((or (eq org-agenda-prefer-last-repeat t)
(member todo-state org-agenda-prefer-last-repeat))
(org-agenda--timestamp-to-absolute
s today 'past (current-buffer) pos))
(t (org-agenda--timestamp-to-absolute s))))
;; REPEAT is the future repeat closest from CURRENT,
;; according to `org-agenda-show-future-repeats'. If
;; the latter is nil, or if the time stamp has no
;; repeat part, default to SCHEDULE.
(repeat
(cond
(sexp? schedule)
((<= current today) schedule)
((not org-agenda-show-future-repeats) schedule)
(t
(let ((base (if (eq org-agenda-show-future-repeats 'next)
(1+ today)
current)))
(org-agenda--timestamp-to-absolute
s base 'future (current-buffer) pos)))))
(diff (- current schedule))
(warntime (org-entry-get (point) "APPT_WARNTIME" 'selective))
(pastschedp (< schedule today))
(futureschedp (> schedule today))
(habitp (and (fboundp 'org-is-habit-p)
(string= "habit" (org-element-property :STYLE el))))
(max-delay-days
(let ((deadline (and org-agenda-skip-scheduled-delay-if-deadline
(org-element-property
:raw-value
(org-element-property :deadline el)))))
(cond
((not deadline) most-positive-fixnum)
;; The current item has a deadline date, so
;; evaluate its delay time.
((integerp org-agenda-skip-scheduled-delay-if-deadline)
;; Use global delay time.
(- org-agenda-skip-scheduled-delay-if-deadline))
((eq org-agenda-skip-scheduled-delay-if-deadline
'post-deadline)
;; Set delay to no later than DEADLINE.
(min (- schedule
(org-agenda--timestamp-to-absolute deadline))
org-scheduled-delay-days))
(t 0))))
(delay-days
(cond
;; Nullify delay when a repeater triggered already
;; and the delay is of the form --Xd.
((and (string-match-p "--[0-9]+[hdwmy]" s)
(> schedule (org-agenda--timestamp-to-absolute s)))
0)
(t (min max-delay-days (org-get-wdays s t))))))
;; Display scheduled items at base date (SCHEDULE), today if
;; scheduled before the current date, and at any repeat past
;; today. However, skip delayed items and items that have
;; been displayed for more than `org-scheduled-past-days'.
(unless (and todayp
habitp
(bound-and-true-p org-habit-show-all-today))
(when (or (and (> delay-days 0) (< diff delay-days))
(> diff (or (and habitp org-habit-scheduled-past-days)
org-scheduled-past-days))
(> schedule current)
(and (/= current schedule)
(/= current today)
(/= current repeat)))
(throw :skip nil)))
;; Possibly skip done tasks.
(when (and donep
(or org-agenda-skip-scheduled-if-done
(/= schedule current)))
(throw :skip nil))
;; Skip entry if it already appears as a deadline, per
;; `org-agenda-skip-scheduled-if-deadline-is-shown'. This
;; doesn't apply to habits.
(when (or org-agenda-skip-scheduled-repeats-after-deadline
;; FIXME: Backwards-compatibility.
(eq org-agenda-skip-scheduled-if-deadline-is-shown
'repeated-after-deadline))
(let ((deadline
(time-to-days
(when (org-element-property :deadline el)
(org-time-string-to-time
(org-element-interpret-data
(org-element-property :deadline el)))))))
(when (and (or (<= (org-agenda--timestamp-to-absolute s) deadline)
(not (= schedule current)))
(> current deadline))
(throw :skip nil))))
(when (pcase org-agenda-skip-scheduled-if-deadline-is-shown
((guard
(or (not (memq (line-beginning-position 0) deadline-pos))
habitp))
nil)
(`not-today pastschedp)
(`t t)
(_ nil))
(throw :skip nil))
;; Skip habits if `org-habit-show-habits' is nil, or if we
;; only show them for today. Also skip done habits.
(when (and habitp
(or donep
(not (bound-and-true-p org-habit-show-habits))
(and (not todayp)
(bound-and-true-p
org-habit-show-habits-only-for-today))))
(throw :skip nil))
(save-excursion
(goto-char (org-element-begin el))
(let* ((category (org-get-category))
(effort (save-match-data
(or (get-text-property (point) 'effort)
(org-element-property (intern (concat ":" (upcase org-effort-property))) el))))
(effort-minutes (when effort (save-match-data (org-duration-to-minutes effort))))
(inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
(memq 'agenda org-agenda-show-inherited-tags))
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda
org-agenda-use-tag-inheritance)))))
(tags (org-get-tags el (not inherited-tags)))
(level (make-string (org-element-property :level el)
?\s))
(head (save-excursion
(goto-char (org-element-begin el))
(re-search-forward org-outline-regexp-bol)
(buffer-substring (point) (line-end-position))))
(time
(cond
;; No time of day designation if it is only a
;; reminder, except for habits, which always show
;; the time of day. Habits are an exception
;; because if there is a time of day, that is
;; interpreted to mean they should usually happen
;; then, even if doing the habit was missed.
((and
(not habitp)
(/= current schedule)
(/= current repeat))
nil)
((string-match " \\([012]?[0-9]:[0-9][0-9]\\)" s)
(concat (substring s (match-beginning 1)) " "))
(t 'time)))
(item
(org-agenda-format-item
(pcase-let ((`(,first ,past) org-agenda-scheduled-leaders))
;; Show a reminder of a past scheduled today.
(if (and todayp pastschedp)
(format past diff)
first))
(org-add-props head nil
'effort effort
'effort-minutes effort-minutes)
level category tags time nil habitp))
(face (cond ((and (not habitp) pastschedp)
'org-scheduled-previously)
((and habitp futureschedp)
'org-agenda-done)
(todayp 'org-scheduled-today)
(t 'org-scheduled)))
(habitp (and habitp (org-habit-parse-todo (org-element-begin el)))))
(org-add-props item props
'undone-face face
'face (if donep 'org-agenda-done face)
'org-marker (org-agenda-new-marker pos)
'org-hd-marker (org-agenda-new-marker (line-beginning-position))
'type (if pastschedp "past-scheduled" "scheduled")
'date (if pastschedp schedule date)
'ts-date schedule
'warntime warntime
'level level
'effort effort 'effort-minutes effort-minutes
'urgency (if habitp (org-habit-get-urgency habitp)
(+ 99 diff (org-get-priority item)))
'priority (org-get-priority item)
'org-habit-p habitp
'todo-state todo-state)
(push item scheduled-items)))))))
:next-re regexp
:fail-re regexp
:narrow t)
(nreverse scheduled-items)))
(defun org-agenda-get-blocks ()
"Return the date-range information for agenda display."
(with-no-warnings (defvar date))
(let* ((props (list 'org-not-done-regexp org-not-done-regexp
'org-todo-regexp org-todo-regexp
'org-complex-heading-regexp org-complex-heading-regexp
'mouse-face 'highlight
'help-echo
(format "mouse-2 or RET jump to org file %s"
(abbreviate-file-name buffer-file-name))))
(regexp (if org-agenda-include-inactive-timestamps
org-tr-regexp-both org-tr-regexp))
(d0 (calendar-absolute-from-gregorian date))
face marker hdmarker ee txt d1 d2 s1 s2 category level
todo-state tags pos head donep inherited-tags effort
effort-minutes inactive?)
(goto-char (point-min))
(while (re-search-forward regexp nil t)
(catch :skip
(org-agenda-skip)
(setq pos (point))
(setq inactive? (eq ?\[ (char-after (match-beginning 0))))
(let ((start-time (match-string 1))
(end-time (match-string 2)))
(setq s1 (match-string 1)
s2 (match-string 2)
d1 (time-to-days
(condition-case err
(org-time-string-to-time s1)
(error
(error
"Bad timestamp %S at %d in buffer %S\nError was: %s"
s1
pos
(current-buffer)
(error-message-string err)))))
d2 (time-to-days
(condition-case err
(org-time-string-to-time s2)
(error
(error
"Bad timestamp %S at %d in buffer %S\nError was: %s"
s2
pos
(current-buffer)
(error-message-string err))))))
(when (and (> (- d0 d1) -1) (> (- d2 d0) -1))
;; Only allow days between the limits, because the normal
;; date stamps will catch the limits.
(save-excursion
(setq todo-state (org-get-todo-state))
(setq donep (member todo-state org-done-keywords))
(when (and donep org-agenda-skip-timestamp-if-done)
(throw :skip t))
(setq face (if (= d1 d2)
'org-agenda-calendar-event
'org-agenda-calendar-daterange))
(setq marker (org-agenda-new-marker (point))
category (org-get-category))
(setq effort (save-match-data (or (get-text-property (point) 'effort)
(org-entry-get (point) org-effort-property))))
(setq effort-minutes (when effort (save-match-data (org-duration-to-minutes effort))))
(if (not (re-search-backward org-outline-regexp-bol nil t))
(throw :skip nil)
(goto-char (match-beginning 0))
(setq hdmarker (org-agenda-new-marker (point))
inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
(memq 'agenda org-agenda-show-inherited-tags))
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda org-agenda-use-tag-inheritance))))
tags (org-get-tags nil (not inherited-tags)))
(setq level (make-string (org-reduced-level (org-outline-level)) ? ))
(looking-at "\\*+[ \t]+\\(.*\\)")
(setq head (match-string 1))
(let ((remove-re
(if org-agenda-remove-timeranges-from-blocks
(concat
"<" (regexp-quote s1) ".*?>"
"--"
"<" (regexp-quote s2) ".*?>")
nil)))
(setq txt (org-agenda-format-item
(concat
(when inactive? org-agenda-inactive-leader)
(format
(nth (if (= d1 d2) 0 1)
org-agenda-timerange-leaders)
(1+ (- d0 d1)) (1+ (- d2 d1))))
(org-add-props head nil
'effort effort
'effort-minutes effort-minutes)
level category tags
(cond
((and (= d1 d0) (= d2 d0))
(concat "<" start-time ">--<" end-time ">"))
((= d1 d0)
(concat "<" start-time ">"))
((= d2 d0)
(concat "<" end-time ">")))
remove-re))))
(org-add-props txt props
'face face
'org-marker marker 'org-hd-marker hdmarker
'type "block" 'date date
'level level
'effort effort 'effort-minutes effort-minutes
'todo-state todo-state
'urgency (org-get-priority txt)
'priority (org-get-priority txt))
(push txt ee))))
(goto-char pos)))
;; Sort the entries by expiration date.
(nreverse ee)))
;;; Agenda presentation and sorting
(defvar org-prefix-has-time nil
"A flag, set by `org-compile-prefix-format'.
The flag is set if the currently compiled format contains a `%t'.")
(defvar org-prefix-has-tag nil
"A flag, set by `org-compile-prefix-format'.
The flag is set if the currently compiled format contains a `%T'.")
(defvar org-prefix-has-effort nil
"A flag, set by `org-compile-prefix-format'.
The flag is set if the currently compiled format contains a `%e'.")
(defvar org-prefix-has-breadcrumbs nil
"A flag, set by `org-compile-prefix-format'.
The flag is set if the currently compiled format contains a `%b'.")
(defvar org-prefix-category-length nil
"Used by `org-compile-prefix-format' to remember the category field width.")
(defvar org-prefix-category-max-length nil
"Used by `org-compile-prefix-format' to remember the category field width.")
(defun org-agenda-get-category-icon (category)
"Return an image for CATEGORY according to `org-agenda-category-icon-alist'."
(cl-dolist (entry org-agenda-category-icon-alist)
(when (string-match-p (car entry) category)
(if (listp (cadr entry))
(cl-return (cadr entry))
(cl-return (apply #'create-image (cdr entry)))))))
(defun org-agenda-format-item (extra txt &optional with-level with-category tags dotime
remove-re habitp)
"Format TXT to be inserted into the agenda buffer.
In particular, add the prefix and corresponding text properties.
EXTRA must be a string to replace the `%s' specifier in the prefix format.
WITH-LEVEL may be a string to replace the `%l' specifier.
WITH-CATEGORY (a string, a symbol or nil) may be used to overrule the default
category taken from local variable or file name. It will replace the `%c'
specifier in the format.
DOTIME, when non-nil, indicates that a time-of-day should be extracted from
TXT for sorting of this entry, and for the `%t' specifier in the format.
When DOTIME is a string, this string is searched for a time before TXT is.
TAGS can be the tags of the headline.
Any match of REMOVE-RE will be removed from TXT."
;; We keep the org-prefix-* variable values along with a compiled
;; formatter, so that multiple agendas existing at the same time do
;; not step on each other toes.
;;
;; It was inconvenient to make these variables buffer local in
;; Agenda buffers, because this function expects to be called with
;; the buffer where item comes from being current, and not agenda
;; buffer
(let* ((bindings (car org-prefix-format-compiled))
(formatter (cadr org-prefix-format-compiled)))
(cl-loop for (var value) in bindings
do (set var value))
(save-match-data
;; Diary entries sometimes have extra whitespace at the beginning
(setq txt (org-trim txt))
;; Fix the tags part in txt
(setq txt (org-agenda-fix-displayed-tags
txt tags
org-agenda-show-inherited-tags
org-agenda-hide-tags-regexp))
(with-no-warnings
;; `time', `tag', `effort' are needed for the eval of the prefix format.
;; Based on what I see in `org-compile-prefix-format', I added
;; a few more.
(defvar breadcrumbs) (defvar category) (defvar category-icon)
(defvar effort) (defvar extra)
(defvar level) (defvar tag) (defvar time))
(let* ((category (or with-category
(if buffer-file-name
(file-name-sans-extension
(file-name-nondirectory buffer-file-name))
"")))
(full-category category)
(category-icon (org-agenda-get-category-icon category))
(category-icon (if category-icon
(propertize " " 'display category-icon)
""))
(effort (and (not (string= txt ""))
(get-text-property 1 'effort txt)))
(tag (if tags (nth (1- (length tags)) tags) ""))
(time-grid-trailing-characters (nth 2 org-agenda-time-grid))
(extra (or (and (not habitp) extra) ""))
time
(ts (when dotime (concat
(if (stringp dotime) dotime "")
(and org-agenda-search-headline-for-time
;; Do not search inside
;; timestamps. They are handled
;; separately.
(replace-regexp-in-string
org-ts-regexp-both ""
txt)))))
(time-of-day (and dotime (org-get-time-of-day ts)))
stamp plain s0 s1 s2 rtn srp l
duration breadcrumbs)
(and (derived-mode-p 'org-mode) buffer-file-name
(add-to-list 'org-agenda-contributing-files buffer-file-name))
(when (and dotime time-of-day)
;; Extract starting and ending time and move them to prefix
(when (or (setq stamp (string-match org-stamp-time-of-day-regexp ts))
(setq plain (string-match org-plain-time-of-day-regexp ts)))
(setq s0 (match-string 0 ts)
srp (and stamp (match-end 3))
s1 (match-string (if plain 1 2) ts)
s2 (match-string (if plain 8 (if srp 4 6)) ts))
;; If the times are in TXT (not in DOTIMES), and the prefix will list
;; them, we might want to remove them there to avoid duplication.
;; The user can turn this off with a variable.
(when (and org-prefix-has-time
org-agenda-remove-times-when-in-prefix (or stamp plain)
(string-match (concat (regexp-quote s0) " *") txt)
(not (equal ?\] (string-to-char (substring txt (match-end 0)))))
(if (eq org-agenda-remove-times-when-in-prefix 'beg)
(= (match-beginning 0) 0)
t))
(setq txt (replace-match "" nil nil txt))))
;; Normalize the time(s) to 24 hour.
(when s1 (setq s1 (org-get-time-of-day s1 t)))
(when s2 (setq s2 (org-get-time-of-day s2 t)))
;; Try to set s2 if s1 and
;; `org-agenda-default-appointment-duration' are set
(when (and s1 (not s2) org-agenda-default-appointment-duration)
(setq s2
(org-duration-from-minutes
(+ (org-duration-to-minutes s1 t)
org-agenda-default-appointment-duration)
nil t)))
;; Compute the duration
(when s2
(setq duration (- (org-duration-to-minutes s2)
(org-duration-to-minutes s1))))
;; Format S1 and S2 for display.
(when s1 (setq s1 (format "%5s" (org-get-time-of-day s1 'overtime))))
(when s2 (setq s2 (org-get-time-of-day s2 'overtime))))
(when (string-match org-tag-group-re txt)
;; Tags are in the string
(if (or (eq org-agenda-remove-tags t)
(and org-agenda-remove-tags
org-prefix-has-tag))
(setq txt (replace-match "" t t txt))
(setq txt (replace-match
(concat (make-string (max (- 50 (length txt)) 1) ?\ )
(match-string 1 txt))
t t txt))))
(when remove-re
(while (string-match remove-re txt)
(setq txt (replace-match "" t t txt))))
;; Set org-heading property on `txt' to mark the start of the
;; heading.
(add-text-properties 0 (length txt) '(org-heading t) txt)
;; Prepare the variables needed in the eval of the compiled format
(when org-prefix-has-breadcrumbs
(setq breadcrumbs
;; When called from Org buffer, remain in position.
;; When called from Agenda buffer, jump to headline position first.
(org-with-point-at (org-get-at-bol 'org-marker)
(let ((s (if (derived-mode-p 'org-mode)
(org-format-outline-path (org-get-outline-path)
(1- (frame-width))
nil org-agenda-breadcrumbs-separator)
;; Not in Org buffer. This can happen,
;; for example, in
;; `org-agenda-add-time-grid-maybe' where
;; time grid does not correspond to a
;; particular heading.
"")))
(if (equal "" s) "" (concat s org-agenda-breadcrumbs-separator))))))
(setq time (cond (s2 (concat
(org-agenda-time-of-day-to-ampm-maybe s1)
"-" (org-agenda-time-of-day-to-ampm-maybe s2)
(when org-agenda-timegrid-use-ampm " ")))
(s1 (concat
(org-agenda-time-of-day-to-ampm-maybe s1)
(if org-agenda-timegrid-use-ampm
(concat time-grid-trailing-characters " ")
time-grid-trailing-characters)))
(t ""))
category (if (symbolp category) (symbol-name category) category)
level (or with-level ""))
(if (string-match org-link-bracket-re category)
(progn
(setq l (string-width (or (match-string 2) (match-string 1))))
(when (< l (or org-prefix-category-length 0))
(setq category (copy-sequence category))
(org-add-props category nil
'extra-space (make-string
(- org-prefix-category-length l 1) ?\ ))))
(when (and org-prefix-category-max-length
(>= (length category) org-prefix-category-max-length))
(setq category (substring category 0 (1- org-prefix-category-max-length)))))
;; Evaluate the compiled format
(setq rtn (concat (eval formatter t) txt))
;; And finally add the text properties
(remove-text-properties 0 (length rtn) '(line-prefix t wrap-prefix t) rtn)
(org-add-props rtn nil
;; CATEGORY might be truncated. Store the full category in
;; the properties.
'org-category full-category
'tags tags
'org-priority-highest org-priority-highest
'org-priority-lowest org-priority-lowest
'time-of-day time-of-day
'duration duration
'breadcrumbs breadcrumbs
'txt txt
'level level
'time time
'extra extra
'format org-prefix-format-compiled
'dotime dotime)))))
(defun org-agenda-fix-displayed-tags (txt tags add-inherited hide-re)
"Remove tags string from TXT, and add a modified list of tags.
The modified list may contain inherited tags, and tags matched by
`org-agenda-hide-tags-regexp' will be removed."
(when (or add-inherited hide-re)
(when (string-match org-tag-group-re txt)
(setq txt (substring txt 0 (match-beginning 0))))
(setq tags
(delq nil
(mapcar (lambda (tg)
(if (or (and hide-re (string-match hide-re tg))
(and (not add-inherited)
(get-text-property 0 'inherited tg)))
nil
tg))
tags)))
(when tags
(let ((have-i (get-text-property 0 'inherited (car tags)))
i)
(setq txt (concat txt " :"
(mapconcat
(lambda (x)
(setq i (get-text-property 0 'inherited x))
(if (and have-i (not i))
(progn
(setq have-i nil)
(concat ":" x))
x))
tags ":")
(if have-i "::" ":"))))))
txt)
(defvar org-agenda-sorting-strategy) ;; because the def is in a let form
(defun org-agenda-add-time-grid-maybe (list ndays todayp)
"Add a time-grid for agenda items which need it.
LIST is the list of agenda items formatted by `org-agenda-list'.
NDAYS is the span of the current agenda view.
TODAYP is t when the current agenda view is on today."
(catch 'exit
(cond ((not org-agenda-use-time-grid) (throw 'exit list))
((and todayp (member 'today (car org-agenda-time-grid))))
((and (= ndays 1) (member 'daily (car org-agenda-time-grid))))
((member 'weekly (car org-agenda-time-grid)))
(t (throw 'exit list)))
(let* ((have (delq nil (mapcar
(lambda (x) (get-text-property 1 'time-of-day x))
list)))
(string (nth 3 org-agenda-time-grid))
(gridtimes (nth 1 org-agenda-time-grid))
(req (car org-agenda-time-grid))
(remove (member 'remove-match req))
new time
;; We abuse `org-agenda-format-item' to format grid lines
;; here. Prevent it from adding default duration, if any
;; to the grid lines.
(org-agenda-default-appointment-duration nil))
(when (and (member 'require-timed req) (not have))
;; don't show empty grid
(throw 'exit list))
(while (setq time (pop gridtimes))
(unless (and remove (member time have))
(setq time (replace-regexp-in-string " " "0" (format "%04s" time)))
(push (org-agenda-format-item
nil string nil "" nil
(concat (substring time 0 -2) ":" (substring time -2)))
new)
(put-text-property
2 (length (car new)) 'face 'org-time-grid (car new))))
(when (and todayp org-agenda-show-current-time-in-grid)
(push (org-agenda-format-item
nil org-agenda-current-time-string nil "" nil
(format-time-string "%H:%M "))
new)
(put-text-property
2 (length (car new)) 'face 'org-agenda-current-time (car new)))
(if (member 'time-up org-agenda-sorting-strategy-selected)
(append new list)
(append list new)))))
(defun org-compile-prefix-format (key)
"Compile the prefix format into a Lisp form that can be evaluated.
KEY is the agenda type (see `org-agenda-prefix-format').
The resulting form and associated variable bindings is returned
and stored in the variable `org-prefix-format-compiled'."
(setq org-prefix-has-time nil
org-prefix-has-tag nil
org-prefix-category-length nil
org-prefix-has-effort nil
org-prefix-has-breadcrumbs nil)
(let ((s (cond
((stringp org-agenda-prefix-format)
org-agenda-prefix-format)
((assq key org-agenda-prefix-format)
(cdr (assq key org-agenda-prefix-format)))
(t " %-12:c%?-12t% s")))
(start 0)
varform vars var c f opt) ;; e
(while (string-match "%\\(\\?\\)?\\([-+]?[0-9.]*\\)\\([ .;,:!?=|/<>]?\\)\\([cltseib]\\|(.+?)\\)"
s start)
(setq var (or (cdr (assoc (match-string 4 s)
'(("c" . category) ("t" . time) ("l" . level) ("s" . extra)
("i" . category-icon) ("T" . tag) ("e" . effort) ("b" . breadcrumbs))))
'eval)
c (or (match-string 3 s) "")
opt (match-beginning 1)
start (1+ (match-beginning 0)))
(cl-case var
(time (setq org-prefix-has-time t))
(tag (setq org-prefix-has-tag t))
(effort (setq org-prefix-has-effort t))
(breadcrumbs (setq org-prefix-has-breadcrumbs t)))
(setq f (concat "%" (match-string 2 s) "s"))
(when (eq var 'category)
(setq org-prefix-category-length
(floor (abs (string-to-number (match-string 2 s)))))
(setq org-prefix-category-max-length
(let ((x (match-string 2 s)))
(save-match-data
(and (string-match "\\.[0-9]+" x)
(string-to-number (substring (match-string 0 x) 1)))))))
(if (eq var 'eval)
(setq varform `(format ,f (org-eval ,(read (substring s (match-beginning 4))))))
(if opt
(setq varform
`(if (member ,var '("" nil))
""
(format ,f (concat ,var ,c))))
(setq varform
`(format ,f (if (member ,var '("" nil)) ""
(concat ,var ,c (get-text-property 0 'extra-space ,var)))))))
(if (eq var 'eval)
(setf (substring s (match-beginning 0)
(+ (match-beginning 4)
(length (format "%S" (read (substring s (match-beginning 4)))))))
"%s")
(setq s (replace-match "%s" t nil s)))
(push varform vars))
(setq vars (nreverse vars))
(with-current-buffer (or org-agenda-buffer (current-buffer))
(setq org-prefix-format-compiled
(list
`((org-prefix-has-time ,org-prefix-has-time)
(org-prefix-has-tag ,org-prefix-has-tag)
(org-prefix-category-length ,org-prefix-category-length)
(org-prefix-has-effort ,org-prefix-has-effort)
(org-prefix-has-breadcrumbs ,org-prefix-has-breadcrumbs))
`(format ,s ,@vars))))))
(defun org-set-sorting-strategy (key)
(setq org-agenda-sorting-strategy-selected
(if (symbolp (car org-agenda-sorting-strategy))
;; the old format
org-agenda-sorting-strategy
(or (cdr (assq key org-agenda-sorting-strategy))
(cdr (assq 'agenda org-agenda-sorting-strategy))
'(time-up category-keep urgency-down)))))
(defun org-get-time-of-day (s &optional string)
"Check string S for a time of day.
If found, return it as a military time number between 0 and 2400.
If not found, return nil.
The optional STRING argument forces conversion into a 5 character wide string
HH:MM. When it is `overtime', any time above 24:00 is turned into \"+H:MM\"
where H:MM is the duration above midnight."
(let ((case-fold-search t)
(time-regexp
(rx word-start
(group (opt (any "012")) digit) ;group 1: hours
(or (and ":" (group (any "012345") digit) ;group 2: minutes
(opt (group (or "am" "pm")))) ;group 3: am/pm
;; Special "HHam/pm" case.
(group-n 3 (or "am" "pm")))
word-end)))
(save-match-data
(when (and (string-match time-regexp s)
(not (eq 'org-link (get-text-property 1 'face s))))
(let ((hours
(let* ((ampm (and (match-end 3) (downcase (match-string 3 s))))
(am-p (equal ampm "am")))
(pcase (string-to-number (match-string 1 s))
((and (guard (not ampm)) h) h)
(12 (if am-p 0 12))
(h (+ h (if am-p 0 12))))))
(minutes
(if (match-end 2)
(string-to-number (match-string 2 s))
0)))
(pcase string
(`nil (+ minutes (* hours 100)))
((and `overtime
(guard (or (> hours 24)
(and (= hours 24)
(> minutes 0)))))
(format "+%d:%02d" (- hours 24) minutes))
((guard org-agenda-time-leading-zero)
(format "%02d:%02d" hours minutes))
(_
(format "%d:%02d" hours minutes))))))))
(defvar org-agenda-before-sorting-filter-function nil
"Function to be applied to agenda items prior to sorting.
Prior to sorting also means just before they are inserted into the agenda.
To aid sorting, you may revisit the original entries and add more text
properties which will later be used by the sorting functions.
The function should take a string argument, an agenda line.
It has access to the text properties in that line, which contain among
other things, the property `org-hd-marker' that points to the entry
where the line comes from. Note that not all lines going into the agenda
have this property, only most.
The function should return the modified string. It is probably best
to ONLY change text properties.
You can also use this function as a filter, by returning nil for lines
you don't want to have in the agenda at all. For this application, you
could bind the variable in the options section of a custom command.")
(defun org-agenda-finalize-entries (list &optional type)
"Sort, limit and concatenate the LIST of agenda items.
The optional argument TYPE tells the agenda type."
(let ((max-effort (cond ((listp org-agenda-max-effort)
(cdr (assoc type org-agenda-max-effort)))
(t org-agenda-max-effort)))
(max-todo (cond ((listp org-agenda-max-todos)
(cdr (assoc type org-agenda-max-todos)))
(t org-agenda-max-todos)))
(max-tags (cond ((listp org-agenda-max-tags)
(cdr (assoc type org-agenda-max-tags)))
(t org-agenda-max-tags)))
(max-entries (cond ((listp org-agenda-max-entries)
(cdr (assoc type org-agenda-max-entries)))
(t org-agenda-max-entries))))
(when org-agenda-before-sorting-filter-function
(setq list
(delq nil
(mapcar
org-agenda-before-sorting-filter-function list))))
(setq list (mapcar #'org-agenda-highlight-todo list)
list (mapcar #'identity (sort list #'org-entries-lessp)))
(when max-effort
(setq list (org-agenda-limit-entries
list 'effort-minutes max-effort
(lambda (e) (or e (if org-agenda-sort-noeffort-is-high
32767 -1))))))
(when max-todo
(setq list (org-agenda-limit-entries list 'todo-state max-todo)))
(when max-tags
(setq list (org-agenda-limit-entries list 'tags max-tags)))
(when max-entries
(setq list (org-agenda-limit-entries list 'org-hd-marker max-entries)))
(when (and org-agenda-dim-blocked-tasks org-blocker-hook)
(setq list (mapcar #'org-agenda--mark-blocked-entry list)))
(mapconcat #'identity list "\n")))
(defun org-agenda-limit-entries (list prop limit &optional fn)
"Limit the number of agenda entries."
(let ((include (and limit (< limit 0))))
(if limit
(let ((fun (or fn (lambda (p) (when p 1))))
(lim 0))
(delq nil
(mapcar
(lambda (e)
(let ((pval (funcall
fun (get-text-property (1- (length e))
prop e))))
(when pval (setq lim (+ lim pval)))
(cond ((and pval (<= lim (abs limit))) e)
((and include (not pval)) e))))
list)))
list)))
(defun org-agenda-limit-interactively (remove)
"In agenda, interactively limit entries to various maximums."
(interactive "P")
(if remove
(progn (setq org-agenda-max-entries nil
org-agenda-max-todos nil
org-agenda-max-tags nil
org-agenda-max-effort nil)
(org-agenda-redo))
(let* ((max (read-char "Number of [e]ntries [t]odos [T]ags [E]ffort? "))
(msg (cond ((= max ?E) "How many minutes? ")
((= max ?e) "How many entries? ")
((= max ?t) "How many TODO entries? ")
((= max ?T) "How many tagged entries? ")
(t (user-error "Wrong input"))))
(num (string-to-number (read-from-minibuffer msg))))
(cond ((equal max ?e)
(let ((org-agenda-max-entries num)) (org-agenda-redo)))
((equal max ?t)
(let ((org-agenda-max-todos num)) (org-agenda-redo)))
((equal max ?T)
(let ((org-agenda-max-tags num)) (org-agenda-redo)))
((equal max ?E)
(let ((org-agenda-max-effort num)) (org-agenda-redo))))))
(org-agenda-fit-window-to-buffer))
(defun org-agenda-highlight-todo (x)
(let ((org-done-keywords org-done-keywords-for-agenda)
(case-fold-search nil)
re)
(if (eq x 'line)
(save-excursion
(forward-line 0)
(setq re (org-get-at-bol 'org-todo-regexp))
(goto-char (or (text-property-any (line-beginning-position)
(line-end-position)
'org-heading t)
(point)))
(when (looking-at (concat "[ \t]*\\.*\\(" re "\\) +"))
(add-text-properties (match-beginning 0) (match-end 1)
(list 'face (org-get-todo-face 1)))
(let ((s (buffer-substring (match-beginning 1) (match-end 1))))
(delete-region (match-beginning 1) (1- (match-end 0)))
(goto-char (match-beginning 1))
(insert (format org-agenda-todo-keyword-format s)))))
(let ((pl (text-property-any 0 (length x) 'org-heading t x)))
(setq re (get-text-property 0 'org-todo-regexp x))
(when (and re
;; Test `pl' because if there's no heading content,
;; there's no point matching to highlight. Note
;; that if we didn't test `pl' first, and there
;; happened to be no keyword from `org-todo-regexp'
;; on this heading line, then the `equal' comparison
;; afterwards would spuriously succeed in the case
;; where `pl' is nil -- causing an args-out-of-range
;; error when we try to add text properties to text
;; that isn't there.
pl
(equal (string-match (concat "\\(\\.*\\)" re "\\( +\\)")
x pl)
pl))
(add-text-properties
(or (match-end 1) (match-end 0)) (match-end 0)
(list 'face (org-get-todo-face (match-string 2 x)))
x)
(when (match-end 1)
(setq x
(concat
(substring x 0 (match-end 1))
(unless (string= org-agenda-todo-keyword-format "")
(format org-agenda-todo-keyword-format
(match-string 2 x)))
(unless (string= org-agenda-todo-keyword-format "")
;; Remove `display' property as the icon could leak
;; on the white space.
(apply #'propertize " " (org-plist-delete (text-properties-at 0 x) 'display)))
(substring x (match-end 3)))))))
x)))
(defsubst org-cmp-values (a b property)
"Compare the numeric value of text PROPERTY for string A and B."
(let ((pa (or (get-text-property (1- (length a)) property a) 0))
(pb (or (get-text-property (1- (length b)) property b) 0)))
(cond ((> pa pb) +1)
((< pa pb) -1))))
(defsubst org-cmp-effort (a b)
"Compare the effort values of string A and B."
(let* ((def (if org-agenda-sort-noeffort-is-high 32767 -1))
;; `effort-minutes' property is not directly accessible from
;; the strings, but is stored as a property in `txt'.
(ea (or (get-text-property
0 'effort-minutes (get-text-property 0 'txt a))
def))
(eb (or (get-text-property
0 'effort-minutes (get-text-property 0 'txt b))
def)))
(cond ((> ea eb) +1)
((< ea eb) -1))))
(defsubst org-cmp-category (a b)
"Compare the string values of categories of strings A and B."
(let ((ca (or (get-text-property (1- (length a)) 'org-category a) ""))
(cb (or (get-text-property (1- (length b)) 'org-category b) "")))
(cond ((org-string< ca cb) -1)
((org-string< cb ca) +1))))
(defsubst org-cmp-todo-state (a b)
"Compare the todo states of strings A and B."
(let* ((ma (or (get-text-property 1 'org-marker a)
(get-text-property 1 'org-hd-marker a)))
(mb (or (get-text-property 1 'org-marker b)
(get-text-property 1 'org-hd-marker b)))
(fa (and ma (marker-buffer ma)))
(fb (and mb (marker-buffer mb)))
(todo-kwds
(or (and fa (with-current-buffer fa org-todo-keywords-1))
(and fb (with-current-buffer fb org-todo-keywords-1))))
(ta (or (get-text-property 1 'todo-state a) ""))
(tb (or (get-text-property 1 'todo-state b) ""))
(la (- (length (member ta todo-kwds))))
(lb (- (length (member tb todo-kwds))))
(donepa (member ta org-done-keywords-for-agenda))
(donepb (member tb org-done-keywords-for-agenda)))
(cond ((and donepa (not donepb)) -1)
((and (not donepa) donepb) +1)
((< la lb) -1)
((< lb la) +1))))
(defsubst org-cmp-alpha (a b)
"Compare the headlines, alphabetically."
(let* ((pla (text-property-any 0 (length a) 'org-heading t a))
(plb (text-property-any 0 (length b) 'org-heading t b))
(ta (and pla (substring a pla)))
(tb (and plb (substring b plb)))
(case-fold-search nil))
(when pla
(when (string-match (concat "\\`[ \t]*" (or (get-text-property 0 'org-todo-regexp a) "")
"\\([ \t]*\\[[a-zA-Z0-9]\\]\\)? *")
ta)
(setq ta (substring ta (match-end 0))))
(setq ta (downcase ta)))
(when plb
(when (string-match (concat "\\`[ \t]*" (or (get-text-property 0 'org-todo-regexp b) "")
"\\([ \t]*\\[[a-zA-Z0-9]\\]\\)? *")
tb)
(setq tb (substring tb (match-end 0))))
(setq tb (downcase tb)))
(cond ((not (or ta tb)) nil)
((not ta) +1)
((not tb) -1)
((org-string< ta tb) -1)
((org-string< tb ta) +1))))
(defsubst org-cmp-tag (a b)
"Compare the string values of the first tags of A and B."
(let ((ta (car (last (get-text-property 1 'tags a))))
(tb (car (last (get-text-property 1 'tags b)))))
(cond ((not (or ta tb)) nil)
((not ta) +1)
((not tb) -1)
((funcall (or org-tags-sort-function #'org-string<) ta tb) -1)
((funcall (or org-tags-sort-function #'org-string<) tb ta) +1))))
(defsubst org-cmp-time (a b)
"Compare the time-of-day values of strings A and B."
(let* ((def (if org-agenda-sort-notime-is-late 9901 -1))
(ta (or (get-text-property 1 'time-of-day a) def))
(tb (or (get-text-property 1 'time-of-day b) def)))
(cond ((< ta tb) -1)
((< tb ta) +1))))
(defsubst org-cmp-ts (a b type)
"Compare the timestamps values of entries A and B.
When TYPE is \"scheduled\", \"deadline\", \"timestamp\" or
\"timestamp_ia\", compare within each of these type. When TYPE
is the empty string, compare all timestamps without respect of
their type."
(let* ((def (if org-agenda-sort-notime-is-late 99999999 -1))
(ta (or (and (string-match type (or (get-text-property 1 'type a) ""))
(get-text-property 1 'ts-date a))
def))
(tb (or (and (string-match type (or (get-text-property 1 'type b) ""))
(get-text-property 1 'ts-date b))
def)))
(cond ((if ta (and tb (< ta tb)) tb) -1)
((if tb (and ta (< tb ta)) ta) +1))))
(defsubst org-cmp-habit-p (a b)
"Compare the todo states of strings A and B."
(let ((ha (get-text-property 1 'org-habit-p a))
(hb (get-text-property 1 'org-habit-p b)))
(cond ((and ha (not hb)) -1)
((and (not ha) hb) +1))))
(defun org-entries-lessp (a b)
"Predicate for sorting agenda entries."
;; The following variables will be used when the form is evaluated.
;; So even though the compiler complains, keep them.
(let ((ss org-agenda-sorting-strategy-selected))
(org-dlet
((timestamp-up (and (org-em 'timestamp-up 'timestamp-down ss)
(org-cmp-ts a b "")))
(timestamp-down (if timestamp-up (- timestamp-up) nil))
(scheduled-up (and (org-em 'scheduled-up 'scheduled-down ss)
(org-cmp-ts a b "scheduled")))
(scheduled-down (if scheduled-up (- scheduled-up) nil))
(deadline-up (and (org-em 'deadline-up 'deadline-down ss)
(org-cmp-ts a b "deadline")))
(deadline-down (if deadline-up (- deadline-up) nil))
(tsia-up (and (org-em 'tsia-up 'tsia-down ss)
(org-cmp-ts a b "timestamp_ia")))
(tsia-down (if tsia-up (- tsia-up) nil))
(ts-up (and (org-em 'ts-up 'ts-down ss)
(org-cmp-ts a b "timestamp")))
(ts-down (if ts-up (- ts-up) nil))
(time-up (and (org-em 'time-up 'time-down ss)
(org-cmp-time a b)))
(time-down (if time-up (- time-up) nil))
(stats-up (and (org-em 'stats-up 'stats-down ss)
(org-cmp-values a b 'org-stats)))
(stats-down (if stats-up (- stats-up) nil))
(priority-up (and (org-em 'priority-up 'priority-down ss)
(org-cmp-values a b 'priority)))
(priority-down (if priority-up (- priority-up) nil))
(urgency-up (and (org-em 'urgency-up 'urgency-down ss)
(org-cmp-values a b 'urgency)))
(urgency-down (if urgency-up (- urgency-up) nil))
(effort-up (and (org-em 'effort-up 'effort-down ss)
(org-cmp-effort a b)))
(effort-down (if effort-up (- effort-up) nil))
(category-up (and (or (org-em 'category-up 'category-down ss)
(memq 'category-keep ss))
(org-cmp-category a b)))
(category-down (if category-up (- category-up) nil))
(category-keep (if category-up +1 nil))
(tag-up (and (org-em 'tag-up 'tag-down ss)
(org-cmp-tag a b)))
(tag-down (if tag-up (- tag-up) nil))
(todo-state-up (and (org-em 'todo-state-up 'todo-state-down ss)
(org-cmp-todo-state a b)))
(todo-state-down (if todo-state-up (- todo-state-up) nil))
(habit-up (and (org-em 'habit-up 'habit-down ss)
(org-cmp-habit-p a b)))
(habit-down (if habit-up (- habit-up) nil))
(alpha-up (and (org-em 'alpha-up 'alpha-down ss)
(org-cmp-alpha a b)))
(alpha-down (if alpha-up (- alpha-up) nil))
(need-user-cmp (org-em 'user-defined-up 'user-defined-down ss))
user-defined-up user-defined-down)
(when (and need-user-cmp org-agenda-cmp-user-defined
(functionp org-agenda-cmp-user-defined))
(setq user-defined-up
(funcall org-agenda-cmp-user-defined a b)
user-defined-down (if user-defined-up (- user-defined-up) nil)))
(cdr (assoc
(eval (cons 'or org-agenda-sorting-strategy-selected) t)
'((-1 . t) (1 . nil) (nil . nil)))))))
;;; Agenda restriction lock
(defvar org-agenda-restriction-lock-overlay (make-overlay 1 1)
"Overlay to mark the headline to which agenda commands are restricted.")
(overlay-put org-agenda-restriction-lock-overlay
'face 'org-agenda-restriction-lock)
(overlay-put org-agenda-restriction-lock-overlay
'help-echo "Agendas are currently limited to this subtree.")
(delete-overlay org-agenda-restriction-lock-overlay)
(defun org-agenda-set-restriction-lock-from-agenda (arg)
"Set the restriction lock to the agenda item at point from within the agenda.
When called with a `\\[universal-argument]' prefix, restrict to
the file which contains the item.
Argument ARG is the prefix argument."
(interactive "P")
(unless (derived-mode-p 'org-agenda-mode)
(user-error "Not in an Org agenda buffer"))
(let* ((marker (or (org-get-at-bol 'org-marker)
(org-agenda-error)))
(buffer (marker-buffer marker))
(pos (marker-position marker)))
(with-current-buffer buffer
(goto-char pos)
(org-agenda-set-restriction-lock arg))))
;;;###autoload
(defun org-agenda-set-restriction-lock (&optional type)
"Set restriction lock for agenda to current subtree or file.
When in a restricted subtree, remove it.
The restriction will span over the entire file if TYPE is `file',
or if TYPE is (4), or if the cursor is before the first headline
in the file. Otherwise, only apply the restriction to the current
subtree."
(interactive "P")
(if (and org-agenda-overriding-restriction
(member org-agenda-restriction-lock-overlay
(overlays-at (point)))
(equal (overlay-start org-agenda-restriction-lock-overlay)
(point)))
(org-agenda-remove-restriction-lock 'noupdate)
(org-agenda-remove-restriction-lock 'noupdate)
(and (equal type '(4)) (setq type 'file))
(setq type (cond
(type type)
((org-at-heading-p) 'subtree)
((condition-case nil (org-back-to-heading t) (error nil))
'subtree)
(t 'file)))
(if (eq type 'subtree)
(progn
(setq org-agenda-restrict (current-buffer))
(setq org-agenda-overriding-restriction 'subtree)
(put 'org-agenda-files 'org-restrict
(list (buffer-file-name (buffer-base-buffer))))
(org-back-to-heading t)
(move-overlay org-agenda-restriction-lock-overlay
(point)
(if org-agenda-restriction-lock-highlight-subtree
(save-excursion (org-end-of-subtree t t) (point))
(line-end-position)))
(move-marker org-agenda-restrict-begin (point))
(move-marker org-agenda-restrict-end
(save-excursion (org-end-of-subtree t t)))
(message "Locking agenda restriction to subtree"))
(put 'org-agenda-files 'org-restrict
(list (buffer-file-name (buffer-base-buffer))))
(setq org-agenda-restrict t)
(setq org-agenda-overriding-restriction 'file)
(move-marker org-agenda-restrict-begin nil)
(move-marker org-agenda-restrict-end nil)
(message "Locking agenda restriction to file"))
(setq current-prefix-arg nil))
(org-agenda-maybe-redo))
(defun org-agenda-remove-restriction-lock (&optional noupdate)
"Remove agenda restriction lock."
(interactive "P")
(if (not org-agenda-restrict)
(message "No agenda restriction to remove.")
(delete-overlay org-agenda-restriction-lock-overlay)
(delete-overlay org-speedbar-restriction-lock-overlay)
(setq org-agenda-overriding-restriction nil)
(setq org-agenda-restrict nil)
(put 'org-agenda-files 'org-restrict nil)
(move-marker org-agenda-restrict-begin nil)
(move-marker org-agenda-restrict-end nil)
(setq current-prefix-arg nil)
(message "Agenda restriction lock removed")
(or noupdate (org-agenda-maybe-redo))))
(defun org-agenda-maybe-redo ()
"If there is any window showing the agenda view, update it."
(let ((w (get-buffer-window (or org-agenda-this-buffer-name
org-agenda-buffer-name)
t))
(w0 (selected-window)))
(when w
(select-window w)
(org-agenda-redo)
(select-window w0)
(if org-agenda-overriding-restriction
(message "Agenda view shifted to new %s restriction"
org-agenda-overriding-restriction)
(message "Agenda restriction lock removed")))))
;;; Agenda commands
(defun org-agenda-check-type (error &rest types)
"Check if agenda buffer or component is of allowed type.
If ERROR is non-nil, throw an error, otherwise just return nil.
Allowed types are `agenda' `todo' `tags' `search'."
(cond ((not org-agenda-type)
(error "No Org agenda currently displayed"))
((memq org-agenda-type types) t)
(error
(error "Not allowed in '%s'-type agenda buffer or component" org-agenda-type))
(t nil)))
(defun org-agenda-Quit ()
"Exit the agenda, killing the agenda buffer.
Like `org-agenda-quit', but kill the buffer even when
`org-agenda-sticky' is non-nil."
(interactive)
(org-agenda--quit))
(defun org-agenda-quit ()
"Exit the agenda.
When `org-agenda-sticky' is non-nil, bury the agenda buffer
instead of killing it.
When `org-agenda-restore-windows-after-quit' is non-nil, restore
the pre-agenda window configuration.
When column view is active, exit column view instead of the
agenda."
(interactive)
(org-agenda--quit org-agenda-sticky))
(defun org-agenda--quit (&optional bury)
(if org-agenda-columns-active
(org-columns-quit)
(let ((wconf org-agenda-pre-window-conf)
(buf (current-buffer))
(org-agenda-last-indirect-window
(and (eq org-indirect-buffer-display 'other-window)
org-agenda-last-indirect-buffer
(get-buffer-window org-agenda-last-indirect-buffer))))
(cond
((eq org-agenda-window-setup 'other-frame)
(delete-frame))
((eq org-agenda-window-setup 'other-tab)
(if (fboundp 'tab-bar-close-tab)
(tab-bar-close-tab)
(user-error "Your version of Emacs does not have tab bar mode support")))
((and org-agenda-restore-windows-after-quit
wconf)
;; Maybe restore the pre-agenda window configuration. Reset
;; `org-agenda-pre-window-conf' before running
;; `set-window-configuration', which loses the current buffer.
(setq org-agenda-pre-window-conf nil)
(set-window-configuration wconf))
(t
(when org-agenda-last-indirect-window
(delete-window org-agenda-last-indirect-window))
(and (not (eq org-agenda-window-setup 'current-window))
(not (one-window-p))
(delete-window))))
(if bury
;; Set the agenda buffer as the current buffer instead of
;; passing it as an argument to `bury-buffer' so that
;; `bury-buffer' removes it from the window.
(with-current-buffer buf
(bury-buffer))
(kill-buffer buf)
(setq org-agenda-archives-mode nil
org-agenda-buffer nil)))))
(defun org-agenda-exit ()
"Exit the agenda, killing Org buffers loaded by the agenda.
Like `org-agenda-Quit', but kill any buffers that were created by
the agenda. Org buffers visited directly by the user will not be
touched. Also, exit the agenda even if it is in column view."
(interactive)
(when org-agenda-columns-active
(org-columns-quit))
(org-release-buffers org-agenda-new-buffers)
(setq org-agenda-new-buffers nil)
(org-agenda-Quit))
(defun org-agenda-kill-all-agenda-buffers ()
"Kill all buffers in `org-agenda-mode'.
This is used when toggling sticky agendas."
(interactive)
(let (blist)
(dolist (buf (buffer-list))
(when (with-current-buffer buf (eq major-mode 'org-agenda-mode))
(push buf blist)))
(mapc #'kill-buffer blist)))
(defun org-agenda-execute (arg)
"Execute another agenda command, keeping same window.
So this is just a shortcut for \\`\\[org-agenda]', available
in the agenda."
(interactive "P")
(let ((org-agenda-window-setup 'current-window))
(org-agenda arg)))
(defun org-agenda-redo (&optional all)
"Rebuild possibly ALL agenda view(s) in the current buffer."
(interactive "P")
(defvar org-agenda-tag-filter-while-redo) ;FIXME: Where is this var used?
(let* ((p (or (and (looking-at "\\'") (1- (point))) (point)))
(cpa (unless (eq all t) current-prefix-arg))
(org-agenda-doing-sticky-redo org-agenda-sticky)
(org-agenda-sticky nil)
(org-agenda-buffer-name (or org-agenda-this-buffer-name
org-agenda-buffer-name))
(org-agenda-keep-modes t)
(tag-filter org-agenda-tag-filter)
(tag-preset (assoc-default 'tag org-agenda-filters-preset))
(top-hl-filter org-agenda-top-headline-filter)
(cat-filter org-agenda-category-filter)
(cat-preset (assoc-default 'category org-agenda-filters-preset))
(re-filter org-agenda-regexp-filter)
(re-preset (assoc-default 'regexp org-agenda-filters-preset))
(effort-filter org-agenda-effort-filter)
(effort-preset (assoc-default 'effort org-agenda-filters-preset))
(org-agenda-tag-filter-while-redo (or tag-filter tag-preset))
(cols org-agenda-columns-active)
(line (org-current-line))
(window-line (- line (org-current-line (window-start))))
(lprops (get-text-property p 'org-lprops))
(redo-cmd (get-text-property p 'org-redo-cmd))
(last-args (get-text-property p 'org-last-args))
(org-agenda-overriding-cmd (get-text-property p 'org-series-cmd))
(org-agenda-overriding-cmd-arguments
(unless (eq all t)
(cond ((listp last-args)
(cons (or cpa (car last-args)) (cdr last-args)))
((stringp last-args)
last-args))))
(series-redo-cmd (get-text-property p 'org-series-redo-cmd)))
(and cols (org-columns-quit))
(message "Rebuilding agenda buffer...")
(if series-redo-cmd
(eval series-redo-cmd t)
(cl-progv
(mapcar #'car lprops)
(mapcar (lambda (binding) (eval (cadr binding) t)) lprops)
(eval redo-cmd t))
(let ((inhibit-read-only t))
(add-text-properties (point-min) (point-max) `(org-lprops ,lprops))))
(setq org-agenda-undo-list nil
org-agenda-pending-undo-list nil
org-agenda-tag-filter tag-filter
org-agenda-category-filter cat-filter
org-agenda-regexp-filter re-filter
org-agenda-effort-filter effort-filter
org-agenda-top-headline-filter top-hl-filter)
(message "Rebuilding agenda buffer...done")
(let ((tag (or tag-filter tag-preset))
(cat (or cat-filter cat-preset))
(effort (or effort-filter effort-preset))
(re (or re-filter re-preset)))
(when tag (org-agenda-filter-apply tag 'tag t))
(when cat (org-agenda-filter-apply cat 'category))
(when effort (org-agenda-filter-apply effort 'effort))
(when re (org-agenda-filter-apply re 'regexp)))
(and top-hl-filter (org-agenda-filter-top-headline-apply top-hl-filter))
(and cols (called-interactively-p 'any) (org-agenda-columns))
(org-goto-line line)
(when (called-interactively-p 'any) (recenter window-line))))
(defun org-agenda-redo-all (&optional exhaustive)
"Rebuild all agenda views in the current buffer.
With a prefix argument, do so in all agenda buffers."
(interactive "P")
(if exhaustive
(dolist (buffer (buffer-list))
(with-current-buffer buffer
(when (derived-mode-p 'org-agenda-mode)
(org-agenda-redo t))))
(org-agenda-redo t)))
(defvar org-global-tags-completion-table nil)
(defvar org-agenda-filter-form nil)
(defvar org-agenda-filtered-by-category nil)
(defsubst org-agenda-get-category ()
"Return the category of the agenda line."
(org-get-at-bol 'org-category))
(defun org-agenda-filter-by-category (strip)
"Filter lines in the agenda buffer that have a specific category.
The category is that of the current line.
With a `\\[universal-argument]' prefix argument, exclude the lines of that category.
When there is already a category filter in place, this command removes the
filter."
(interactive "P")
(if (and org-agenda-filtered-by-category
org-agenda-category-filter)
(org-agenda-filter-show-all-cat)
(let ((cat (org-no-properties (org-agenda-get-category))))
(cond
((and cat strip)
(org-agenda-filter-apply
(push (concat "-" cat) org-agenda-category-filter) 'category))
(cat
(org-agenda-filter-apply
(setq org-agenda-category-filter
(list (concat "+" cat)))
'category))
(t (error "No category at point"))))))
(defun org-find-top-headline (&optional pos)
"Find the topmost parent headline and return it.
POS when non-nil is the marker or buffer position to start the
search from."
(save-excursion
(with-current-buffer (if (markerp pos) (marker-buffer pos) (current-buffer))
(when pos (goto-char pos))
;; Skip up to the topmost parent.
(while (org-up-heading-safe))
(ignore-errors
(replace-regexp-in-string
"^\\[[0-9]+/[0-9]+\\] *\\|^\\[%[0-9]+\\] *" ""
(nth 4 (org-heading-components)))))))
(defvar org-agenda-filtered-by-top-headline nil)
(defun org-agenda-filter-by-top-headline (strip)
"Keep only those lines that are descendants from the same top headline.
The top headline is that of the current line. With prefix arg STRIP, hide
all lines of the category at point."
(interactive "P")
(if org-agenda-filtered-by-top-headline
(progn
(setq org-agenda-filtered-by-top-headline nil
org-agenda-top-headline-filter nil)
(org-agenda-filter-show-all-top-filter))
(let ((toph (org-find-top-headline (org-get-at-bol 'org-hd-marker))))
(if toph (org-agenda-filter-top-headline-apply toph strip)
(error "No top-level headline at point")))))
(defvar org-agenda-regexp-filter nil)
(defun org-agenda-filter-by-regexp (strip-or-accumulate)
"Filter agenda entries by a regular expressions.
You will be prompted for the regular expression, and the agenda
view will only show entries that are matched by that expression.
With one `\\[universal-argument]' prefix argument, hide entries matching the regexp.
When there is already a regexp filter active, this command removed the
filter. However, with two `\\[universal-argument]' prefix arguments, add a new condition to
an already existing regexp filter."
(interactive "P")
(let* ((strip (equal strip-or-accumulate '(4)))
(accumulate (equal strip-or-accumulate '(16))))
(cond
((and org-agenda-regexp-filter (not accumulate))
(org-agenda-filter-show-all-re)
(message "Regexp filter removed"))
(t (let ((flt (concat (if strip "-" "+")
(read-from-minibuffer
(if strip
"Hide entries matching regexp: "
"Narrow to entries matching regexp: ")))))
(push flt org-agenda-regexp-filter)
(org-agenda-filter-apply org-agenda-regexp-filter 'regexp))))))
(defvar org-agenda-effort-filter nil)
(defun org-agenda-filter-by-effort (strip-or-accumulate)
"Filter agenda entries by effort.
With no `\\[universal-argument]' prefix argument, keep entries matching the effort condition.
With one `\\[universal-argument]' prefix argument, filter out entries matching the condition.
With two `\\[universal-argument]' prefix arguments, add a second condition to the existing filter.
This last option is in practice not very useful, but it is available for
consistency with the other filter commands."
(interactive "P")
(let* ((efforts (split-string
(or (cdr (assoc-string (concat org-effort-property "_ALL")
org-global-properties
t))
"0 0:10 0:30 1:00 2:00 3:00 4:00 5:00 6:00 7:00")))
;; XXX: the following handles only up to 10 different
;; effort values.
(allowed-keys (if (null efforts) nil
(mapcar (lambda (n) (mod n 10)) ;turn 10 into 0
(number-sequence 1 (length efforts)))))
(keep (equal strip-or-accumulate '(16)))
(negative (equal strip-or-accumulate '(4)))
(current org-agenda-effort-filter)
(op nil))
(while (not (memq op '(?< ?> ?= ?_)))
(setq op (read-char-exclusive
"Effort operator? (> = or <) or press `_' again to remove filter")))
;; Select appropriate duration. Ignore non-digit characters.
(if (eq op ?_)
(progn
(org-agenda-filter-show-all-effort)
(message "Effort filter removed"))
(let ((prompt
(apply #'format
(concat "Effort %c "
(mapconcat (lambda (s) (concat "[%d]" s))
efforts
" "))
op allowed-keys))
(eff -1))
(while (not (memq eff allowed-keys))
(message prompt)
(setq eff (- (read-char-exclusive) 48)))
(org-agenda-filter-show-all-effort)
(setq org-agenda-effort-filter
(append
(list (concat (if negative "-" "+")
(char-to-string op)
;; Numbering is 1 2 3 ... 9 0, but we want
;; 0 1 2 ... 8 9.
(nth (mod (1- eff) 10) efforts)))
(if keep current nil)))
(org-agenda-filter-apply org-agenda-effort-filter 'effort)))))
(defun org-agenda-filter (&optional strip-or-accumulate)
"Prompt for a general filter string and apply it to the agenda.
The string may contain filter elements like
+category
+tag
+ and = are also allowed as effort operators
+/regexp/
Instead of `+', `-' is allowed to strip the agenda of matching entries.
`+' is optional if it is not required to separate two string parts.
Multiple filter elements can be concatenated without spaces, for example
+work-John<0:10-/plot/
selects entries with category `work' and effort estimates below 10 minutes,
and deselects entries with tag `John' or matching the regexp `plot'.
During entry of the filter, completion for tags, categories and effort
values is offered. Since the syntax for categories and tags is identical
there should be no overlap between categories and tags. If there is, tags
get priority.
A single `\\[universal-argument]' prefix arg STRIP-OR-ACCUMULATE will negate the
entire filter, which can be useful in connection with the prompt history.
A double `\\[universal-argument] \\[universal-argument]' prefix arg will add the new filter elements to the
existing ones. A shortcut for this is to add an additional `+' at the
beginning of the string, like `+-John'.
With a triple prefix argument, execute the computed filtering defined in
the variable `org-agenda-auto-exclude-function'."
(interactive "P")
(if (equal strip-or-accumulate '(64))
;; Execute the auto-exclude action
(if (not org-agenda-auto-exclude-function)
(user-error "`org-agenda-auto-exclude-function' is undefined")
(org-agenda-filter-show-all-tag)
(setq org-agenda-tag-filter nil)
(dolist (tag (org-agenda-get-represented-tags))
(let ((modifier (funcall org-agenda-auto-exclude-function tag)))
(when modifier
(push modifier org-agenda-tag-filter))))
(unless (null org-agenda-tag-filter)
(org-agenda-filter-apply org-agenda-tag-filter 'tag 'expand)))
;; Prompt for a filter and act
(let* ((tag-list (org-agenda-get-represented-tags))
(category-list (org-agenda-get-represented-categories))
(negate (equal strip-or-accumulate '(4)))
(cf (mapconcat #'identity org-agenda-category-filter ""))
(tf (mapconcat #'identity org-agenda-tag-filter ""))
;; (rpl-fn (lambda (c) (replace-regexp-in-string "^\\+" "" (or (car c) ""))))
(ef (replace-regexp-in-string "^\\+" "" (or (car org-agenda-effort-filter) "")))
(rf (replace-regexp-in-string "^\\+" "" (or (car org-agenda-regexp-filter) "")))
(ff (concat cf tf ef (when (not (equal rf "")) (concat "/" rf "/"))))
(f-string (completing-read
(concat
(if negate "Negative filter" "Filter")
" [+cat-tag<0:10-/regexp/]: ")
#'org-agenda-filter-completion-function
nil nil ff))
(keep (or (if (string-match "^\\+[+-]" f-string)
(progn (setq f-string (substring f-string 1)) t))
(equal strip-or-accumulate '(16))))
(fc (if keep org-agenda-category-filter))
(ft (if keep org-agenda-tag-filter))
(fe (if keep org-agenda-effort-filter))
(fr (if keep org-agenda-regexp-filter))
pm s)
;; If the filter contains a double-quoted string, replace a
;; single hyphen by the arbitrary and temporary string "~~~"
;; to disambiguate such hyphens from syntactic ones.
(setq f-string (replace-regexp-in-string
"\"\\([^\"]*\\)-\\([^\"]*\\)\"" "\"\\1~~~\\2\"" f-string))
(while (string-match "^[ \t]*\\([-+]\\)?\\(\\([^-+<>=/ \t]+\\)\\|\\([<>=][0-9:]+\\)\\|\\(/\\([^/]+\\)/?\\)\\)" f-string)
(setq pm (if (match-beginning 1) (match-string 1 f-string) "+"))
(when negate
(setq pm (if (equal pm "+") "-" "+")))
(cond
((match-beginning 3)
;; category or tag
(setq s (replace-regexp-in-string ; Remove the temporary special string.
"~~~" "-" (match-string 3 f-string)))
(cond
((member s tag-list)
(org-pushnew-to-end (concat pm s) ft))
((member s category-list)
(org-pushnew-to-end (concat pm ; Remove temporary double quotes.
(replace-regexp-in-string "\"\\(.*\\)\"" "\\1" s))
fc))
(t (message
"`%s%s' filter ignored because tag/category is not represented"
pm s))))
((match-beginning 4)
;; effort
(org-pushnew-to-end (concat pm (match-string 4 f-string)) fe))
((match-beginning 5)
;; regexp
(org-pushnew-to-end (concat pm (match-string 6 f-string)) fr)))
(setq f-string (substring f-string (match-end 0))))
(org-agenda-filter-remove-all)
(and fc (org-agenda-filter-apply
(setq org-agenda-category-filter fc) 'category))
(and ft (org-agenda-filter-apply
(setq org-agenda-tag-filter ft) 'tag 'expand))
(and fe (org-agenda-filter-apply
(setq org-agenda-effort-filter fe) 'effort))
(and fr (org-agenda-filter-apply
(setq org-agenda-regexp-filter fr) 'regexp))
(run-hooks 'org-agenda-filter-hook))))
(defun org-agenda-filter-completion-function (string _predicate &optional flag)
"Complete a complex filter string.
FLAG specifies the type of completion operation to perform. This
function is passed as a collection function to `completing-read',
which see."
(let ((completion-ignore-case t) ;tags are case-sensitive
(confirm (lambda (x) (stringp x)))
(prefix "")
(operator "")
table
begin)
(when (string-match "^\\(.*\\([-+<>=]\\)\\)\\([^-+<>=]*\\)$" string)
(setq prefix (match-string 1 string)
operator (match-string 2 string)
begin (match-beginning 3)
string (match-string 3 string)))
(cond
((member operator '("+" "-" "" nil))
(setq table (append (org-agenda-get-represented-categories)
(org-agenda-get-represented-tags))))
((member operator '("<" ">" "="))
(setq table (split-string
(or (cdr (assoc-string (concat org-effort-property "_ALL")
org-global-properties
t))
"0 0:10 0:30 1:00 2:00 3:00 4:00 5:00 6:00 7:00")
" +")))
(t (setq table nil)))
(pcase flag
(`t (all-completions string table confirm))
(`lambda (assoc string table)) ;exact match?
(`(boundaries . ,suffix)
(let ((end (if (string-match "[-+<>=]" suffix)
(match-string 0 suffix)
(length suffix))))
`(boundaries ,(or begin 0) . ,end)))
(`nil
(pcase (try-completion string table confirm)
((and completion (pred stringp))
(concat prefix completion))
(completion completion)))
(_ nil))))
(defun org-agenda-filter-remove-all ()
"Remove all filters from the current agenda buffer."
(interactive)
(when org-agenda-tag-filter
(org-agenda-filter-show-all-tag))
(when org-agenda-category-filter
(org-agenda-filter-show-all-cat))
(when org-agenda-regexp-filter
(org-agenda-filter-show-all-re))
(when org-agenda-top-headline-filter
(org-agenda-filter-show-all-top-filter))
(when org-agenda-effort-filter
(org-agenda-filter-show-all-effort))
(org-agenda-finalize)
(when (called-interactively-p 'interactive)
(message "All agenda filters removed")))
(defun org-agenda-filter-by-tag (strip-or-accumulate &optional char exclude)
"Keep only those lines in the agenda buffer that have a specific tag.
The tag is selected with its fast selection letter, as configured.
With a `\\[universal-argument]' prefix, apply the filter negatively, stripping all matches.
With a `\\[universal-argument] \\[universal-argument]' prefix, add the new tag to the existing filter
instead of replacing it.
With a `\\[universal-argument] \\[universal-argument] \\[universal-argument]' prefix, filter the literal tag, \
i.e. don't
filter on all its group members.
A Lisp caller can specify CHAR. EXCLUDE means that the new tag
should be used to exclude the search - the interactive user can
also press `-' or `+' to switch between filtering and excluding."
(interactive "P")
(let* ((alist org-tag-alist-for-agenda)
(seen-chars nil)
(tag-chars (mapconcat
(lambda (x) (if (and (not (symbolp (car x)))
(cdr x)
(not (member (cdr x) seen-chars)))
(progn
(push (cdr x) seen-chars)
(char-to-string (cdr x)))
""))
org-tag-alist-for-agenda ""))
(valid-char-list (append '(?\t ?\r ?\\ ?. ?\s ?q)
(string-to-list tag-chars)))
(exclude (or exclude (equal strip-or-accumulate '(4))))
(accumulate (equal strip-or-accumulate '(16)))
(expand (not (equal strip-or-accumulate '(64))))
(inhibit-read-only t)
(current org-agenda-tag-filter)
a tag) ;; n
(unless char
(while (not (memq char valid-char-list))
(org-unlogged-message
"%s by tag%s: [%s ]tag-char [TAB]tag %s[\\]off [q]uit"
(if exclude "Exclude[+]" "Filter[-]")
(if expand "" " (no grouptag expand)")
tag-chars
(if org-agenda-auto-exclude-function "[RET] " ""))
(setq char (read-char-exclusive))
;; Excluding or filtering down
(cond ((eq char ?-) (setq exclude t))
((eq char ?+) (setq exclude nil)))))
(when (eq char ?\t)
(unless (local-variable-p 'org-global-tags-completion-table)
(setq-local org-global-tags-completion-table
(org-global-tags-completion-table)))
(let ((completion-ignore-case t))
(setq tag (completing-read
"Tag: " org-global-tags-completion-table nil t))))
(cond
((eq char ?\r)
(org-agenda-filter-show-all-tag)
(when org-agenda-auto-exclude-function
(setq org-agenda-tag-filter nil)
(dolist (tag (org-agenda-get-represented-tags))
(let ((modifier (funcall org-agenda-auto-exclude-function tag)))
(when modifier
(push modifier org-agenda-tag-filter))))
(unless (null org-agenda-tag-filter)
(org-agenda-filter-apply org-agenda-tag-filter 'tag expand))))
((eq char ?\\)
(org-agenda-filter-show-all-tag)
(when (assoc-default 'tag org-agenda-filters-preset)
(org-agenda-filter-apply org-agenda-tag-filter 'tag expand)))
((eq char ?.)
(setq org-agenda-tag-filter
(mapcar (lambda(tag) (concat "+" tag))
(org-get-at-bol 'tags)))
(org-agenda-filter-apply org-agenda-tag-filter 'tag expand))
((eq char ?q)) ;If q, abort (even if there is a q-key for a tag...)
((or (eq char ?\s)
(setq a (rassoc char alist))
(and tag (setq a (cons tag nil))))
(org-agenda-filter-show-all-tag)
(setq tag (car a))
(setq org-agenda-tag-filter
(cons (concat (if exclude "-" "+") tag)
(if accumulate current nil)))
(org-agenda-filter-apply org-agenda-tag-filter 'tag expand))
(t (error "Invalid tag selection character %c" char)))))
(defun org-agenda-get-represented-categories ()
"Return a list of all categories used in this agenda buffer."
(or org-agenda-represented-categories
(when (derived-mode-p 'org-agenda-mode)
(let ((pos (point-min)) categories)
(while (and (< pos (point-max))
(setq pos (next-single-property-change
pos 'org-category nil (point-max))))
(push (get-text-property pos 'org-category) categories))
(setq org-agenda-represented-categories
;; Enclose category names with a hyphen in double
;; quotes to process them specially in `org-agenda-filter'.
(mapcar (lambda (s) (if (string-match-p "-" s) (format "\"%s\"" s) s))
(nreverse (org-uniquify (delq nil categories)))))))))
(defvar org-tag-groups-alist-for-agenda)
(defun org-agenda-get-represented-tags ()
"Return a list of all tags used in this agenda buffer.
These will be lower-case, for filtering."
(or org-agenda-represented-tags
(when (derived-mode-p 'org-agenda-mode)
(let ((pos (point-min)) tags-lists tt)
(while (and (< pos (point-max))
(setq pos (next-single-property-change
pos 'tags nil (point-max))))
(setq tt (get-text-property pos 'tags))
(if tt (push tt tags-lists)))
(setq tags-lists
(nreverse (org-uniquify
(delq nil (apply #'append tags-lists)))))
(dolist (tag tags-lists)
(mapc
(lambda (group)
(when (member tag group)
(push (car group) tags-lists)))
org-tag-groups-alist-for-agenda))
(setq org-agenda-represented-tags tags-lists)))))
(defun org-agenda-filter-make-matcher (filter type &optional expand)
"Create the form that tests a line for agenda filter.
Optional argument EXPAND can be used for the TYPE tag and will
expand the tags in the FILTER if any of the tags in FILTER are
grouptags."
(let ((multi-pos-cats
(and (eq type 'category)
(string-match-p "\\+.*\\+"
(mapconcat (lambda (cat) (substring cat 0 1))
filter ""))))
f f1)
(cond
;; Tag filter
((eq type 'tag)
(setq filter
(delete-dups
(append (assoc-default 'tag org-agenda-filters-preset)
filter)))
(dolist (x filter)
(let ((op (string-to-char x)))
(if expand (setq x (org-agenda-filter-expand-tags (list x) t))
(setq x (list x)))
(setq f1 (org-agenda-filter-make-matcher-tag-exp x op))
(push f1 f))))
;; Category filter
((eq type 'category)
(setq filter
(delete-dups
(append (assoc-default 'category org-agenda-filters-preset)
filter)))
(dolist (x filter)
(if (equal "-" (substring x 0 1))
(setq f1 (list 'not (list 'equal (substring x 1) 'cat)))
(setq f1 (list 'equal (substring x 1) 'cat)))
(push f1 f)))
;; Regexp filter
((eq type 'regexp)
(setq filter
(delete-dups
(append (assoc-default 'regexp org-agenda-filters-preset)
filter)))
(dolist (x filter)
(if (equal "-" (substring x 0 1))
(setq f1 (list 'not (list 'string-match (substring x 1) 'txt)))
(setq f1 (list 'string-match (substring x 1) 'txt)))
(push f1 f)))
;; Effort filter
((eq type 'effort)
(setq filter
(delete-dups
(append (assoc-default 'effort org-agenda-filters-preset)
filter)))
(dolist (x filter)
(push (org-agenda-filter-effort-form x) f))))
(cons (if multi-pos-cats 'or 'and) (nreverse f))))
(defun org-agenda-filter-make-matcher-tag-exp (tags op)
"Return a form associated to tag-expression TAGS.
Build a form testing a line for agenda filter for
tag-expressions. OP is an operator of type CHAR that allows the
function to set the right switches in the returned form."
(let (form)
;; Any of the expressions can match if OP is +, all must match if
;; the operator is -.
(dolist (x tags (cons (if (eq op ?-) 'and 'or) form))
(let* ((tag (substring x 1))
(f (cond
((string= "" tag) 'tags)
((and (string-match-p "\\`{" tag) (string-match-p "}\\'" tag))
;; TAG is a regexp.
(list 'org-match-any-p (substring tag 1 -1) 'tags))
(t (list 'member tag 'tags)))))
(push (if (eq op ?-) (list 'not f) f) form)))))
(defun org-agenda-filter-effort-form (e)
"Return the form to compare the effort of the current line with what E says.
E looks like \"+<2:25\"."
(let (op)
(setq e (substring e 1))
(setq op (string-to-char e) e (substring e 1))
(setq op (cond ((equal op ?<) '<=)
((equal op ?>) '>=)
((equal op ??) op)
(t '=)))
(list 'org-agenda-compare-effort (list 'quote op)
(org-duration-to-minutes e))))
(defun org-agenda-compare-effort (op value)
"Compare the effort of the current line with VALUE, using OP.
If the line does not have an effort defined, return nil."
;; `effort-minutes' property cannot be extracted directly from
;; current line but is stored as a property in `txt'.
(let ((effort (get-text-property 0 'effort-minutes (org-get-at-bol 'txt))))
(funcall op
(or effort (if org-agenda-sort-noeffort-is-high 32767 -1))
value)))
(defun org-agenda-filter-expand-tags (filter &optional no-operator)
"Expand group tags in FILTER for the agenda.
When NO-OPERATOR is non-nil, do not add the + operator to
returned tags."
(if org-group-tags
(let (case-fold-search rtn)
(mapc
(lambda (f)
(let (f0 dir)
(if (string-match "^\\([+-]\\)\\(.+\\)" f)
(setq dir (match-string 1 f) f0 (match-string 2 f))
(setq dir (if no-operator "" "+") f0 f))
(setq rtn (append (mapcar (lambda(f1) (concat dir f1))
(org-tags-expand f0 t))
rtn))))
filter)
(reverse rtn))
filter))
(defun org-agenda-filter-apply (filter type &optional expand)
"Set FILTER as the new agenda filter and apply it.
Optional argument EXPAND can be used for the TYPE tag and will
expand the tags in the FILTER if any of the tags in FILTER are
grouptags."
;; Deactivate `org-agenda-entry-text-mode' when filtering
(when org-agenda-entry-text-mode (org-agenda-entry-text-mode))
(setq org-agenda-filter-form (org-agenda-filter-make-matcher
filter type expand))
;; Only set `org-agenda-filtered-by-category' to t when a unique
;; category is used as the filter:
(setq org-agenda-filtered-by-category
(and (eq type 'category)
(not (equal (substring (car filter) 0 1) "-"))))
(org-agenda-set-mode-name)
(save-excursion
(goto-char (point-min))
(while (not (eobp))
(when (or (org-get-at-bol 'org-hd-marker)
(org-get-at-bol 'org-marker))
(org-dlet
((tags (org-get-at-bol 'tags))
(cat (org-agenda-get-category))
(txt (or (org-get-at-bol 'txt) "")))
(unless (eval org-agenda-filter-form t)
(org-agenda-filter-hide-line type))))
(forward-line 1)))
(when (get-char-property (point) 'invisible)
(ignore-errors (org-agenda-previous-line))))
(defun org-agenda-filter-top-headline-apply (hl &optional negative)
"Filter by top headline HL."
(org-agenda-set-mode-name)
(save-excursion
(goto-char (point-min))
(while (not (eobp))
(let* ((pos (org-get-at-bol 'org-hd-marker))
(tophl (and pos (org-find-top-headline pos))))
(when (and tophl (funcall (if negative 'identity 'not)
(string= hl tophl)))
(org-agenda-filter-hide-line 'top-headline)))
(forward-line 1)))
(when (get-char-property (point) 'invisible)
(org-agenda-previous-line))
(setq org-agenda-top-headline-filter hl
org-agenda-filtered-by-top-headline t))
(defun org-agenda-filter-hide-line (type)
"If current line is TYPE, hide it in the agenda buffer."
(let* (buffer-invisibility-spec
(beg (max (point-min) (1- (line-beginning-position))))
(end (line-end-position)))
(let ((inhibit-read-only t))
(add-text-properties
beg end `(invisible org-filtered org-filter-type ,type)))))
(defun org-agenda-remove-filter (type)
"Remove filter of type TYPE from the agenda buffer."
(interactive)
(save-excursion
(goto-char (point-min))
(let ((inhibit-read-only t) pos)
(while (setq pos (text-property-any (point) (point-max)
'org-filter-type type))
(goto-char pos)
(remove-text-properties
(point) (next-single-property-change (point) 'org-filter-type)
`(invisible org-filtered org-filter-type ,type))))
(set (intern (format "org-agenda-%s-filter" (intern-soft type))) nil)
(setq org-agenda-filter-form nil)
(org-agenda-set-mode-name)
(org-agenda-finalize)))
(defun org-agenda-filter-show-all-tag nil
(org-agenda-remove-filter 'tag))
(defun org-agenda-filter-show-all-re nil
(org-agenda-remove-filter 'regexp))
(defun org-agenda-filter-show-all-effort nil
(org-agenda-remove-filter 'effort))
(defun org-agenda-filter-show-all-cat nil
(org-agenda-remove-filter 'category))
(defun org-agenda-filter-show-all-top-filter nil
(org-agenda-remove-filter 'top-headline))
(defun org-agenda-manipulate-query-add ()
"Manipulate the query by adding a search term with positive selection.
Positive selection means the term must be matched for selection of an entry."
(interactive)
(org-agenda-manipulate-query ?\[))
(defun org-agenda-manipulate-query-subtract ()
"Manipulate the query by adding a search term with negative selection.
Negative selection means term must not be matched for selection of an entry."
(interactive)
(org-agenda-manipulate-query ?\]))
(defun org-agenda-manipulate-query-add-re ()
"Manipulate the query by adding a search regexp with positive selection.
Positive selection means the regexp must match for selection of an entry."
(interactive)
(org-agenda-manipulate-query ?\{))
(defun org-agenda-manipulate-query-subtract-re ()
"Manipulate the query by adding a search regexp with negative selection.
Negative selection means regexp must not match for selection of an entry."
(interactive)
(org-agenda-manipulate-query ?\}))
(defun org-agenda-manipulate-query (char)
(cond
((eq org-agenda-type 'agenda)
(let ((org-agenda-include-inactive-timestamps t))
(org-agenda-redo))
(message "Display now includes inactive timestamps as well"))
((eq org-agenda-type 'search)
;; Previous calls to `org-agenda-manipulate-query' could already
;; add trailing text to the query. Prevent duplicating it.
;; Trim the trailing spaces and +/.
(setq org-agenda-query-string
(replace-regexp-in-string
(rx (or (1+ " ") (seq (1+ " ") (any "+-") (opt "{}"))) eos)
""
org-agenda-query-string))
(org-add-to-string
'org-agenda-query-string
(if org-agenda-last-search-view-search-was-boolean
(cdr (assoc char '((?\[ . " +") (?\] . " -")
(?\{ . " +{}") (?\} . " -{}"))))
" "))
(setq org-agenda-redo-command
(list 'org-search-view
(car (get-text-property (min (1- (point-max)) (point))
'org-last-args))
org-agenda-query-string
(+ (length org-agenda-query-string)
(if (member char '(?\{ ?\})) 0 1))))
(set-register org-agenda-query-register org-agenda-query-string)
(let ((org-agenda-overriding-arguments
(cdr org-agenda-redo-command)))
(org-agenda-redo)))
(t (error "Cannot manipulate query for %s-type agenda buffers"
org-agenda-type))))
(defun org-add-to-string (var string)
(set var (concat (symbol-value var) string)))
(defun org-agenda-goto-date (date)
"Jump to DATE in the agenda buffer.
When called interactively, prompt for the date.
When called from Lisp, DATE should be a date as returned by
`org-read-date'.
See also:
`org-agenda-earlier' (\\[org-agenda-earlier])
`org-agenda-later' (\\[org-agenda-later])
`org-agenda-goto-today' (\\[org-agenda-goto-today])"
(interactive
(list
(let ((org-read-date-prefer-future org-agenda-jump-prefer-future))
(org-read-date))))
(org-agenda-check-type t 'agenda)
(let* ((day (time-to-days (org-time-string-to-time date)))
(org-agenda-sticky-orig org-agenda-sticky)
(org-agenda-buffer-tmp-name (buffer-name))
(args (get-text-property (min (1- (point-max)) (point))
'org-last-args))
(0-arg (or current-prefix-arg (car args)))
(2-arg (nth 2 args))
(with-hour-p (nth 4 org-agenda-redo-command))
(newcmd (list 'org-agenda-list 0-arg date
(org-agenda-span-to-ndays
2-arg (org-time-string-to-absolute date))
with-hour-p))
(newargs (cdr newcmd))
(inhibit-read-only t)
org-agenda-sticky)
(add-text-properties (point-min) (point-max)
`(org-redo-cmd ,newcmd org-last-args ,newargs))
(org-agenda-redo)
(goto-char (point-min))
(while (not (or (= (or (get-text-property (point) 'day) 0) day)
(save-excursion (move-beginning-of-line 2) (eobp))))
(move-beginning-of-line 2))
(setq org-agenda-sticky org-agenda-sticky-orig
org-agenda-this-buffer-is-sticky org-agenda-sticky)))
(defun org-agenda-goto-today ()
"Go to today's date in the agenda buffer.
See also:
`org-agenda-later' (\\[org-agenda-later])
`org-agenda-earlier' (\\[org-agenda-earlier])
`org-agenda-goto-date' (\\[org-agenda-goto-date])"
(interactive)
(org-agenda-check-type t 'agenda)
(let* ((args (get-text-property (min (1- (point-max)) (point)) 'org-last-args))
(curspan (nth 2 args))
(tdpos (text-property-any (point-min) (point-max) 'org-today t)))
(cond
(tdpos (goto-char tdpos))
((eq org-agenda-type 'agenda)
(let* ((sd (org-agenda-compute-starting-span
(org-today) (or curspan org-agenda-span)))
(org-agenda-overriding-arguments args))
(setf (nth 1 org-agenda-overriding-arguments) sd)
(org-agenda-redo)
(org-agenda-find-same-or-today-or-agenda)))
(t (error "Cannot find today")))))
(defun org-agenda-find-same-or-today-or-agenda (&optional cnt)
(goto-char
(or (and cnt (text-property-any (point-min) (point-max) 'org-day-cnt cnt))
(text-property-any (point-min) (point-max) 'org-today t)
(text-property-any (point-min) (point-max) 'org-agenda-type 'agenda)
(and (get-text-property (min (1- (point-max)) (point)) 'org-series)
(org-agenda-backward-block))
(point-min))))
(defun org-agenda-backward-block ()
"Move backward by one agenda block."
(interactive)
(org-agenda-forward-block 'backward))
(defun org-agenda-forward-block (&optional backward)
"Move forward by one agenda block.
When optional argument BACKWARD is set, go backward."
(interactive)
(cond ((not (derived-mode-p 'org-agenda-mode))
(user-error
"Cannot execute this command outside of org-agenda-mode buffers"))
((looking-at (if backward "\\`" "\\'"))
(message "Already at the %s block" (if backward "first" "last")))
(t (let ((_pos (prog1 (point)
(ignore-errors (if backward (backward-char 1)
(move-end-of-line 1)))))
(f (if backward
#'previous-single-property-change
#'next-single-property-change))
moved dest)
(while (and (setq dest (funcall
f (point) 'org-agenda-structural-header))
(not (get-text-property
(point) 'org-agenda-structural-header)))
(setq moved t)
(goto-char dest))
(if moved (move-beginning-of-line 1)
(goto-char (if backward (point-min) (point-max)))
(move-beginning-of-line 1)
(message "No %s block" (if backward "previous" "further")))))))
(defun org-agenda-later (arg)
"Go forward in time by the current span in the agenda buffer.
With prefix ARG, go forward that many times the current span.
See also:
`org-agenda-earlier' (\\[org-agenda-earlier])
`org-agenda-goto-today' (\\[org-agenda-goto-today])
`org-agenda-goto-date' (\\[org-agenda-goto-date])"
(interactive "p")
(org-agenda-check-type t 'agenda)
(let* ((wstart (window-start))
(args (get-text-property (min (1- (point-max)) (point)) 'org-last-args))
(span (or (nth 2 args) org-agenda-current-span))
(sd (or (nth 1 args) (org-get-at-bol 'day) org-starting-day))
(greg (calendar-gregorian-from-absolute sd))
(cnt (org-get-at-bol 'org-day-cnt))
greg2)
(cond
((numberp span)
(setq sd (+ (* span arg) sd)))
((eq span 'day)
(setq sd (+ arg sd)))
((eq span 'week)
(setq sd (+ (* 7 arg) sd)))
((eq span 'fortnight)
(setq sd (+ (* 14 arg) sd)))
((eq span 'month)
(setq greg2 (list (+ (car greg) arg) (nth 1 greg) (nth 2 greg))
sd (calendar-absolute-from-gregorian greg2))
(setcar greg2 (1+ (car greg2))))
((eq span 'year)
(setq greg2 (list (car greg) (nth 1 greg) (+ arg (nth 2 greg)))
sd (calendar-absolute-from-gregorian greg2))
(setcar (nthcdr 2 greg2) (1+ (nth 2 greg2))))
(t
(setq sd (+ (* span arg) sd))))
(let ((org-agenda-overriding-cmd
;; `cmd' may have been set by `org-agenda-run-series' which
;; uses `org-agenda-overriding-cmd' to decide whether
;; overriding is allowed for `cmd'
(get-text-property (min (1- (point-max)) (point)) 'org-series-cmd))
(org-agenda-overriding-arguments
(list (car args) sd span)))
(org-agenda-redo)
(org-agenda-find-same-or-today-or-agenda cnt))
(set-window-start nil wstart)))
(defun org-agenda-earlier (arg)
"Go backward in time by the current span in the agenda buffer.
With prefix ARG, go backward that many times the current span.
See also:
`org-agenda-later' (\\[org-agenda-later])
`org-agenda-goto-today' (\\[org-agenda-goto-today])
`org-agenda-goto-date' (\\[org-agenda-goto-date])"
(interactive "p")
(org-agenda-later (- arg)))
(defun org-agenda-view-mode-dispatch ()
"Call one of the view mode commands."
(interactive)
(org-unlogged-message
"View: [d]ay [w]eek for[t]night [m]onth [y]ear [SPC]reset [q]uit/abort
time[G]rid [[]inactive [f]ollow [l]og [L]og-all [c]lockcheck
[a]rch-trees [A]rch-files clock[R]eport include[D]iary [E]ntryText")
(pcase (read-char-exclusive)
(?\ (call-interactively 'org-agenda-reset-view))
(?d (call-interactively 'org-agenda-day-view))
(?w (call-interactively 'org-agenda-week-view))
(?t (call-interactively 'org-agenda-fortnight-view))
(?m (call-interactively 'org-agenda-month-view))
(?y (call-interactively 'org-agenda-year-view))
(?l (call-interactively 'org-agenda-log-mode))
(?L (org-agenda-log-mode '(4)))
(?c (org-agenda-log-mode 'clockcheck))
((or ?F ?f) (call-interactively 'org-agenda-follow-mode))
(?a (call-interactively 'org-agenda-archives-mode))
(?A (org-agenda-archives-mode 'files))
((or ?R ?r) (call-interactively 'org-agenda-clockreport-mode))
((or ?E ?e) (call-interactively 'org-agenda-entry-text-mode))
(?G (call-interactively 'org-agenda-toggle-time-grid))
(?D (call-interactively 'org-agenda-toggle-diary))
(?\! (call-interactively 'org-agenda-toggle-deadlines))
(?\[ (let ((org-agenda-include-inactive-timestamps t))
(org-agenda-check-type t 'agenda)
(org-agenda-redo))
(message "Display now includes inactive timestamps as well"))
(?q (message "Abort"))
(key (user-error "Invalid key: %s" key))))
(defun org-agenda-reset-view ()
"Switch to default view for agenda."
(interactive)
(org-agenda-change-time-span org-agenda-span))
(defun org-agenda-day-view (&optional day-of-month)
"Switch to daily view for agenda.
With argument DAY-OF-MONTH, switch to that day of the month."
(interactive "P")
(org-agenda-change-time-span 'day day-of-month))
(defun org-agenda-week-view (&optional iso-week)
"Switch to weekly view for agenda.
With argument ISO-WEEK, switch to the corresponding ISO week.
If ISO-WEEK has more then 2 digits, only the last two encode
the week. Any digits before this encode a year. So 200712
means week 12 of year 2007. Years ranging from 70 years ago
to 30 years in the future can also be written as 2-digit years."
(interactive "P")
(org-agenda-change-time-span 'week iso-week))
(defun org-agenda-fortnight-view (&optional iso-week)
"Switch to fortnightly view for agenda.
With argument ISO-WEEK, switch to the corresponding ISO week.
If ISO-WEEK has more then 2 digits, only the last two encode
the week. Any digits before this encode a year. So 200712
means week 12 of year 2007. Years ranging from 70 years ago
to 30 years in the future can also be written as 2-digit years."
(interactive "P")
(org-agenda-change-time-span 'fortnight iso-week))
(defun org-agenda-month-view (&optional month)
"Switch to monthly view for agenda.
With argument MONTH, switch to that month. If MONTH has more
then 2 digits, only the last two encode the month. Any digits
before this encode a year. So 200712 means December year 2007.
Years ranging from 70 years ago to 30 years in the future can
also be written as 2-digit years."
(interactive "P")
(org-agenda-change-time-span 'month month))
(defun org-agenda-year-view (&optional year)
"Switch to yearly view for agenda.
With argument YEAR, switch to that year. Years ranging from 70
years ago to 30 years in the future can also be written as
2-digit years."
(interactive "P")
(when year
(setq year (org-small-year-to-year year)))
(if (y-or-n-p "Are you sure you want to compute the agenda for an entire year? ")
(org-agenda-change-time-span 'year year)
(error "Abort")))
(defun org-agenda-change-time-span (span &optional n)
"Change the agenda view to SPAN.
SPAN may be `day', `week', `fortnight', `month', `year'."
(org-agenda-check-type t 'agenda)
(let* ((args (get-text-property (min (1- (point-max)) (point)) 'org-last-args))
(curspan (nth 2 args)))
(when (and (not n) (equal curspan span))
(error "Viewing span is already \"%s\"" span))
(let* ((sd (or (org-get-at-bol 'day)
(nth 1 args)
org-starting-day))
(sd (org-agenda-compute-starting-span sd span n))
(org-agenda-overriding-cmd
(get-text-property (min (1- (point-max)) (point)) 'org-series-cmd))
(org-agenda-overriding-arguments
(list (car args) sd span)))
(org-agenda-redo)
(org-agenda-find-same-or-today-or-agenda))
(org-agenda-set-mode-name)
(message "Switched to %s view" span)))
(defun org-agenda-compute-starting-span (sd span &optional n)
"Compute starting date for agenda.
SPAN may be `day', `week', `fortnight', `month', `year'. The return value
is a cons cell with the starting date and the number of days,
so that the date SD will be in that range."
(let* ((greg (calendar-gregorian-from-absolute sd))
;; (dg (nth 1 greg))
(mg (car greg))
(yg (nth 2 greg)))
(cond
((eq span 'day)
(when n
(setq sd (+ (calendar-absolute-from-gregorian
(list mg 1 yg))
n -1))))
((or (eq span 'week) (eq span 'fortnight))
(let* ((nt (calendar-day-of-week
(calendar-gregorian-from-absolute sd)))
(d (if org-agenda-start-on-weekday
(- nt org-agenda-start-on-weekday)
0))
y1)
(setq sd (- sd (+ (if (< d 0) 7 0) d)))
(when n
(require 'cal-iso)
(when (> n 99)
(setq y1 (org-small-year-to-year (/ n 100))
n (mod n 100)))
(setq sd
(calendar-iso-to-absolute
(list n 1
(or y1 (nth 2 (calendar-iso-from-absolute sd)))))))))
((eq span 'month)
(let (y1)
(when (and n (> n 99))
(setq y1 (org-small-year-to-year (/ n 100))
n (mod n 100)))
(setq sd (calendar-absolute-from-gregorian
(list (or n mg) 1 (or y1 yg))))))
((eq span 'year)
(setq sd (calendar-absolute-from-gregorian
(list 1 1 (or n yg))))))
sd))
(defun org-agenda-next-date-line (&optional arg)
"Jump to the next line indicating a date in agenda buffer."
(interactive "p")
(org-agenda-check-type t 'agenda)
(forward-line 0)
;; This does not work if user makes date format that starts with a blank
(when (looking-at-p "^\\S-") (forward-char 1))
(unless (re-search-forward "^\\S-" nil t arg)
(backward-char 1)
(error "No next date after this line in this buffer"))
(goto-char (match-beginning 0)))
(defun org-agenda-previous-date-line (&optional arg)
"Jump to the previous line indicating a date in agenda buffer."
(interactive "p")
(org-agenda-check-type t 'agenda)
(forward-line 0)
(unless (re-search-backward "^\\S-" nil t arg)
(error "No previous date before this line in this buffer")))
;; Initialize the highlight
(defvar org-hl (make-overlay 1 1))
(overlay-put org-hl 'face 'highlight)
(defun org-highlight (begin end &optional buffer)
"Highlight a region with overlay."
(move-overlay org-hl begin end (or buffer (current-buffer))))
(defun org-unhighlight ()
"Detach overlay INDEX."
(delete-overlay org-hl))
(defun org-unhighlight-once ()
"Remove the highlight from its position, and this function from the hook."
(remove-hook 'pre-command-hook #'org-unhighlight-once)
(org-unhighlight))
(defvar org-agenda-pre-follow-window-conf nil)
(defun org-agenda-follow-mode ()
"Toggle follow mode in an agenda buffer."
(interactive)
(unless org-agenda-follow-mode
(setq org-agenda-pre-follow-window-conf
(current-window-configuration)))
(setq org-agenda-follow-mode (not org-agenda-follow-mode))
(unless org-agenda-follow-mode
(set-window-configuration org-agenda-pre-follow-window-conf))
(org-agenda-set-mode-name)
(org-agenda-do-context-action)
(message "Follow mode is %s"
(if org-agenda-follow-mode "on" "off")))
(defun org-agenda-entry-text-mode (&optional arg)
"Toggle entry text mode in an agenda buffer."
(interactive "P")
(if (or org-agenda-tag-filter
org-agenda-category-filter
org-agenda-regexp-filter
org-agenda-top-headline-filter)
(user-error "Can't show entry text in filtered views")
(setq org-agenda-entry-text-mode (or (integerp arg)
(not org-agenda-entry-text-mode)))
(org-agenda-entry-text-hide)
(and org-agenda-entry-text-mode
(let ((org-agenda-entry-text-maxlines
(if (integerp arg) arg org-agenda-entry-text-maxlines)))
(org-agenda-entry-text-show)))
(org-agenda-set-mode-name)
(message "Entry text mode is %s%s"
(if org-agenda-entry-text-mode "on" "off")
(if (not org-agenda-entry-text-mode) ""
(format " (maximum number of lines is %d)"
(if (integerp arg) arg org-agenda-entry-text-maxlines))))))
(defun org-agenda-clockreport-mode ()
"Toggle clocktable mode in an agenda buffer."
(interactive)
(org-agenda-check-type t 'agenda)
(setq org-agenda-clockreport-mode (not org-agenda-clockreport-mode))
(org-agenda-set-mode-name)
(org-agenda-redo)
(message "Clocktable mode is %s"
(if org-agenda-clockreport-mode "on" "off")))
(defun org-agenda-log-mode (&optional special)
"Toggle log mode in an agenda buffer.
With argument SPECIAL, show all possible log items, not only the ones
configured in `org-agenda-log-mode-items'.
With a `\\[universal-argument] \\[universal-argument]' prefix, show *only* \
log items, nothing else."
(interactive "P")
(org-agenda-check-type t 'agenda)
(setq org-agenda-show-log
(cond
((equal special '(16)) 'only)
((eq special 'clockcheck)
(if (eq org-agenda-show-log 'clockcheck)
nil 'clockcheck))
(special '(closed clock state))
(t (not org-agenda-show-log))))
(org-agenda-set-mode-name)
(org-agenda-redo)
(message "Log mode is %s" (if org-agenda-show-log "on" "off")))
(defun org-agenda-archives-mode (&optional with-files)
"Toggle inclusion of items in trees marked with :ARCHIVE:.
When called with a prefix argument, include all archive files as well."
(interactive "P")
(setq org-agenda-archives-mode
(cond ((and with-files (eq org-agenda-archives-mode t)) nil)
(with-files t)
(org-agenda-archives-mode nil)
(t 'trees)))
(org-agenda-set-mode-name)
(org-agenda-redo)
(message
"%s"
(cond
((eq org-agenda-archives-mode nil)
"No archives are included")
((eq org-agenda-archives-mode 'trees)
(format "Trees with :%s: tag are included" org-archive-tag))
((eq org-agenda-archives-mode t)
(format "Trees with :%s: tag and all active archive files are included"
org-archive-tag)))))
(defun org-agenda-toggle-diary ()
"Toggle diary inclusion in an agenda buffer."
(interactive)
(org-agenda-check-type t 'agenda)
(setq org-agenda-include-diary (not org-agenda-include-diary))
(org-agenda-redo)
(org-agenda-set-mode-name)
(message "Diary inclusion turned %s"
(if org-agenda-include-diary "on" "off")))
(defun org-agenda-toggle-deadlines ()
"Toggle inclusion of entries with a deadline in an agenda buffer."
(interactive)
(org-agenda-check-type t 'agenda)
(setq org-agenda-include-deadlines (not org-agenda-include-deadlines))
(org-agenda-redo)
(org-agenda-set-mode-name)
(message "Deadlines inclusion turned %s"
(if org-agenda-include-deadlines "on" "off")))
(defun org-agenda-toggle-time-grid ()
"Toggle time grid in an agenda buffer."
(interactive)
(org-agenda-check-type t 'agenda)
(setq org-agenda-use-time-grid (not org-agenda-use-time-grid))
(org-agenda-redo)
(org-agenda-set-mode-name)
(message "Time-grid turned %s"
(if org-agenda-use-time-grid "on" "off")))
(defun org-agenda-set-mode-name ()
"Set the mode name to indicate all the small mode settings."
(setq mode-name
(list "Org-Agenda"
(if (get 'org-agenda-files 'org-restrict) " []" "")
" "
'(:eval (org-agenda-span-name org-agenda-current-span))
(if org-agenda-follow-mode " Follow" "")
(if org-agenda-entry-text-mode " ETxt" "")
(if org-agenda-include-diary " Diary" "")
(if org-agenda-include-deadlines " Ddl" "")
(if org-agenda-use-time-grid " Grid" "")
(if (and (boundp 'org-habit-show-habits)
org-habit-show-habits)
" Habit" "")
(cond
((consp org-agenda-show-log) " LogAll")
((eq org-agenda-show-log 'clockcheck) " ClkCk")
(org-agenda-show-log " Log")
(t ""))
(if (org-agenda-filter-any) " " "")
(if (or org-agenda-category-filter
(assoc-default 'category org-agenda-filters-preset))
'(:eval (propertize
(concat "["
(mapconcat
#'identity
(append
(assoc-default 'category org-agenda-filters-preset)
org-agenda-category-filter)
"")
"]")
'face 'org-agenda-filter-category
'help-echo "Category used in filtering"))
"")
(if (or org-agenda-tag-filter
(assoc-default 'tag org-agenda-filters-preset))
'(:eval (propertize
(concat (mapconcat
#'identity
(append
(assoc-default 'tag org-agenda-filters-preset)
org-agenda-tag-filter)
""))
'face 'org-agenda-filter-tags
'help-echo "Tags used in filtering"))
"")
(if (or org-agenda-effort-filter
(assoc-default 'effort org-agenda-filters-preset))
'(:eval (propertize
(concat (mapconcat
#'identity
(append
(assoc-default 'effort org-agenda-filters-preset)
org-agenda-effort-filter)
""))
'face 'org-agenda-filter-effort
'help-echo "Effort conditions used in filtering"))
"")
(if (or org-agenda-regexp-filter
(assoc-default 'regexp org-agenda-filters-preset))
'(:eval (propertize
(concat (mapconcat
(lambda (x) (concat (substring x 0 1) "/" (substring x 1) "/"))
(append
(assoc-default 'regexp org-agenda-filters-preset)
org-agenda-regexp-filter)
""))
'face 'org-agenda-filter-regexp
'help-echo "Regexp used in filtering"))
"")
(if org-agenda-archives-mode
(if (eq org-agenda-archives-mode t)
" Archives"
(format " :%s:" org-archive-tag))
"")
(if org-agenda-clockreport-mode " Clock" "")))
(force-mode-line-update))
(defun org-agenda-update-agenda-type ()
"Update the agenda type after each command."
(setq org-agenda-type
(or (get-text-property (point) 'org-agenda-type)
(get-text-property (max (point-min) (1- (point))) 'org-agenda-type))))
(defun org-agenda-next-line ()
"Move cursor to the next line, and show if follow mode is active."
(interactive)
(call-interactively 'next-line)
(org-agenda-do-context-action))
(defun org-agenda-previous-line ()
"Move cursor to the previous line, and show if follow mode is active."
(interactive)
(call-interactively 'previous-line)
(org-agenda-do-context-action))
(defun org-agenda-next-item (n)
"Move cursor to next agenda item."
(interactive "p")
(let ((col (current-column)))
(dotimes (_ n)
(when (next-single-property-change (line-end-position) 'org-marker)
(move-end-of-line 1)
(goto-char (next-single-property-change (point) 'org-marker))))
(org-move-to-column col))
(org-agenda-do-context-action))
(defun org-agenda-previous-item (n)
"Move cursor to next agenda item."
(interactive "p")
(dotimes (_ n)
(let ((col (current-column))
(goto (save-excursion
(move-end-of-line 0)
(previous-single-property-change (point) 'org-marker))))
(when goto (goto-char goto))
(org-move-to-column col)))
(org-agenda-do-context-action))
(defun org-agenda-do-context-action ()
"Show outline path and, maybe, follow mode window."
(let ((m (org-get-at-bol 'org-marker)))
(when (and (markerp m) (marker-buffer m))
(and org-agenda-follow-mode
(if org-agenda-follow-indirect
(let ((org-indirect-buffer-display 'other-window))
(org-agenda-tree-to-indirect-buffer nil))
(org-agenda-show)))
(and org-agenda-show-outline-path
(org-with-point-at m (org-display-outline-path org-agenda-show-outline-path))))))
(defun org-agenda-show-tags ()
"Show the tags applicable to the current item."
(interactive)
(let* ((tags (org-get-at-bol 'tags)))
(if tags
(message "Tags are :%s:"
(org-no-properties (mapconcat #'identity tags ":")))
(message "No tags associated with this line"))))
(defun org-agenda-goto (&optional highlight)
"Go to the entry at point in the corresponding Org file."
(interactive)
(let* ((marker (or (org-get-at-bol 'org-marker)
(org-agenda-error)))
(buffer (marker-buffer marker))
(pos (marker-position marker)))
(switch-to-buffer-other-window buffer)
(widen)
(push-mark)
(goto-char pos)
(when (derived-mode-p 'org-mode)
(org-fold-show-context 'agenda)
(recenter (/ (window-height) 2))
(org-back-to-heading t)
(let ((case-fold-search nil))
(when (re-search-forward org-complex-heading-regexp nil t)
(goto-char (match-beginning 4)))))
(run-hooks 'org-agenda-after-show-hook)
(and highlight (org-highlight (line-beginning-position)
(line-end-position)))))
(defvar org-agenda-after-show-hook nil
"Normal hook run after an item has been shown from the agenda.
Point is in the buffer where the item originated.")
;; Defined later in org-agenda.el
(defvar org-agenda-loop-over-headlines-in-active-region nil)
(defun org-agenda-do-in-region (beg end cmd &optional arg force-arg delete)
"Between region BEG and END, call agenda command CMD.
When optional argument ARG is non-nil or FORCE-ARG is t, pass
ARG to CMD. When optional argument DELETE is non-nil, assume CMD
deletes the agenda entry and don't move to the next entry."
(save-excursion
(goto-char beg)
(let ((mend (move-marker (make-marker) end))
(all (eq org-agenda-loop-over-headlines-in-active-region t))
(match (and (stringp org-agenda-loop-over-headlines-in-active-region)
org-agenda-loop-over-headlines-in-active-region))
(level (and (eq org-agenda-loop-over-headlines-in-active-region 'start-level)
(org-get-at-bol 'level))))
(while (< (point) mend)
(let ((ov (make-overlay (point) (line-end-position))))
(if (not (or all
(and match (looking-at-p match))
(eq level (org-get-at-bol 'level))))
(org-agenda-next-item 1)
(overlay-put ov 'face 'region)
(if (or arg force-arg) (funcall cmd arg) (funcall cmd))
(when (not delete) (org-agenda-next-item 1))
(delete-overlay ov)))))))
;; org-agenda-[schedule,deadline,date-prompt,todo,[toggle]archive*,
;; kill,set-property,set-effort] commands may loop over agenda
;; entries. Commands `org-agenda-set-tags' and `org-agenda-bulk-mark'
;; use their own mechanisms on active regions.
(defmacro org-agenda-maybe-loop (cmd arg force-arg delete &rest body)
"Maybe loop over agenda entries and perform CMD.
Pass ARG, FORCE-ARG, DELETE and BODY to `org-agenda-do-in-region'."
(declare (debug t))
`(if (and (called-interactively-p 'any)
org-agenda-loop-over-headlines-in-active-region
(org-region-active-p))
(org-agenda-do-in-region
(region-beginning) (region-end) ,cmd ,arg ,force-arg ,delete)
,@body))
(defun org-agenda-kill ()
"Kill the entry or subtree belonging to the current agenda entry."
(interactive)
(or (eq major-mode 'org-agenda-mode) (user-error "Not in agenda"))
(org-agenda-maybe-loop
#'org-agenda-kill nil nil t
(let* ((bufname-orig (buffer-name))
(marker (or (org-get-at-bol 'org-marker)
(org-agenda-error)))
(buffer (marker-buffer marker))
(type (org-get-at-bol 'type))
dbeg dend (n 0))
(org-with-remote-undo buffer
(org-with-point-at marker
(if (and (derived-mode-p 'org-mode) (not (member type '("sexp"))))
(setq dbeg (progn (org-back-to-heading t) (point))
dend (org-end-of-subtree t t))
(setq dbeg (line-beginning-position)
dend (min (point-max) (1+ (line-end-position)))))
(goto-char dbeg)
(while (re-search-forward "^[ \t]*\\S-" dend t) (setq n (1+ n))))
(when (or (eq t org-agenda-confirm-kill)
(and (numberp org-agenda-confirm-kill)
(> n org-agenda-confirm-kill)))
(let ((win-conf (current-window-configuration)))
(unwind-protect
(and
(prog2
(org-agenda-tree-to-indirect-buffer nil)
(not (y-or-n-p
(format "Delete entry with %d lines in buffer \"%s\"? "
n (buffer-name buffer))))
(kill-buffer org-last-indirect-buffer))
(error "Abort"))
(set-window-configuration win-conf))))
(let ((org-agenda-buffer-name bufname-orig))
(org-remove-subtree-entries-from-agenda buffer dbeg dend))
(org-with-point-at marker (delete-region dbeg dend))
(message "Agenda item and source killed")))))
(defvar org-archive-default-command) ; defined in org-archive.el
(defun org-agenda-archive-default ()
"Archive the entry or subtree belonging to the current agenda entry."
(interactive)
(require 'org-archive)
(funcall-interactively
#'org-agenda-archive-with org-archive-default-command))
(defun org-agenda-archive-default-with-confirmation ()
"Archive the entry or subtree belonging to the current agenda entry."
(interactive)
(require 'org-archive)
(funcall-interactively
#'org-agenda-archive-with org-archive-default-command 'confirm))
(defun org-agenda-archive ()
"Archive the entry or subtree belonging to the current agenda entry."
(interactive)
(funcall-interactively
#'org-agenda-archive-with 'org-archive-subtree))
(defun org-agenda-archive-to-archive-sibling ()
"Move the entry to the archive sibling."
(interactive)
(funcall-interactively
#'org-agenda-archive-with 'org-archive-to-archive-sibling))
(defvar org-archive-from-agenda)
(defun org-agenda-archive-with (cmd &optional confirm)
"Move the entry to the archive sibling."
(interactive)
(or (eq major-mode 'org-agenda-mode) (user-error "Not in agenda"))
(org-agenda-maybe-loop
#'org-agenda-archive-with cmd nil t
(let* ((bufname-orig (buffer-name))
(marker (or (org-get-at-bol 'org-marker)
(org-agenda-error)))
(buffer (marker-buffer marker))
(pos (marker-position marker)))
(org-with-remote-undo buffer
(with-current-buffer buffer
(if (derived-mode-p 'org-mode)
(if (and confirm
(not (y-or-n-p "Archive this subtree or entry? ")))
(error "Abort")
(save-window-excursion
(goto-char pos)
(let ((org-agenda-buffer-name bufname-orig))
(org-remove-subtree-entries-from-agenda))
(org-back-to-heading t)
(let ((org-archive-from-agenda t))
(funcall cmd))))
(error "Archiving works only in Org files")))))))
(defun org-remove-subtree-entries-from-agenda (&optional buf beg end)
"Remove all lines in the agenda that correspond to a given subtree.
The subtree is the one in buffer BUF, starting at BEG and ending at END.
If this information is not given, the function uses the tree at point."
(let ((buf (or buf (current-buffer))) m p)
(org-with-wide-buffer
(unless (and beg end)
(org-back-to-heading t)
(setq beg (point))
(org-end-of-subtree t)
(setq end (point)))
(set-buffer (get-buffer org-agenda-buffer-name))
(save-excursion
(goto-char (point-max))
(forward-line 0)
(while (not (bobp))
(when (and (setq m (org-get-at-bol 'org-marker))
(equal buf (marker-buffer m))
(setq p (marker-position m))
(>= p beg)
(< p end))
(let ((inhibit-read-only t))
(delete-region (line-beginning-position)
(1+ (line-end-position)))))
(forward-line -1))))))
(defun org-agenda-refile (&optional goto rfloc no-update)
"Refile the item at point.
When called with `\\[universal-argument] \\[universal-argument]', \
go to the location of the last
refiled item.
When called with `\\[universal-argument] \\[universal-argument] \
\\[universal-argument]' prefix or when GOTO is 0, clear
the refile cache.
RFLOC can be a refile location obtained in a different way.
When NO-UPDATE is non-nil, don't redo the agenda buffer."
(interactive "P")
(cond
((member goto '(0 (64)))
(org-refile-cache-clear))
((equal goto '(16))
(org-refile-goto-last-stored))
(t
(let* ((buffer-orig (buffer-name))
(marker (or (org-get-at-bol 'org-hd-marker)
(org-agenda-error)))
(buffer (marker-buffer marker))
;; (pos (marker-position marker))
(rfloc (or rfloc
(org-refile-get-location
(if goto "Goto" "Refile to") buffer
org-refile-allow-creating-parent-nodes))))
(with-current-buffer buffer
(org-with-wide-buffer
(goto-char marker)
(let ((org-agenda-buffer-name buffer-orig))
(org-remove-subtree-entries-from-agenda))
(org-refile goto buffer rfloc))))
(unless no-update (org-agenda-redo)))))
(defun org-agenda-open-link (&optional arg)
"Open the link(s) in the current entry, if any.
This looks for a link in the displayed line in the agenda.
It also looks at the text of the entry itself."
(interactive "P")
(let* ((marker (or (org-get-at-bol 'org-hd-marker)
(org-get-at-bol 'org-marker)))
(buffer (and marker (marker-buffer marker)))
(prefix (buffer-substring (line-beginning-position)
(line-end-position)))
(lkall (and buffer (org-offer-links-in-entry
buffer marker arg prefix)))
(lk0 (car lkall))
(lk (if (stringp lk0) (list lk0) lk0))
(lkend (cdr lkall))
trg)
(cond
((and buffer lk)
(mapcar (lambda(l)
(with-current-buffer buffer
(setq trg (and (string-match org-link-bracket-re l)
(match-string 1 l)))
(if (or (not trg) (string-match org-link-any-re trg))
;; Don't use `org-with-wide-buffer' here as
;; opening the link may result in moving the point
(save-restriction
(widen)
(goto-char marker)
(when (search-forward l nil lkend)
(goto-char (match-beginning 0))
(org-open-at-point)))
(switch-to-buffer-other-window buffer)
;; This is an internal link, widen the buffer
(widen)
(goto-char marker)
(when (search-forward l nil lkend)
(goto-char (match-beginning 0))
(org-open-at-point)))))
lk))
((or (org-in-regexp (concat "\\(" org-link-bracket-re "\\)"))
(save-excursion
(forward-line 0)
(looking-at (concat ".*?\\(" org-link-bracket-re "\\)"))))
(org-link-open-from-string (match-string 1)))
(t (message "No link to open here")))))
(defun org-agenda-copy-local-variable (var)
"Get a variable from a referenced buffer and install it here."
(let ((m (org-get-at-bol 'org-marker)))
(when (and m (buffer-live-p (marker-buffer m)))
(set (make-local-variable var)
(with-current-buffer (marker-buffer m)
(symbol-value var))))))
(defun org-agenda-switch-to (&optional delete-other-windows)
"Go to the Org mode file which contains the item at point.
When optional argument DELETE-OTHER-WINDOWS is non-nil, the
displayed Org file fills the frame."
(interactive)
(if (and org-return-follows-link
(not (org-get-at-bol 'org-marker))
(org-in-regexp org-link-bracket-re))
(org-link-open-from-string (match-string 0))
(let* ((marker (or (org-get-at-bol 'org-marker)
(org-agenda-error)))
(buffer (marker-buffer marker))
(pos (marker-position marker)))
(unless buffer (user-error "Trying to switch to non-existent buffer"))
(pop-to-buffer-same-window buffer)
(when delete-other-windows
(display-buffer (current-buffer) '(org-display-buffer-full-frame)))
(widen)
(goto-char pos)
(when (derived-mode-p 'org-mode)
(org-fold-show-context 'agenda)
(run-hooks 'org-agenda-after-show-hook)))))
(defun org-agenda-goto-mouse (ev)
"Go to the Org file which contains the item at the mouse click."
(interactive "e")
(mouse-set-point ev)
(org-agenda-goto))
(defun org-agenda-show (&optional full-entry)
"Display the Org file which contains the item at point.
With prefix argument FULL-ENTRY, make the entire entry visible
if it was hidden in the outline."
(interactive "P")
(let ((win (selected-window)))
(org-agenda-goto t)
(when full-entry (org-fold-show-entry 'hide-drawers))
(select-window win)))
(defvar org-agenda-show-window nil)
(defun org-agenda-show-and-scroll-up (&optional arg)
"Display the Org file which contains the item at point.
When called repeatedly, scroll the window that is displaying the buffer.
With a `\\[universal-argument]' prefix argument, display the item, but \
fold drawers."
(interactive "P")
(let ((win (selected-window)))
(if (and (window-live-p org-agenda-show-window)
(eq this-command last-command))
(progn
(select-window org-agenda-show-window)
(ignore-errors (scroll-up)))
(org-agenda-goto t)
(org-fold-show-entry 'hide-drawers)
(if arg (org-cycle-hide-drawers 'children)
(org-with-wide-buffer
(narrow-to-region (org-entry-beginning-position)
(org-entry-end-position))
(org-fold-show-all '(drawers))))
(setq org-agenda-show-window (selected-window)))
(select-window win)))
(defun org-agenda-show-scroll-down ()
"Scroll down the window showing the agenda."
(interactive)
(let ((win (selected-window)))
(when (window-live-p org-agenda-show-window)
(select-window org-agenda-show-window)
(ignore-errors (scroll-down))
(select-window win))))
(defun org-agenda-show-1 (&optional more)
"Display the Org file which contains the item at point.
The prefix arg selects the amount of information to display:
0 hide the subtree
1 just show the entry according to defaults.
2 show the children view
3 show the subtree view
4 show the entire subtree and any drawers
With prefix argument FULL-ENTRY, make the entire entry visible
if it was hidden in the outline."
(interactive "p")
(let ((win (selected-window)))
(org-agenda-goto t)
(org-back-to-heading)
(set-window-start (selected-window) (line-beginning-position))
(cond
((= more 0)
(org-fold-subtree t)
(save-excursion
(org-back-to-heading)
(run-hook-with-args 'org-cycle-hook 'folded))
(message "Remote: FOLDED"))
((and (called-interactively-p 'any) (= more 1))
(message "Remote: show with default settings"))
((= more 2)
(org-fold-show-entry 'hide-drawers)
(org-fold-show-children)
(save-excursion
(org-back-to-heading)
(run-hook-with-args 'org-cycle-hook 'children))
(message "Remote: CHILDREN"))
((= more 3)
(org-fold-show-subtree)
(save-excursion
(org-back-to-heading)
(run-hook-with-args 'org-cycle-hook 'subtree))
(message "Remote: SUBTREE"))
((> more 3)
(org-fold-show-subtree)
(message "Remote: SUBTREE AND ALL DRAWERS")))
(select-window win)))
(defvar org-agenda-cycle-counter nil)
(defun org-agenda-cycle-show (&optional n)
"Show the current entry in another window, with default settings.
Default settings are taken from `org-show-context-detail'. When
use repeatedly in immediate succession, the remote entry will
cycle through visibility
children -> subtree -> folded
When called with a numeric prefix arg, that arg will be passed through to
`org-agenda-show-1'. For the interpretation of that argument, see the
docstring of `org-agenda-show-1'."
(interactive "P")
(if (integerp n)
(setq org-agenda-cycle-counter n)
(if (not (eq last-command this-command))
(setq org-agenda-cycle-counter 1)
(if (equal org-agenda-cycle-counter 0)
(setq org-agenda-cycle-counter 2)
(setq org-agenda-cycle-counter (1+ org-agenda-cycle-counter))
(when (> org-agenda-cycle-counter 3)
(setq org-agenda-cycle-counter 0)))))
(org-agenda-show-1 org-agenda-cycle-counter))
(defun org-agenda-recenter (arg)
"Display the Org file which contains the item at point and recenter."
(interactive "P")
(let ((win (selected-window)))
(org-agenda-goto t)
(recenter arg)
(select-window win)))
(defun org-agenda-show-mouse (ev)
"Display the Org file which contains the item at the mouse click."
(interactive "e")
(mouse-set-point ev)
(org-agenda-show))
(defun org-agenda-check-no-diary ()
"Check if the entry is a diary link and abort if yes."
(when (org-get-at-bol 'org-agenda-diary-link)
(org-agenda-error)))
(defun org-agenda-error ()
"Throw an error when a command is not allowed in the agenda."
(user-error "Command not allowed in this line"))
(defun org-agenda-tree-to-indirect-buffer (arg)
"Show the subtree corresponding to the current entry in an indirect buffer.
This calls the command `org-tree-to-indirect-buffer' from the original buffer.
With a numerical prefix ARG, go up to this level and then take that tree.
With a negative numeric ARG, go up by this number of levels.
With a `\\[universal-argument]' prefix, make a separate frame for this tree, \
i.e. don't use
the dedicated frame."
(interactive "P")
(org-agenda-check-no-diary)
(let* ((marker (or (org-get-at-bol 'org-marker)
(org-agenda-error)))
(buffer (marker-buffer marker))
(pos (marker-position marker)))
(with-current-buffer buffer
(save-excursion
(goto-char pos)
(org-tree-to-indirect-buffer arg))))
(setq org-agenda-last-indirect-buffer org-last-indirect-buffer))
(defvar org-last-heading-marker (make-marker)
"Marker pointing to the headline that last changed its TODO state
by a remote command from the agenda.")
(defun org-agenda-todo-nextset ()
"Switch TODO entry to next sequence."
(interactive)
(org-agenda-todo 'nextset))
(defun org-agenda-todo-previousset ()
"Switch TODO entry to previous sequence."
(interactive)
(org-agenda-todo 'previousset))
(defvar org-agenda-headline-snapshot-before-repeat)
(defun org-agenda-todo (&optional arg)
"Cycle TODO state of line at point, also in Org file.
This changes the line at point, all other lines in the agenda referring to
the same tree node, and the headline of the tree node in the Org file."
(interactive "P")
(org-agenda-check-no-diary)
(org-agenda-maybe-loop
#'org-agenda-todo arg nil nil
(let* ((col (current-column))
(marker (or (org-get-at-bol 'org-marker)
(org-agenda-error)))
(buffer (marker-buffer marker))
(pos (marker-position marker))
(hdmarker (org-get-at-bol 'org-hd-marker))
(todayp (org-agenda-today-p (org-get-at-bol 'day)))
(inhibit-read-only t)
org-loop-over-headlines-in-active-region
org-agenda-headline-snapshot-before-repeat newhead just-one)
(org-with-remote-undo buffer
(with-current-buffer buffer
(widen)
(goto-char pos)
(org-fold-show-context 'agenda)
(let ((current-prefix-arg arg))
(call-interactively 'org-todo)
;; Make sure that log is recorded in current undo.
(when (and org-log-setup
(not (eq org-log-note-how 'note)))
(org-add-log-note)))
(and (bolp) (forward-char 1))
(setq newhead (org-get-heading))
(when (and org-agenda-headline-snapshot-before-repeat
(not (equal org-agenda-headline-snapshot-before-repeat
newhead))
todayp)
(setq newhead org-agenda-headline-snapshot-before-repeat
just-one t))
(save-excursion
(org-back-to-heading)
(move-marker org-last-heading-marker (point))))
(forward-line 0)
(save-window-excursion
(org-agenda-change-all-lines newhead hdmarker 'fixface just-one))
(when (bound-and-true-p org-clock-out-when-done)
(string-match (concat "^" (regexp-opt org-done-keywords-for-agenda))
newhead)
(org-agenda-unmark-clocking-task))
(org-move-to-column col)
(org-agenda-mark-clocking-task)))))
(defun org-agenda-add-note (&optional _arg)
"Add a time-stamped note to the entry at point."
(interactive) ;; "P"
(org-agenda-check-no-diary)
(let* ((marker (or (org-get-at-bol 'org-marker)
(org-agenda-error)))
(buffer (marker-buffer marker))
(pos (marker-position marker))
(_hdmarker (org-get-at-bol 'org-hd-marker))
(inhibit-read-only t))
(with-current-buffer buffer
(widen)
(goto-char pos)
(org-fold-show-context 'agenda)
(org-add-note))))
(defun org-agenda-change-all-lines (newhead hdmarker
&optional fixface just-this)
"Change all lines in the agenda buffer which match HDMARKER.
The new content of the line will be NEWHEAD (as modified by
`org-agenda-format-item'). HDMARKER is checked with
`equal' against all `org-hd-marker' text properties in the file.
If FIXFACE is non-nil, the face of each item is modified according to
the new TODO state.
If JUST-THIS is non-nil, change just the current line, not all.
If FORCE-TAGS is non-nil, the car of it returns the new tags."
(let* ((inhibit-read-only t)
(line (org-current-line))
(org-agenda-buffer (current-buffer))
(thetags (with-current-buffer (marker-buffer hdmarker)
(org-get-tags hdmarker)))
props m undone-face done-face finish new dotime level cat tags
effort effort-minutes) ;; pl
(save-excursion
(goto-char (point-max))
(forward-line 0)
(while (not finish)
(setq finish (bobp))
(when (and (setq m (org-get-at-bol 'org-hd-marker))
(or (not just-this) (= (org-current-line) line))
(equal m hdmarker))
(setq props (text-properties-at (point))
dotime (org-get-at-bol 'dotime)
cat (org-agenda-get-category)
level (org-get-at-bol 'level)
tags thetags
effort (org-get-at-bol 'effort)
effort-minutes (org-get-at-bol 'effort-minutes)
new
(let ((org-prefix-format-compiled
(or (get-text-property (min (1- (point-max)) (point)) 'format)
org-prefix-format-compiled))
(extra (org-get-at-bol 'extra)))
(with-current-buffer (marker-buffer hdmarker)
(org-with-wide-buffer
(org-agenda-format-item extra
(org-add-props newhead nil
'effort effort
'effort-minutes effort-minutes)
level cat tags dotime))))
;; pl (text-property-any (line-beginning-position)
;; (line-end-position) 'org-heading t)
undone-face (org-get-at-bol 'undone-face)
done-face (org-get-at-bol 'done-face))
(forward-line 0)
(cond
((equal new "") (delete-region (point) (line-beginning-position 2)))
((looking-at ".*")
;; When replacing the whole line, preserve bulk mark
;; overlay, if any.
(let ((mark (catch :overlay
(dolist (o (overlays-in (point) (+ 2 (point))))
(when (eq (overlay-get o 'type)
'org-marked-entry-overlay)
(throw :overlay o))))))
(replace-match new t t)
(forward-line 0)
(when mark (move-overlay mark (point) (+ 2 (point)))))
(add-text-properties (line-beginning-position)
(line-end-position) props)
(when fixface
(add-text-properties
(line-beginning-position) (line-end-position)
(list 'face
(if org-last-todo-state-is-todo
undone-face done-face))))
(org-agenda-highlight-todo 'line)
(forward-line 0))
(t (error "Line update did not work")))
(save-restriction
(narrow-to-region (line-beginning-position) (line-end-position))
(org-agenda-finalize)))
(forward-line -1)))))
(defun org-agenda-align-tags (&optional line)
"Align all tags in agenda items to `org-agenda-tags-column'.
When optional argument LINE is non-nil, align tags only on the
current line."
(let ((inhibit-read-only t)
(org-agenda-tags-column (if (eq 'auto org-agenda-tags-column)
(- (window-max-chars-per-line))
org-agenda-tags-column))
(end (and line (line-end-position)))
l c)
(org-fold-core-ignore-modifications
(save-excursion
(goto-char (if line (line-beginning-position) (point-min)))
(while (re-search-forward org-tag-group-re end t)
(add-text-properties
(match-beginning 1) (match-end 1)
(list 'face (delq nil (let ((prop (get-text-property
(match-beginning 1) 'face)))
(or (listp prop) (setq prop (list prop)))
(if (memq 'org-tag prop)
prop
(cons 'org-tag prop))))))
(setq l (string-width (match-string 1))
c (if (< org-agenda-tags-column 0)
(- (abs org-agenda-tags-column) l)
org-agenda-tags-column))
(goto-char (match-beginning 1))
(delete-region (save-excursion (skip-chars-backward " \t") (point))
(point))
(insert (org-add-props
(make-string (max 1 (- c (current-column))) ?\s)
(plist-put (copy-sequence (text-properties-at (point)))
'face nil))))
(goto-char (point-min))
(org-font-lock-add-tag-faces (point-max))))))
(defun org-agenda-priority-up ()
"Increase the priority of line at point, also in Org file."
(interactive)
(org-agenda-priority 'up))
(defun org-agenda-priority-down ()
"Decrease the priority of line at point, also in Org file."
(interactive)
(org-agenda-priority 'down))
(defun org-agenda-priority (&optional force-direction)
"Set the priority of line at point, also in Org file.
This changes the line at point, all other lines in the agenda
referring to the same tree node, and the headline of the tree
node in the Org file.
Called with one universal prefix arg, show the priority instead
of setting it.
When called programmatically, FORCE-DIRECTION can be `set', `up',
`down', or a character."
(interactive "P")
(unless org-priority-enable-commands
(user-error "Priority commands are disabled"))
(org-agenda-check-no-diary)
(let* ((col (current-column))
(hdmarker (org-get-at-bol 'org-hd-marker))
(buffer (marker-buffer hdmarker))
(pos (marker-position hdmarker))
(inhibit-read-only t)
newhead)
(org-with-remote-undo buffer
(with-current-buffer buffer
(widen)
(goto-char pos)
(org-fold-show-context 'agenda)
(org-priority force-direction)
(end-of-line 1)
(setq newhead (org-get-heading)))
(org-agenda-change-all-lines newhead hdmarker)
(org-move-to-column col))))
;; FIXME: should fix the tags property of the agenda line.
(defun org-agenda-set-tags (&optional tag onoff)
"Set tags for the current headline."
(interactive)
(org-agenda-check-no-diary)
(if (and (org-region-active-p) (called-interactively-p 'any))
(call-interactively 'org-change-tag-in-region)
(let* ((hdmarker (or (org-get-at-bol 'org-hd-marker)
(org-agenda-error)))
(buffer (marker-buffer hdmarker))
(pos (marker-position hdmarker))
(inhibit-read-only t)
newhead)
(org-with-remote-undo buffer
(with-current-buffer buffer
(widen)
(goto-char pos)
(org-fold-show-context 'agenda)
(if tag
(org-toggle-tag tag onoff)
(call-interactively #'org-set-tags-command))
(end-of-line 1)
(setq newhead (org-get-heading)))
(org-agenda-change-all-lines newhead hdmarker)
(forward-line 0)))))
(defun org-agenda-set-property ()
"Set a property for the current headline."
(interactive)
(org-agenda-check-no-diary)
(org-agenda-maybe-loop
#'org-agenda-set-property nil nil nil
(let* ((hdmarker (or (org-get-at-bol 'org-hd-marker)
(org-agenda-error)))
(buffer (marker-buffer hdmarker))
(pos (marker-position hdmarker))
(inhibit-read-only t)
) ;; newhead
(org-with-remote-undo buffer
(with-current-buffer buffer
(widen)
(goto-char pos)
(org-fold-show-context 'agenda)
(call-interactively 'org-set-property))))))
(defun org-agenda-set-effort ()
"Set the effort property for the current headline."
(interactive)
(org-agenda-check-no-diary)
(org-agenda-maybe-loop
#'org-agenda-set-effort nil nil nil
(let* ((hdmarker (or (org-get-at-bol 'org-hd-marker)
(org-agenda-error)))
(buffer (marker-buffer hdmarker))
(pos (marker-position hdmarker))
(inhibit-read-only t)
newhead)
(org-with-remote-undo buffer
(with-current-buffer buffer
(widen)
(goto-char pos)
(org-fold-show-context 'agenda)
(call-interactively 'org-set-effort)
(end-of-line 1)
(setq newhead (org-get-heading)))
(org-agenda-change-all-lines newhead hdmarker)))))
(defun org-agenda-toggle-archive-tag ()
"Toggle the archive tag for the current entry."
(interactive)
(org-agenda-check-no-diary)
(org-agenda-maybe-loop
#'org-agenda-toggle-archive-tag nil nil nil
(let* ((hdmarker (or (org-get-at-bol 'org-hd-marker)
(org-agenda-error)))
(buffer (marker-buffer hdmarker))
(pos (marker-position hdmarker))
(inhibit-read-only t)
newhead)
(org-with-remote-undo buffer
(with-current-buffer buffer
(widen)
(goto-char pos)
(org-fold-show-context 'agenda)
(call-interactively 'org-toggle-archive-tag)
(end-of-line 1)
(setq newhead (org-get-heading)))
(org-agenda-change-all-lines newhead hdmarker)
(forward-line 0)))))
(defun org-agenda-do-date-later (arg)
(interactive "P")
(cond
((or (equal arg '(16))
(memq last-command
'(org-agenda-date-later-minutes org-agenda-date-earlier-minutes)))
(setq this-command 'org-agenda-date-later-minutes)
(org-agenda-date-later-minutes 1))
((or (equal arg '(4))
(memq last-command
'(org-agenda-date-later-hours org-agenda-date-earlier-hours)))
(setq this-command 'org-agenda-date-later-hours)
(org-agenda-date-later-hours 1))
(t
(org-agenda-date-later (prefix-numeric-value arg)))))
(defun org-agenda-do-date-earlier (arg)
(interactive "P")
(cond
((or (equal arg '(16))
(memq last-command
'(org-agenda-date-later-minutes org-agenda-date-earlier-minutes)))
(setq this-command 'org-agenda-date-earlier-minutes)
(org-agenda-date-earlier-minutes 1))
((or (equal arg '(4))
(memq last-command
'(org-agenda-date-later-hours org-agenda-date-earlier-hours)))
(setq this-command 'org-agenda-date-earlier-hours)
(org-agenda-date-earlier-hours 1))
(t
(org-agenda-date-earlier (prefix-numeric-value arg)))))
(defun org-agenda-date-later (arg &optional what)
"Change the date of this item to ARG day(s) later."
(interactive "p")
(org-agenda-check-type t 'agenda)
(org-agenda-check-no-diary)
(let* ((marker (or (org-get-at-bol 'org-marker)
(org-agenda-error)))
(buffer (marker-buffer marker))
(pos (marker-position marker))
cdate today)
(org-with-remote-undo buffer
(with-current-buffer buffer
(widen)
(goto-char pos)
(unless (org-at-timestamp-p 'lax) (error "Cannot find time stamp"))
(when (and org-agenda-move-date-from-past-immediately-to-today
(equal arg 1)
(or (not what) (eq what 'day))
(not (save-match-data (org-at-date-range-p))))
(setq cdate (org-parse-time-string (match-string 0) 'nodefault)
cdate (calendar-absolute-from-gregorian
(list (nth 4 cdate) (nth 3 cdate) (nth 5 cdate)))
today (org-today))
(when (> today cdate)
;; immediately shift to today
(setq arg (- today cdate))))
(org-timestamp-change arg (or what 'day))
(when (and (org-at-date-range-p)
(re-search-backward org-tr-regexp-both
(line-beginning-position)))
(let ((end org-last-changed-timestamp))
(org-timestamp-change arg (or what 'day))
(setq org-last-changed-timestamp
(concat org-last-changed-timestamp "--" end)))))
(org-agenda-show-new-time marker org-last-changed-timestamp))
(message "Time stamp changed to %s" org-last-changed-timestamp)))
(defun org-agenda-date-earlier (arg &optional what)
"Change the date of this item to ARG day(s) earlier."
(interactive "p")
(org-agenda-date-later (- arg) what))
(defun org-agenda-date-later-minutes (arg)
"Change the time of this item, in units of `org-timestamp-rounding-minutes'."
(interactive "p")
(setq arg (* arg (cadr org-timestamp-rounding-minutes)))
(org-agenda-date-later arg 'minute))
(defun org-agenda-date-earlier-minutes (arg)
"Change the time of this item, in units of `org-timestamp-rounding-minutes'."
(interactive "p")
(setq arg (* arg (cadr org-timestamp-rounding-minutes)))
(org-agenda-date-earlier arg 'minute))
(defun org-agenda-date-later-hours (arg)
"Change the time of this item, in hour steps."
(interactive "p")
(org-agenda-date-later arg 'hour))
(defun org-agenda-date-earlier-hours (arg)
"Change the time of this item, in hour steps."
(interactive "p")
(org-agenda-date-earlier arg 'hour))
(defun org-agenda-show-new-time (marker stamp &optional prefix)
"Show new date stamp via text properties."
;; We use text properties to make this undoable
(let ((inhibit-read-only t))
(setq stamp (concat prefix " => " stamp " "))
(save-excursion
(goto-char (point-max))
(while (not (bobp))
(when (equal marker (org-get-at-bol 'org-marker))
(remove-text-properties (line-beginning-position)
(line-end-position)
'(display nil))
(org-move-to-column
(max
1 ;; narrow buffer and wide timestamp
(- (window-max-chars-per-line)
(length stamp)))
t)
(add-text-properties
(1- (point)) (line-end-position)
(list 'display (org-add-props stamp nil
'face '(secondary-selection default))))
(forward-line 0))
(forward-line -1)))))
(defun org-agenda-date-prompt (arg)
"Change the date of this item. Date is prompted for, with default today.
The prefix ARG is passed to the `org-timestamp' command and can therefore
be used to request time specification in the time stamp."
(interactive "P")
(org-agenda-check-type t 'agenda)
(org-agenda-check-no-diary)
(org-agenda-maybe-loop
#'org-agenda-date-prompt arg t nil
(let* ((marker (or (org-get-at-bol 'org-marker)
(org-agenda-error)))
(buffer (marker-buffer marker))
(pos (marker-position marker)))
(org-with-remote-undo buffer
(with-current-buffer buffer
(widen)
(goto-char pos)
(unless (org-at-timestamp-p 'lax) (error "Cannot find time stamp"))
(org-timestamp arg (equal (char-after (match-beginning 0)) ?\[)))
(org-agenda-show-new-time marker org-last-changed-timestamp))
(message "Time stamp changed to %s" org-last-changed-timestamp))))
(defun org-agenda-schedule (arg &optional time)
"Schedule the item at point.
ARG is passed through to `org-schedule'."
(interactive "P")
(org-agenda-check-type t 'agenda 'todo 'tags 'search)
(org-agenda-check-no-diary)
(org-agenda-maybe-loop
#'org-agenda-schedule arg t nil
(let* ((marker (or (org-get-at-bol 'org-marker)
(org-agenda-error)))
;; (type (marker-insertion-type marker))
(buffer (marker-buffer marker))
(pos (marker-position marker))
ts)
(set-marker-insertion-type marker t)
(org-with-remote-undo buffer
(with-current-buffer buffer
(widen)
(goto-char pos)
(setq ts (org-schedule arg time)))
(org-agenda-show-new-time marker ts " S"))
(message "%s" ts))))
(defun org-agenda-deadline (arg &optional time)
"Schedule the item at point.
ARG is passed through to `org-deadline'."
(interactive "P")
(org-agenda-check-type t 'agenda 'todo 'tags 'search)
(org-agenda-check-no-diary)
(org-agenda-maybe-loop
#'org-agenda-deadline arg t nil
(let* ((marker (or (org-get-at-bol 'org-marker)
(org-agenda-error)))
(buffer (marker-buffer marker))
(pos (marker-position marker))
ts)
(org-with-remote-undo buffer
(with-current-buffer buffer
(widen)
(goto-char pos)
(setq ts (org-deadline arg time)))
(org-agenda-show-new-time marker ts " D"))
(message "%s" ts))))
(defun org-agenda-clock-in (&optional arg)
"Start the clock on the currently selected item."
(interactive "P")
(org-agenda-check-no-diary)
(if (equal arg '(4))
(org-clock-in arg)
(let* ((marker (or (org-get-at-bol 'org-marker)
(org-agenda-error)))
(hdmarker (or (org-get-at-bol 'org-hd-marker) marker))
(pos (marker-position marker))
(col (current-column))
newhead)
(org-with-remote-undo (marker-buffer marker)
(with-current-buffer (marker-buffer marker)
(widen)
(goto-char pos)
(org-fold-show-context 'agenda)
(org-clock-in arg)
(setq newhead (org-get-heading)))
(org-agenda-change-all-lines newhead hdmarker))
(org-move-to-column col))))
(defun org-agenda-clock-out ()
"Stop the currently running clock."
(interactive)
(unless (marker-buffer org-clock-marker)
(user-error "No running clock"))
(let ((marker (make-marker)) (col (current-column)) newhead)
(org-with-remote-undo (marker-buffer org-clock-marker)
(with-current-buffer (marker-buffer org-clock-marker)
(org-with-wide-buffer
(goto-char org-clock-marker)
(org-back-to-heading t)
(move-marker marker (point))
(org-clock-out)
(setq newhead (org-get-heading)))))
(org-agenda-change-all-lines newhead marker)
(move-marker marker nil)
(org-move-to-column col)
(org-agenda-unmark-clocking-task)))
(defun org-agenda-clock-cancel (&optional _arg)
"Cancel the currently running clock."
(interactive) ;; "P"
(unless (marker-buffer org-clock-marker)
(user-error "No running clock"))
(org-with-remote-undo (marker-buffer org-clock-marker)
(org-clock-cancel))
(org-agenda-unmark-clocking-task))
(defun org-agenda-clock-goto ()
"Jump to the currently clocked in task within the agenda.
If the currently clocked in task is not listed in the agenda
buffer, display it in another window."
(interactive)
(let (pos)
(mapc (lambda (o)
(when (eq (overlay-get o 'type) 'org-agenda-clocking)
(setq pos (overlay-start o))))
(overlays-in (point-min) (point-max)))
(cond (pos (goto-char pos))
;; If the currently clocked entry is not in the agenda
;; buffer, we visit it in another window:
((bound-and-true-p org-clock-current-task)
(switch-to-buffer-other-window (org-clock-goto)))
(t (message "No running clock, use `C-c C-x C-j' to jump to the most recent one")))))
(defun org-agenda-diary-entry-in-org-file ()
"Make a diary entry in the file `org-agenda-diary-file'."
(let (d1 d2 char (text "") dp1 dp2)
(if (equal (buffer-name) calendar-buffer)
(setq d1 (calendar-cursor-to-date t)
d2 (car calendar-mark-ring))
(setq dp1 (get-text-property (line-beginning-position) 'day))
(unless dp1 (user-error "No date defined in current line"))
(setq d1 (calendar-gregorian-from-absolute dp1)
d2 (and (ignore-errors (mark))
(save-excursion
(goto-char (mark))
(setq dp2 (get-text-property (line-beginning-position) 'day)))
(calendar-gregorian-from-absolute dp2))))
(message "Diary entry: [d]ay [a]nniversary [b]lock [j]ump to date tree")
(setq char (read-char-exclusive))
(cond
((equal char ?d)
(setq text (read-string "Day entry: "))
(org-agenda-add-entry-to-org-agenda-diary-file 'day text d1)
(and (equal (buffer-name) org-agenda-buffer-name) (org-agenda-redo)))
((equal char ?a)
(setq d1 (list (car d1) (nth 1 d1)
(read-number (format "Reference year [%d]: " (nth 2 d1))
(nth 2 d1))))
(setq text (read-string "Anniversary (use %d to show years): "))
(org-agenda-add-entry-to-org-agenda-diary-file 'anniversary text d1)
(and (equal (buffer-name) org-agenda-buffer-name) (org-agenda-redo)))
((equal char ?b)
(setq text (read-string "Block entry: "))
(unless (and d1 d2 (not (equal d1 d2)))
(user-error "No block of days selected"))
(org-agenda-add-entry-to-org-agenda-diary-file 'block text d1 d2)
(and (equal (buffer-name) org-agenda-buffer-name) (org-agenda-redo)))
((equal char ?j)
(switch-to-buffer-other-window
(find-file-noselect org-agenda-diary-file))
(require 'org-datetree)
(org-datetree-find-date-create d1)
(org-fold-reveal t))
(t (user-error "Invalid selection character `%c'" char)))))
(defcustom org-agenda-insert-diary-strategy 'date-tree
"Where in `org-agenda-diary-file' should new entries be added?
Valid values:
date-tree in the date tree, as first child of the date
date-tree-last in the date tree, as last child of the date
top-level as top-level entries at the end of the file."
:group 'org-agenda
:type '(choice
(const :tag "first in a date tree" date-tree)
(const :tag "last in a date tree" date-tree-last)
(const :tag "as top level at end of file" top-level)))
(defcustom org-agenda-insert-diary-extract-time nil
"Non-nil means extract any time specification from the diary entry."
:group 'org-agenda
:version "24.1"
:type 'boolean)
(defcustom org-agenda-bulk-mark-char ">"
"A single-character string to be used as the bulk mark."
:group 'org-agenda
:version "24.1"
:type 'string)
(defun org-agenda-add-entry-to-org-agenda-diary-file (type text &optional d1 d2)
"Add a diary entry with TYPE to `org-agenda-diary-file'.
If TEXT is not empty, it will become the headline of the new entry, and
the resulting entry will not be shown. When TEXT is empty, switch to
`org-agenda-diary-file' and let the user finish the entry there."
(let ((cw (current-window-configuration)))
(switch-to-buffer-other-window
(find-file-noselect org-agenda-diary-file))
(widen)
(goto-char (point-min))
(cl-case type
(anniversary
(or (re-search-forward "^\\*[ \t]+Anniversaries" nil t)
(progn
(or (org-at-heading-p)
(progn
(outline-next-heading)
(insert "* Anniversaries\n\n")
(forward-line -2)))))
(outline-next-heading)
(org-back-over-empty-lines)
(backward-char 1)
(insert "\n")
(insert (format "%%%%(org-anniversary %d %2d %2d) %s"
(nth 2 d1) (car d1) (nth 1 d1) text)))
(day
(let ((org-prefix-has-time t)
(org-agenda-time-leading-zero t)
fmt time time2)
(when org-agenda-insert-diary-extract-time
;; Use org-agenda-format-item to parse text for a time-range and
;; remove it. FIXME: This is a hack, we should refactor
;; that function to make time extraction available separately
(setq fmt (org-agenda-format-item nil text nil nil nil t)
time (get-text-property 0 'time fmt)
time2 (if (> (length time) 0)
;; split-string removes trailing ...... if
;; no end time given. First space
;; separates time from date.
(concat " " (car (split-string time "\\.")))
nil)
text (get-text-property 0 'txt fmt)))
(if (eq org-agenda-insert-diary-strategy 'top-level)
(org-agenda-insert-diary-as-top-level text)
(require 'org-datetree)
(org-datetree-find-date-create d1)
(org-agenda-insert-diary-make-new-entry text))
(org-insert-timestamp (org-time-from-absolute
(calendar-absolute-from-gregorian d1))
nil nil nil nil time2))
(end-of-line 0))
((block) ;; Wrap this in (strictly unnecessary) parens because
;; otherwise the indentation gets confused by the
;; special meaning of 'block
(when (> (calendar-absolute-from-gregorian d1)
(calendar-absolute-from-gregorian d2))
(setq d1 (prog1 d2 (setq d2 d1))))
(if (eq org-agenda-insert-diary-strategy 'top-level)
(org-agenda-insert-diary-as-top-level text)
(require 'org-datetree)
(org-datetree-find-date-create d1)
(org-agenda-insert-diary-make-new-entry text))
(org-insert-timestamp (org-time-from-absolute
(calendar-absolute-from-gregorian d1)))
(insert "--")
(org-insert-timestamp (org-time-from-absolute
(calendar-absolute-from-gregorian d2)))
(end-of-line 0)))
(if (string-match "\\S-" text)
(progn
(set-window-configuration cw)
(message "%s entry added to %s"
(capitalize (symbol-name type))
(abbreviate-file-name org-agenda-diary-file)))
(org-fold-reveal t)
(message "Please finish entry here"))))
(defun org-agenda-insert-diary-as-top-level (text)
"Make new entry as a top-level entry at the end of the file.
Add TEXT as headline, and position the cursor in the second line so that
a timestamp can be added there."
(widen)
(goto-char (point-max))
(unless (bolp) (insert "\n"))
(org-insert-heading nil t t)
(insert text)
(org-end-of-meta-data)
(unless (bolp) (insert "\n"))
(when org-adapt-indentation (indent-to-column 2)))
(defun org-agenda-insert-diary-make-new-entry (text)
"Make a new entry with TEXT as a child of the current subtree.
Position the point in the heading's first body line so that
a timestamp can be added there."
(cond
((eq org-agenda-insert-diary-strategy 'date-tree-last)
(end-of-line)
(org-insert-heading '(4) t)
(org-do-demote))
(t
(outline-next-heading)
(org-back-over-empty-lines)
(unless (looking-at "[ \t]*$") (save-excursion (insert "\n")))
(org-insert-heading nil t)
(org-do-demote)))
(let ((col (current-column)))
(insert text)
(org-end-of-meta-data)
;; Ensure point is left on a blank line, at proper indentation.
(unless (bolp) (insert "\n"))
(unless (looking-at-p "^[ \t]*$") (save-excursion (insert "\n")))
(when org-adapt-indentation (indent-to-column col)))
(org-fold-show-set-visibility 'lineage))
(defun org-agenda-diary-entry ()
"Make a diary entry, like the `i' command from the calendar.
All the standard commands work: block, weekly etc.
When `org-agenda-diary-file' points to a file,
`org-agenda-diary-entry-in-org-file' is called instead to create
entries in that Org file."
(interactive)
(if (not (eq org-agenda-diary-file 'diary-file))
(org-agenda-diary-entry-in-org-file)
(require 'diary-lib)
(let* ((char (read-char-exclusive
"Diary entry: [d]ay [w]eekly [m]onthly [y]early\
[a]nniversary [b]lock [c]yclic"))
(cmd (cdr (assoc char
'((?d . diary-insert-entry)
(?w . diary-insert-weekly-entry)
(?m . diary-insert-monthly-entry)
(?y . diary-insert-yearly-entry)
(?a . diary-insert-anniversary-entry)
(?b . diary-insert-block-entry)
(?c . diary-insert-cyclic-entry)))))
(oldf (symbol-function 'calendar-cursor-to-date))
;; (buf (get-file-buffer (substitute-in-file-name diary-file)))
(point (point))
(mark (or (mark t) (point))))
(unless cmd
(user-error "No command associated with <%c>" char))
(unless (and (get-text-property point 'day)
(or (not (equal ?b char))
(get-text-property mark 'day)))
(user-error "Don't know which date to use for diary entry"))
;; We implement this by hacking the `calendar-cursor-to-date' function
;; and the `calendar-mark-ring' variable. Saves a lot of code.
(let ((calendar-mark-ring
(list (calendar-gregorian-from-absolute
(or (get-text-property mark 'day)
(get-text-property point 'day))))))
(unwind-protect
(progn
(fset 'calendar-cursor-to-date
(lambda (&optional _error _dummy)
(calendar-gregorian-from-absolute
(get-text-property point 'day))))
(call-interactively cmd))
(fset 'calendar-cursor-to-date oldf))))))
(defun org-agenda-execute-calendar-command (cmd)
"Execute a calendar command from the agenda with date from cursor."
(org-agenda-check-type t 'agenda)
(require 'diary-lib)
(unless (get-text-property (min (1- (point-max)) (point)) 'day)
(user-error "Don't know which date to use for the calendar command"))
(let* ((oldf (symbol-function 'calendar-cursor-to-date))
(point (point))
(date (calendar-gregorian-from-absolute
(get-text-property point 'day))))
;; the following 2 vars are needed in the calendar
(org-dlet
((displayed-month (car date))
(displayed-year (nth 2 date)))
(unwind-protect
(progn
(fset 'calendar-cursor-to-date
(lambda (&optional _error _dummy)
(calendar-gregorian-from-absolute
(get-text-property point 'day))))
(call-interactively cmd))
(fset 'calendar-cursor-to-date oldf)))))
(defun org-agenda-phases-of-moon ()
"Display the phases of the moon for the 3 months around the cursor date."
(interactive)
(org-agenda-execute-calendar-command 'calendar-lunar-phases))
(defun org-agenda-holidays ()
"Display the holidays for the 3 months around the cursor date."
(interactive)
(org-agenda-execute-calendar-command 'calendar-list-holidays))
(defvar calendar-longitude) ; defined in calendar.el
(defvar calendar-latitude) ; defined in calendar.el
(defvar calendar-location-name) ; defined in calendar.el
(defun org-agenda-sunrise-sunset (arg)
"Display sunrise and sunset for the cursor date.
Latitude and longitude can be specified with the variables
`calendar-latitude' and `calendar-longitude'. When called with prefix
argument, latitude and longitude will be prompted for."
(interactive "P")
(require 'solar)
(let ((calendar-longitude (if arg nil calendar-longitude))
(calendar-latitude (if arg nil calendar-latitude))
(calendar-location-name
(if arg "the given coordinates" calendar-location-name)))
(org-agenda-execute-calendar-command 'calendar-sunrise-sunset)))
(defun org-agenda-goto-calendar ()
"Open the Emacs calendar with the date at the cursor."
(interactive)
(org-agenda-check-type t 'agenda)
(let* ((day (or (get-text-property (min (1- (point-max)) (point)) 'day)
(user-error "Don't know which date to open in calendar")))
(date (calendar-gregorian-from-absolute day))
(calendar-move-hook nil)
(calendar-view-holidays-initially-flag nil)
(calendar-view-diary-initially-flag nil))
(calendar)
(calendar-goto-date date)))
;;;###autoload
(defun org-calendar-goto-agenda ()
"Compute the Org agenda for the calendar date displayed at the cursor.
This is a command that has to be installed in `calendar-mode-map'."
(interactive)
;; Temporarily disable sticky agenda since user clearly wants to
;; refresh view anyway.
(let ((org-agenda-buffer-tmp-name "*Org Agenda(a)*")
(org-agenda-sticky nil))
(org-agenda-list nil (calendar-absolute-from-gregorian
(calendar-cursor-to-date))
nil)))
(defun org-agenda-convert-date ()
(interactive)
(org-agenda-check-type t 'agenda)
(let ((day (get-text-property (min (1- (point-max)) (point)) 'day))
date s)
(unless day
(user-error "Don't know which date to convert"))
(setq date (calendar-gregorian-from-absolute day))
(setq s (concat
"Gregorian: " (calendar-date-string date) "\n"
"ISO: " (calendar-iso-date-string date) "\n"
"Day of Yr: " (calendar-day-of-year-string date) "\n"
"Julian: " (calendar-julian-date-string date) "\n"
"Astron. JD: " (calendar-astro-date-string date)
" (Julian date number at noon UTC)\n"
"Hebrew: " (calendar-hebrew-date-string date) " (until sunset)\n"
"Islamic: " (calendar-islamic-date-string date) " (until sunset)\n"
"French: " (calendar-french-date-string date) "\n"
"Bahá’í: " (calendar-bahai-date-string date) " (until sunset)\n"
"Mayan: " (calendar-mayan-date-string date) "\n"
"Coptic: " (calendar-coptic-date-string date) "\n"
"Ethiopic: " (calendar-ethiopic-date-string date) "\n"
"Persian: " (calendar-persian-date-string date) "\n"
"Chinese: " (calendar-chinese-date-string date) "\n"))
(with-output-to-temp-buffer "*Dates*"
(princ s))
(org-fit-window-to-buffer (get-buffer-window "*Dates*"))))
;;; Bulk commands
(defun org-agenda-bulk-marked-p ()
"Non-nil when current entry is marked for bulk action."
(eq (get-char-property (line-beginning-position) 'type)
'org-marked-entry-overlay))
(defun org-agenda-bulk-mark (&optional arg)
"Mark entries for future bulk action.
When ARG is nil or one and region is not active then mark the
entry at point.
When ARG is nil or one and region is active then mark the entries
in the region.
When ARG is greater than one mark ARG lines."
(interactive "p")
(when (and (or (not arg) (= arg 1)) (use-region-p))
(setq arg (count-lines (region-beginning) (region-end)))
(goto-char (region-beginning))
(deactivate-mark))
(dotimes (_ (or arg 1))
(unless (org-get-at-bol 'org-agenda-diary-link)
(let* ((m (org-get-at-bol 'org-hd-marker))
ov)
(unless (org-agenda-bulk-marked-p)
(unless m (user-error "Nothing to mark at point"))
(push m org-agenda-bulk-marked-entries)
(setq ov (make-overlay (line-beginning-position)
(+ 2 (line-beginning-position))))
;; Display using 'before-string to make the overlay
;; compatible with column view in agenda that uses an
;; overlay with higher priority.
(overlay-put ov 'before-string
(propertize org-agenda-bulk-mark-char
'face (org-get-todo-face "TODO")))
;; We cannot completely hide the overlay to make point
;; adjustment not move point out of overlay (to previous
;; line) when moving lines with n/p.
(org-overlay-display ov " " nil 'evaporate)
(overlay-put ov 'type 'org-marked-entry-overlay))
(end-of-line 1)
(or (ignore-errors
(goto-char (next-single-property-change (point) 'org-hd-marker)))
(forward-line 1))
(while (and (get-char-property (point) 'invisible) (not (eobp)))
(forward-line 1)))))
(message "%d entries marked for bulk action"
(length org-agenda-bulk-marked-entries)))
(defun org-agenda-bulk-mark-all ()
"Mark all entries for future agenda bulk action."
(interactive)
(org-agenda-bulk-mark-regexp "."))
(defun org-agenda-bulk-mark-regexp (regexp)
"Mark entries matching REGEXP for future agenda bulk action."
(interactive "sMark entries matching regexp: ")
(let ((entries-marked 0) txt-at-point)
(save-excursion
(goto-char (point-min))
(goto-char (next-single-property-change (point) 'org-hd-marker))
(while (and (re-search-forward regexp nil t)
(setq txt-at-point
(get-text-property (match-beginning 0) 'txt)))
(if (get-char-property (point) 'invisible)
(forward-line 1)
(when (string-match-p regexp txt-at-point)
(setq entries-marked (1+ entries-marked))
(call-interactively 'org-agenda-bulk-mark)))))
(unless entries-marked
(message "No entry matching this regexp."))))
(defun org-agenda-bulk-unmark (&optional arg)
"Unmark the entry at point for future bulk action."
(interactive "P")
(if arg
(org-agenda-bulk-unmark-all)
(cond ((org-agenda-bulk-marked-p)
(org-agenda-bulk-remove-overlays
(line-beginning-position) (+ 2 (line-beginning-position)))
(setq org-agenda-bulk-marked-entries
(delete (org-get-at-bol 'org-hd-marker)
org-agenda-bulk-marked-entries))
(end-of-line 1)
(or (ignore-errors
(goto-char (next-single-property-change (point) 'txt)))
(forward-line 1))
(while (and (get-char-property (point) 'invisible) (not (eobp)))
(forward-line 1))
(message "%d entries left marked for bulk action"
(length org-agenda-bulk-marked-entries)))
(t (message "No entry to unmark here")))))
(defun org-agenda-bulk-toggle-all ()
"Toggle all marks for bulk action."
(interactive)
(save-excursion
(goto-char (point-min))
(while (ignore-errors
(goto-char (next-single-property-change (point) 'org-hd-marker)))
(org-agenda-bulk-toggle))))
(defun org-agenda-bulk-toggle ()
"Toggle the mark at point for bulk action."
(interactive)
(if (org-agenda-bulk-marked-p)
(org-agenda-bulk-unmark)
(org-agenda-bulk-mark)))
(defun org-agenda-bulk-remove-overlays (&optional beg end)
"Remove the mark overlays between BEG and END in the agenda buffer.
BEG and END default to the buffer limits.
This only removes the overlays, it does not remove the markers
from the list in `org-agenda-bulk-marked-entries'."
(interactive)
(mapc (lambda (ov)
(and (eq (overlay-get ov 'type) 'org-marked-entry-overlay)
(delete-overlay ov)))
(overlays-in (or beg (point-min)) (or end (point-max)))))
(defun org-agenda-bulk-unmark-all ()
"Remove all marks in the agenda buffer.
This will remove the markers and the overlays."
(interactive)
(if (null org-agenda-bulk-marked-entries)
(message "No entry to unmark")
(setq org-agenda-bulk-marked-entries nil)
(org-agenda-bulk-remove-overlays (point-min) (point-max))))
(defcustom org-agenda-persistent-marks nil
"Non-nil means marked items will stay marked after a bulk action.
You can toggle this interactively by typing `p' when prompted for a
bulk action."
:group 'org-agenda
:version "24.1"
:type 'boolean)
(defcustom org-agenda-loop-over-headlines-in-active-region t
"Shall some commands act upon headlines in the active region?
When set to t, some commands will be performed in all headlines
within the active region.
When set to `start-level', some commands will be performed in all
headlines within the active region, provided that these headlines
are of the same level than the first one.
When set to a regular expression, those commands will be
performed on the matching headlines within the active region.
The list of commands is: `org-agenda-schedule',
`org-agenda-deadline', `org-agenda-date-prompt',
`org-agenda-todo', `org-agenda-archive*', `org-agenda-kill'.
See `org-loop-over-headlines-in-active-region' for the equivalent
option for Org buffers."
:type '(choice (const :tag "Don't loop" nil)
(const :tag "All headlines in active region" t)
(const :tag "In active region, headlines at the same level than the first one" start-level)
(regexp :tag "Regular expression matcher"))
:version "27.1"
:package-version '(Org . "9.4")
:group 'org-agenda)
(defun org-agenda-bulk-action (&optional arg)
"Execute an remote-editing action on all marked entries.
The prefix arg is passed through to the command if possible."
(interactive "P")
;; When there is no mark, act on the agenda entry at point.
(if (not org-agenda-bulk-marked-entries)
(save-excursion (org-agenda-bulk-mark)))
(dolist (m org-agenda-bulk-marked-entries)
(unless (and (markerp m)
(marker-buffer m)
(buffer-live-p (marker-buffer m))
(marker-position m))
(user-error "Marker %s for bulk command is invalid" m)))
;; Prompt for the bulk command.
(org-unlogged-message
(concat "Bulk (" (if org-agenda-persistent-marks "" "don't ") "[p]ersist marks): "
"[$]arch [A]rch->sib [t]odo [+/-]tag [s]chd [d]eadline [r]efile "
"[S]catter [f]unction "
(and org-agenda-bulk-custom-functions
(format " Custom: [%s]"
(mapconcat (lambda (f) (char-to-string (car f)))
org-agenda-bulk-custom-functions
"")))))
(catch 'exit
(let* ((org-log-refile (if org-log-refile 'time nil))
(entries (reverse org-agenda-bulk-marked-entries))
(org-overriding-default-time
(and (get-text-property (point) 'org-agenda-date-header)
(org-get-cursor-date)))
redo-at-end
cmd)
(pcase (read-char-exclusive)
(?p
(let ((org-agenda-persistent-marks
(not org-agenda-persistent-marks)))
(org-agenda-bulk-action)
(throw 'exit nil)))
(?$
(setq cmd #'org-agenda-archive))
(?A
(setq cmd #'org-agenda-archive-to-archive-sibling))
((or ?r ?w)
(let ((refile-location
(org-refile-get-location
"Refile to"
(marker-buffer (car entries))
org-refile-allow-creating-parent-nodes)))
(when (nth 3 refile-location)
(setcar (nthcdr 3 refile-location)
(move-marker
(make-marker)
(nth 3 refile-location)
(or (get-file-buffer (nth 1 refile-location))
(find-buffer-visiting (nth 1 refile-location))
(error "This should not happen")))))
(setq cmd (lambda () (org-agenda-refile nil refile-location t)))
(setq redo-at-end t)))
(?t
(let ((state (completing-read
"Todo state: "
(with-current-buffer (marker-buffer (car entries))
(mapcar #'list org-todo-keywords-1)))))
(setq cmd (lambda ()
(let ((org-inhibit-blocking t)
(org-inhibit-logging 'note))
(org-agenda-todo state))))))
((and (or ?- ?+) action)
(let ((tag (completing-read
(format "Tag to %s: " (if (eq action ?+) "add" "remove"))
(with-current-buffer (marker-buffer (car entries))
(delq nil
(mapcar (lambda (x) (and (stringp (car x)) x))
org-current-tag-alist))))))
(setq cmd
(lambda ()
(org-agenda-set-tags tag
(if (eq action ?+) 'on 'off))))))
((and (or ?s ?d) c)
(let* ((schedule? (eq c ?s))
(prompt (if schedule? "(Re)Schedule to" "(Re)Set Deadline to"))
(time
(and (not arg)
(let ((new (org-read-date
nil nil nil prompt org-overriding-default-time)))
;; A "double plus" answer applies to every
;; scheduled time. Do not turn it into
;; a fixed date yet.
(if (string-match-p "\\`[ \t]*\\+\\+"
org-read-date-final-answer)
org-read-date-final-answer
new)))))
;; Make sure to not prompt for a note when bulk
;; rescheduling/resetting deadline as Org cannot cope with
;; simultaneous notes. Besides, it could be annoying
;; depending on the number of marked items.
(setq cmd
(if schedule?
(lambda ()
(let ((org-log-reschedule
(and org-log-reschedule 'time)))
(org-agenda-schedule arg time)))
(lambda ()
(let ((org-log-redeadline (and org-log-redeadline 'time)))
(org-agenda-deadline arg time)))))))
(?S
(unless (org-agenda-check-type nil 'agenda 'todo)
(user-error "Can't scatter tasks in \"%s\" agenda view" org-agenda-type))
(let ((days (read-number
(format "Scatter tasks across how many %sdays: "
(if arg "week" ""))
7)))
(setq cmd
(lambda ()
(let ((distance (1+ (random days))))
(when arg
(let ((dist distance)
(day-of-week
(calendar-day-of-week
(calendar-gregorian-from-absolute (org-today)))))
(dotimes (_ (1+ dist))
(while (member day-of-week org-agenda-weekend-days)
(cl-incf distance)
(cl-incf day-of-week)
(when (= day-of-week 7)
(setq day-of-week 0)))
(cl-incf day-of-week)
(when (= day-of-week 7)
(setq day-of-week 0)))))
;; Silently fail when try to replan a sexp entry.
(ignore-errors
(let* ((date (calendar-gregorian-from-absolute
(+ (org-today) distance)))
(time (org-encode-time
0 0 0 (nth 1 date) (nth 0 date) (nth 2 date))))
(org-agenda-schedule nil time))))))))
(?f
(setq cmd
(intern
(completing-read "Function: " obarray #'fboundp t nil nil))))
(action
(setq cmd
(pcase (assoc action org-agenda-bulk-custom-functions)
(`(,_ ,fn)
fn)
(`(,_ ,fn ,arg-fn)
(apply #'apply-partially fn (funcall arg-fn)))
(_
(user-error "Invalid bulk action: %c" action))))
(setq redo-at-end t)))
;; Sort the markers, to make sure that parents are handled
;; before children.
(setq entries (sort entries
(lambda (a b)
(cond
((eq (marker-buffer a) (marker-buffer b))
(< (marker-position a) (marker-position b)))
(t
(string< (buffer-name (marker-buffer a))
(buffer-name (marker-buffer b))))))))
;; Now loop over all markers and apply CMD.
(let ((processed 0)
(skipped 0))
(dolist (e entries)
(let ((pos (text-property-any (point-min) (point-max) 'org-hd-marker e)))
(if (not pos)
(progn (message "Skipping removed entry at %s" e)
(cl-incf skipped))
(goto-char pos)
(let (org-loop-over-headlines-in-active-region) (funcall cmd))
;; `post-command-hook' is not run yet. We make sure any
;; pending log note is processed.
(when org-log-setup (org-add-log-note))
(cl-incf processed))))
(when redo-at-end (org-agenda-redo))
(unless org-agenda-persistent-marks (org-agenda-bulk-unmark-all))
(message "Acted on %d entries%s%s"
processed
(if (= skipped 0)
""
(format ", skipped %d (disappeared before their turn)"
skipped))
(if (not org-agenda-persistent-marks) "" " (kept marked)"))))))
(defun org-agenda-capture (&optional with-time)
"Call `org-capture' with the date at point.
With a `C-1' prefix, use the HH:MM value at point (if any) or the
current HH:MM time."
(interactive "P")
(if (not (eq major-mode 'org-agenda-mode))
(user-error "You cannot do this outside of agenda buffers")
(let ((org-overriding-default-time
(org-get-cursor-date (equal with-time 1))))
(call-interactively 'org-capture))))
;;; Dragging agenda lines forward/backward
(defun org-agenda-reapply-filters ()
"Re-apply all agenda filters."
(mapcar
(lambda(f) (when (car f) (org-agenda-filter-apply (car f) (cadr f) t)))
`((,org-agenda-tag-filter tag)
(,org-agenda-category-filter category)
(,org-agenda-regexp-filter regexp)
(,org-agenda-effort-filter effort)
(,(assoc-default 'tag org-agenda-filters-preset) tag)
(,(assoc-default 'category org-agenda-filters-preset) category)
(,(assoc-default 'effort org-agenda-filters-preset) effort)
(,(assoc-default 'regexp org-agenda-filters-preset) regexp))))
(defun org-agenda-drag-line-forward (arg &optional backward)
"Drag an agenda line forward by ARG lines.
When the optional argument `backward' is non-nil, move backward."
(interactive "p")
(let ((inhibit-read-only t) lst line)
(if (or (not (get-text-property (point) 'txt))
(save-excursion
(dotimes (_ arg)
(move-beginning-of-line (if backward 0 2))
(push (not (get-text-property (point) 'txt)) lst))
(delq nil lst)))
(message "Cannot move line forward")
(let ((end (save-excursion (move-beginning-of-line 2) (point))))
(move-beginning-of-line 1)
(setq line (buffer-substring (point) end))
(delete-region (point) end)
(move-beginning-of-line (funcall (if backward '1- '1+) arg))
(insert line)
(org-agenda-reapply-filters)
(org-agenda-mark-clocking-task)
(move-beginning-of-line 0)))))
(defun org-agenda-drag-line-backward (arg)
"Drag an agenda line backward by ARG lines."
(interactive "p")
(org-agenda-drag-line-forward arg t))
;;; Flagging notes
(defun org-agenda-show-the-flagging-note ()
"Display the flagging note in the other window.
When called a second time in direct sequence, offer to remove the FLAGGING
tag and (if present) the flagging note."
(interactive)
(let ((hdmarker (org-get-at-bol 'org-hd-marker))
(win (selected-window))
note) ;; heading newhead
(unless hdmarker
(user-error "No linked entry at point"))
(if (and (eq this-command last-command)
(y-or-n-p "Unflag and remove any flagging note? "))
(progn
(org-agenda-remove-flag hdmarker)
(let ((win (get-buffer-window "*Flagging Note*")))
(and win (delete-window win)))
(message "Entry unflagged"))
(setq note (org-entry-get hdmarker "THEFLAGGINGNOTE"))
(unless note
(user-error "No flagging note"))
(org-kill-new note)
(switch-to-buffer-other-window "*Flagging Note*")
(erase-buffer)
(insert note)
(goto-char (point-min))
(while (re-search-forward "\\\\n" nil t)
(replace-match "\n" t t))
(goto-char (point-min))
(select-window win)
(message "%s" (substitute-command-keys "Flagging note pushed to \
kill ring. Press `\\[org-agenda-show-the-flagging-note]' again to remove \
tag and note")))))
(defun org-agenda-remove-flag (marker)
"Remove the FLAGGED tag and any flagging note in the entry."
(let ((newhead
(org-with-point-at marker
(org-toggle-tag "FLAGGED" 'off)
(org-entry-delete nil "THEFLAGGINGNOTE")
(org-get-heading))))
(org-agenda-change-all-lines newhead marker)
(message "Entry unflagged")))
(defun org-agenda-get-any-marker (&optional pos)
(or (get-text-property (or pos (line-beginning-position)) 'org-hd-marker)
(get-text-property (or pos (line-beginning-position)) 'org-marker)))
;;; Appointment reminders
(defvar appt-time-msg-list) ; defined in appt.el
;;;###autoload
(defun org-agenda-to-appt (&optional refresh filter &rest args)
"Activate appointments found in `org-agenda-files'.
With a `\\[universal-argument]' prefix, refresh the list of \
appointments.
If FILTER is t, interactively prompt the user for a regular
expression, and filter out entries that don't match it.
If FILTER is a string, use this string as a regular expression
for filtering entries out.
If FILTER is a function, filter out entries against which
calling the function returns nil. This function takes one
argument: an entry from `org-agenda-get-day-entries'.
FILTER can also be an alist with the car of each cell being
either `headline' or `category'. For example:
((headline \"IMPORTANT\")
(category \"Work\"))
will only add headlines containing IMPORTANT or headlines
belonging to the \"Work\" category.
ARGS are symbols indicating what kind of entries to consider.
By default `org-agenda-to-appt' will use :deadline*, :scheduled*
\(i.e., deadlines and scheduled items with a hh:mm specification)
and :timestamp entries. See the docstring of `org-diary' for
details and examples.
If an entry has a APPT_WARNTIME property, its value will be used
to override `appt-message-warning-time'."
(interactive "P")
(when refresh (setq appt-time-msg-list nil))
(when (eq filter t)
(setq filter (read-from-minibuffer "Regexp filter: ")))
(let* ((cnt 0) ; count added events
(scope (or args '(:deadline* :scheduled* :timestamp)))
(org-agenda-new-buffers nil)
(org-deadline-warning-days 0)
;; Do not use `org-today' here because appt only takes
;; time and without date as argument, so it may pass wrong
;; information otherwise
(today (org-date-to-gregorian
(time-to-days nil)))
(org-agenda-restrict nil)
(files (org-agenda-files 'unrestricted)) entries file
(org-agenda-buffer nil))
;; Get all entries which may contain an appt
(org-agenda-prepare-buffers files)
(while (setq file (pop files))
(setq entries
(delq nil
(append entries
(apply #'org-agenda-get-day-entries
file today scope)))))
;; Map through entries and find if we should filter them out
(mapc
(lambda (x)
(let* ((evt (org-trim
(replace-regexp-in-string
org-link-bracket-re "\\2"
(or (get-text-property 1 'txt x) ""))))
(cat (get-text-property (1- (length x)) 'org-category x))
(tod (get-text-property 1 'time-of-day x))
(ok (or (null filter)
(and (stringp filter) (string-match filter evt))
(and (functionp filter) (funcall filter x))
(and (listp filter)
(let ((cat-filter (cadr (assq 'category filter)))
(evt-filter (cadr (assq 'headline filter))))
(or (and (stringp cat-filter)
(string-match cat-filter cat))
(and (stringp evt-filter)
(string-match evt-filter evt)))))))
(wrn (get-text-property 1 'warntime x))
(todo-regexp (get-text-property 1 'org-todo-regexp x))
(not-done-regexp (get-text-property 1 'org-not-done-regexp x)))
;; FIXME: Shall we remove text-properties for the appt text?
;; (setq evt (set-text-properties 0 (length evt) nil evt))
(when (and ok tod
;; Exclude done items unconditionally.
(or (not (and todo-regexp (string-match-p todo-regexp evt))) ; no todo keyword
(and not-done-regexp (string-match-p not-done-regexp evt)) ; or not done
))
(setq tod (concat "00" (number-to-string tod)))
(setq tod (when (string-match
"\\([0-9]\\{1,2\\}\\)\\([0-9]\\{2\\}\\)\\'" tod)
(concat (match-string 1 tod) ":"
(match-string 2 tod))))
(when (appt-add tod evt wrn)
(setq cnt (1+ cnt))))))
entries)
(org-release-buffers org-agenda-new-buffers)
(if (eq cnt 0)
(message "No event to add")
(message "Added %d event%s for today" cnt (if (> cnt 1) "s" "")))))
(defun org-agenda-today-p (date)
"Non-nil when DATE means today.
DATE is either a list of the form (month day year) or a number of
days as returned by `calendar-absolute-from-gregorian' or
`org-today'. This function considers `org-extend-today-until'
when defining today."
(eq (org-today)
(if (consp date) (calendar-absolute-from-gregorian date) date)))
(defun org-agenda-todo-yesterday (&optional arg)
"Like `org-agenda-todo' but the time of change will be 23:59 of yesterday."
(interactive "P")
(let* ((org-use-effective-time t)
(hour (nth 2 (decode-time (org-current-time))))
(org-extend-today-until (1+ hour)))
(org-agenda-todo arg)))
(defun org-agenda-ctrl-c-ctrl-c ()
"Set tags in agenda buffer."
(interactive)
(org-agenda-set-tags))
(provide 'org-agenda)
;;; org-agenda.el ends here
org-mode-9.7.29+dfsg/lisp/org-archive.el 0000664 0000000 0000000 00000060145 15004304337 0017756 0 ustar 00root root 0000000 0000000 ;;; org-archive.el --- Archiving for Org -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2025 Free Software Foundation, Inc.
;; Author: Carsten Dominik
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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
;; Restructurer: Gustav Wikström
;; Keywords: org data git
;; 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
;; Keywords: org data attachment
;; 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
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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 Capture buffer. Finish \
`\\[org-capture-finalize]', refile `\\[org-capture-refile]', \
abort `\\[org-capture-kill]'.")))
;;; The main commands
(defvar org-capture-initial nil)
(defvar org-capture-entry nil)
;;;###autoload
(defun org-capture-string (string &optional keys)
"Capture STRING with the template selected by KEYS."
(interactive "sInitial text: \n")
(let ((org-capture-initial string)
(org-capture-entry (org-capture-select-template keys)))
(org-capture)))
(defcustom org-capture-templates-contexts nil
"Alist of capture templates and valid contexts.
For example, if you have a capture template \"c\" and you want
this template to be accessible only from `message-mode' buffers,
use this:
(setq org-capture-templates-contexts
\\='((\"c\" ((in-mode . \"message-mode\")))
(\"d\" (my-context-function
(in-mode . \"org-mode\")))))
Here are the available contexts definitions:
in-file: command displayed only in matching files
in-mode: command displayed only in matching modes
not-in-file: command not displayed in matching files
not-in-mode: command not displayed in matching modes
in-buffer: command displayed only in matching buffers
not-in-buffer: command not displayed in matching buffers
[function]: a custom function taking no argument
If you define several checks, the agenda command will be
accessible if there is at least one valid check.
You can also bind a key to another capture template depending on
contextual rules.
(setq org-capture-templates-contexts
\\='((\"c\" \"d\" ((in-mode . \"message-mode\")))))
Here it means: in `message-mode buffers', use \"c\" as the
key for the capture template otherwise associated with \"d\".
\(The template originally associated with \"d\" is not displayed
to avoid duplicates.)"
:version "24.3"
:group 'org-capture
:type '(repeat (list :tag "Rule"
(string :tag " Capture key")
(string :tag "Replace by template")
(repeat :tag "Available when"
(choice
(cons :tag "Condition"
(choice
(const :tag "In file" in-file)
(const :tag "Not in file" not-in-file)
(const :tag "In buffer" in-buffer)
(const :tag "Not in buffer" not-in-buffer)
(const :tag "In mode" in-mode)
(const :tag "Not in mode" not-in-mode))
(regexp))
(function :tag "Custom function"))))))
(defcustom org-capture-use-agenda-date nil
"Non-nil means use the date at point when capturing from agendas.
When nil, you can still capture using the date at point with
`\\[org-agenda-capture]'."
:group 'org-capture
:version "24.3"
:type 'boolean)
;;;###autoload
(defun org-capture (&optional goto keys)
"Capture something.
\\
This will let you select a template from `org-capture-templates', and
then file the newly captured information. The text is immediately
inserted at the target location, and an indirect buffer is shown where
you can edit it. Pressing `\\[org-capture-finalize]' brings you back to the \
previous
state of Emacs, so that you can continue your work.
When called interactively with a `\\[universal-argument]' prefix argument \
GOTO, don't
capture anything, just go to the file/headline where the selected
template stores its notes.
With a `\\[universal-argument] \\[universal-argument]' prefix argument, go to \
the last note stored.
When called with a `C-0' (zero) prefix, insert a template at point.
When called with a `C-1' (one) prefix, force prompting for a date when
a datetree entry is made.
Elisp programs can set KEYS to a string associated with a template
in `org-capture-templates'. In this case, interactive selection
will be bypassed.
If `org-capture-use-agenda-date' is non-nil, capturing from the
agenda will use the date at point as the default date. Then, a
`C-1' prefix will tell the capture process to use the HH:MM time
of the day at point (if any) or the current HH:MM time."
(interactive "P")
(when (and org-capture-use-agenda-date
(eq major-mode 'org-agenda-mode))
(setq org-overriding-default-time
(org-get-cursor-date (equal goto 1))))
(cond
((equal goto '(4)) (org-capture-goto-target keys))
((equal goto '(16)) (org-capture-goto-last-stored))
(t
(let* ((orig-buf (current-buffer))
(annotation (if (and (boundp 'org-capture-link-is-already-stored)
org-capture-link-is-already-stored)
(plist-get org-store-link-plist :annotation)
(ignore-errors (org-store-link nil))))
(entry (or org-capture-entry (org-capture-select-template keys)))
initial)
(setq initial (or org-capture-initial
(and (org-region-active-p)
(buffer-substring (point) (mark)))))
(when (stringp initial)
(remove-text-properties 0 (length initial) '(read-only t) initial))
(when (stringp annotation)
(remove-text-properties 0 (length annotation)
'(read-only t) annotation))
(cond
((equal entry "C")
(customize-variable 'org-capture-templates))
((equal entry "q")
(user-error "Abort"))
(t
(org-capture-set-plist entry)
(org-capture-get-template)
(org-capture-put :original-buffer orig-buf
:original-file (or (buffer-file-name orig-buf)
(and (featurep 'dired)
(car (rassq orig-buf
dired-buffers))))
:original-file-nondirectory
(and (buffer-file-name orig-buf)
(file-name-nondirectory
(buffer-file-name orig-buf)))
:annotation annotation
:initial initial
:return-to-wconf (current-window-configuration)
:default-time (or org-overriding-default-time
(org-current-time)))
(org-capture-set-target-location (and (equal goto 0) 'here))
(condition-case error
(org-capture-put :template (org-capture-fill-template))
((error quit)
(if (get-buffer "*Capture*") (kill-buffer "*Capture*"))
(error "Capture abort: %s" (error-message-string error))))
(setq org-capture-clock-keep (org-capture-get :clock-keep))
(condition-case error
(org-capture-place-template
(eq (car (org-capture-get :target)) 'function))
((error quit)
(when (and (buffer-base-buffer (current-buffer))
(string-prefix-p "CAPTURE-" (buffer-name)))
(kill-buffer (current-buffer)))
(set-window-configuration (org-capture-get :return-to-wconf))
(error "Capture template `%s': %s"
(org-capture-get :key)
(error-message-string error))))
(when (and (derived-mode-p 'org-mode) (org-capture-get :clock-in))
(condition-case nil
(progn
(when (org-clock-is-active)
(org-capture-put :interrupted-clock
(copy-marker org-clock-marker)))
(org-clock-in)
(setq-local org-capture-clock-was-started
(copy-marker org-clock-marker)))
(error "Could not start the clock in this capture buffer")))
(when (org-capture-get :immediate-finish)
(org-capture-finalize))))))))
(defun org-capture-get-template ()
"Get the template from a file or a function if necessary."
(org-capture-put
:template
(pcase (org-capture-get :template)
(`nil "")
((and (pred stringp) template) template)
(`(file ,file)
(let ((filename (expand-file-name file org-directory)))
(if (file-exists-p filename) (org-file-contents filename)
(format "* Template file %S not found" file))))
(`(function ,f)
(if (functionp f) (funcall f)
(format "* Template function %S not found" f)))
(_ "* Invalid capture template"))))
(defun org-capture--run-template-functions (keyword &optional local)
"Run functions associated with KEYWORD on template's plist.
For valid values of KEYWORD see `org-capture-templates'.
If LOCAL is non-nil use the buffer-local value of `org-capture-plist'."
;; Used in place of `run-hooks' because these functions have no associated symbol.
;; They are stored directly on `org-capture-plist'.
(let ((value (org-capture-get keyword local)))
(if (functionp value)
(funcall value)
(mapc #'funcall value))))
(defun org-capture-finalize (&optional stay-with-capture)
"Finalize the capture process.
With prefix argument STAY-WITH-CAPTURE, jump to the location of the
captured item after finalizing."
(interactive "P")
(when (org-capture-get :jump-to-captured)
(setq stay-with-capture t))
(unless (and org-capture-mode
(buffer-base-buffer (current-buffer)))
(error "This does not seem to be a capture buffer for Org mode"))
(org-capture--run-template-functions :prepare-finalize 'local)
(run-hooks 'org-capture-prepare-finalize-hook)
;; Update `org-capture-plist' with the buffer-local value. Since
;; captures can be run concurrently, this is to ensure that
;; `org-capture-after-finalize-hook' accesses the proper plist.
(setq org-capture-plist org-capture-current-plist)
;; Did we start the clock in this capture buffer?
(when (and org-capture-clock-was-started
(equal org-clock-marker org-capture-clock-was-started))
;; Looks like the clock we started is still running.
(if org-capture-clock-keep
;; User may have completed clocked heading from the template.
;; Refresh clock mode line.
(org-clock-update-mode-line t)
;; Clock out. Possibly resume interrupted clock.
(let (org-log-note-clock-out) (org-clock-out))
(when (and (org-capture-get :clock-resume 'local)
(markerp (org-capture-get :interrupted-clock 'local))
(buffer-live-p (marker-buffer
(org-capture-get :interrupted-clock 'local))))
(let ((clock-in-task (org-capture-get :interrupted-clock 'local)))
(org-with-point-at clock-in-task (org-clock-in)))
(message "Interrupted clock has been resumed"))))
(let ((abort-note nil))
;; Store the size of the capture buffer
(org-capture-put :captured-entry-size (- (point-max) (point-min)))
(widen)
;; Store the insertion point in the target buffer
(org-capture-put :insertion-point (point))
(if org-note-abort
(let ((beg (org-capture-get :begin-marker 'local))
(end (org-capture-get :end-marker 'local)))
(if (not (and beg end)) (setq abort-note 'dirty)
(setq abort-note t)
(org-with-wide-buffer (kill-region beg end))))
;; Postprocessing: Update Statistics cookies, do the sorting
(when (derived-mode-p 'org-mode)
(save-excursion
(when (ignore-errors (org-back-to-heading))
(org-update-parent-todo-statistics)
(org-update-checkbox-count)))
;; FIXME Here we should do the sorting
;; If we have added a table line, maybe recompute?
(when (and (eq (org-capture-get :type 'local) 'table-line)
(org-at-table-p))
(if (not (org-table-get-stored-formulas)) (org-table-align)
;; Adjust formulas, if necessary. We assume a non-nil
;; `:immediate-finish' means that no confirmation is
;; required. Else, obey `org-table-fix-formulas-confirm'.
;;
;; The delta required to fix formulas depends on the
;; number of rows inserted by the template.
(when (or (org-capture-get :immediate-finish)
(not org-table-fix-formulas-confirm)
(funcall org-table-fix-formulas-confirm "Fix formulas? "))
(org-table-fix-formulas
"@" nil (1- (org-table-current-dline))
(count-lines (org-capture-get :begin-marker 'local)
(org-capture-get :end-marker 'local))))
(org-table-recalculate 'all)))) ;FIXME: should we iterate?
;; Store this place as the last one where we stored something
;; Do the marking in the base buffer, so that it makes sense after
;; the indirect buffer has been killed.
(org-capture-store-last-position)
(org-capture--run-template-functions :before-finalize 'local)
;; Run the hook
(run-hooks 'org-capture-before-finalize-hook))
(when (org-capture-get :decrypted)
(save-excursion
(goto-char (org-capture-get :decrypted))
(org-encrypt-entry)))
(unless (org-capture-get :no-save) (save-buffer))
(let ((return-wconf (org-capture-get :return-to-wconf 'local))
(new-buffer (org-capture-get :new-buffer 'local))
(kill-buffer (org-capture-get :kill-buffer 'local))
(base-buffer (buffer-base-buffer (current-buffer))))
;; Kill the indirect buffer
(kill-buffer (current-buffer))
;; Narrow back the target buffer to its previous state
(with-current-buffer (org-capture-get :buffer)
(let ((reg (org-capture-get :initial-target-region))
(pos (org-capture-get :initial-target-position))
(ipt (org-capture-get :insertion-point))
(size (org-capture-get :captured-entry-size)))
(if (not reg)
(widen)
(cond ((< ipt (car reg))
;; insertion point is before the narrowed region
(narrow-to-region (+ size (car reg)) (+ size (cdr reg))))
((> ipt (cdr reg))
;; insertion point is after the narrowed region
(narrow-to-region (car reg) (cdr reg)))
(t
;; insertion point is within the narrowed region
(narrow-to-region (car reg) (+ size (cdr reg)))))
;; now place back the point at its original position
(if (< ipt (car reg))
(goto-char (+ size pos))
(goto-char (if (< ipt pos) (+ size pos) pos))))))
(if (and base-buffer org-note-abort new-buffer)
;; Unconditionally kill the new buffer when capture is
;; aborted.
(with-current-buffer base-buffer
(set-buffer-modified-p nil)
(kill-buffer))
;; Kill the target buffer if that is desired
(when (and base-buffer new-buffer kill-buffer)
(with-current-buffer base-buffer (save-buffer))
(kill-buffer base-buffer)))
;; Restore the window configuration before capture
(set-window-configuration return-wconf))
;; Do not use the local arg to `org-capture--run-template-functions' here.
;; The buffer-local value has been stored on `org-capture-plist'.
(org-capture--run-template-functions :after-finalize)
(run-hooks 'org-capture-after-finalize-hook)
;; Special cases
(cond
(abort-note
(cl-case abort-note
(clean
(message "Capture process aborted and target buffer cleaned up"))
(dirty
(error "Capture process aborted, but target buffer could not be \
cleaned up correctly"))))
(stay-with-capture
(org-capture-goto-last-stored)))
;; Return if we did store something
(not abort-note)))
(defun org-capture-refile ()
"Finalize the current capture and then refile the entry.
Refiling is done from the base buffer, because the indirect buffer is then
already gone. Any prefix argument will be passed to the refile command."
(interactive)
(unless (eq (org-capture-get :type 'local) 'entry)
(user-error "Refiling from a capture buffer makes only sense \
for `entry'-type templates"))
(let* ((base (or (buffer-base-buffer) (current-buffer)))
(pos (make-marker))
(org-capture-is-refiling t)
(kill-buffer (org-capture-get :kill-buffer 'local))
(jump-to-captured (org-capture-get :jump-to-captured 'local))
(refile-targets (org-capture-get :refile-targets 'local)))
;; Since `org-capture-finalize' may alter buffer contents (e.g.,
;; empty lines) around entry, use a marker to refer to the
;; headline to be refiled. Place the marker in the base buffer,
;; as the current indirect one is going to be killed.
(set-marker pos (save-excursion (org-back-to-heading t) (point)) base)
;; `org-capture-finalize' calls `org-capture-goto-last-stored' too
;; early. We want to wait for the refiling to be over, so we
;; control when the latter function is called.
(org-capture-put :kill-buffer nil :jump-to-captured nil)
(let ((org-refile-targets (or refile-targets org-refile-targets)))
(org-capture-finalize)
(save-window-excursion
(with-current-buffer base
(org-with-point-at pos
(call-interactively 'org-refile)))))
(when kill-buffer
(with-current-buffer base (save-buffer))
(kill-buffer base))
(when jump-to-captured (org-capture-goto-last-stored))))
(defun org-capture-kill ()
"Abort the current capture process."
(interactive)
;; FIXME: This does not do the right thing, we need to remove the
;; new stuff by hand it is easy: undo, then kill the buffer
(let ((org-note-abort t)
(org-capture-before-finalize-hook nil))
(org-capture-finalize)))
(defun org-capture-goto-last-stored ()
"Go to the location where the last capture note was stored."
(interactive)
(org-goto-marker-or-bmk org-capture-last-stored-marker
(plist-get org-bookmark-names-plist
:last-capture))
(message "This is the last note stored by a capture process"))
;;; Supporting functions for handling the process
(defun org-capture-put-target-region-and-position ()
"Store the initial region with `org-capture-put'."
(org-capture-put
:initial-target-region
;; Check if the buffer is currently narrowed
(when (org-buffer-narrowed-p)
(cons (point-min) (point-max))))
;; store the current point
(org-capture-put :initial-target-position (point)))
(defvar org-time-was-given) ; dynamically scoped parameter
(defun org-capture-set-target-location (&optional target)
"Find TARGET buffer and position.
Store them in the capture property list."
(let ((target-entry-p t))
(save-excursion
(pcase (or target (org-capture-get :target))
((or `here
`(here))
(org-capture-put :exact-position (point) :insert-here t))
(`(file ,path)
(set-buffer (org-capture-target-buffer path))
(org-capture-put-target-region-and-position)
(widen)
(setq target-entry-p nil))
(`(id ,(and id (or (pred stringp) (pred symbolp))))
(pcase (org-id-find id)
(`(,path . ,position)
(set-buffer (org-capture-target-buffer path))
(widen)
(org-capture-put-target-region-and-position)
(goto-char position))
(_ (error "Cannot find target ID \"%s\"" id))))
(`(file+headline ,path ,(and headline (pred stringp)))
(set-buffer (org-capture-target-buffer path))
;; Org expects the target file to be in Org mode, otherwise
;; it throws an error. However, the default notes files
;; should work out of the box. In this case, we switch it to
;; Org mode.
(unless (derived-mode-p 'org-mode)
(org-display-warning
(format "Capture requirement: switching buffer %S to Org mode"
(current-buffer)))
(org-mode))
(org-capture-put-target-region-and-position)
(widen)
(goto-char (point-min))
(if (re-search-forward (format org-complex-heading-regexp-format
(regexp-quote headline))
nil t)
(forward-line 0)
(goto-char (point-max))
(unless (bolp) (insert "\n"))
(insert "* " headline "\n")
(forward-line -1)))
(`(file+olp ,path . ,(and outline-path (guard outline-path)))
(let ((m (org-find-olp (cons (org-capture-expand-file path)
outline-path))))
(set-buffer (marker-buffer m))
(org-capture-put-target-region-and-position)
(widen)
(goto-char m)
(set-marker m nil)))
(`(file+regexp ,path ,(and regexp (pred stringp)))
(set-buffer (org-capture-target-buffer path))
(org-capture-put-target-region-and-position)
(widen)
(goto-char (point-min))
(if (not (re-search-forward regexp nil t))
(error "No match for target regexp in file %s" path)
(goto-char (if (org-capture-get :prepend)
(match-beginning 0)
(match-end 0)))
(org-capture-put :exact-position (point))
(setq target-entry-p
(and (derived-mode-p 'org-mode) (org-at-heading-p)))))
(`(file+olp+datetree ,path . ,outline-path)
(let ((m (if outline-path
(org-find-olp (cons (org-capture-expand-file path)
outline-path))
(set-buffer (org-capture-target-buffer path))
(point-marker))))
(set-buffer (marker-buffer m))
(org-capture-put-target-region-and-position)
(widen)
(goto-char m)
(set-marker m nil)
(require 'org-datetree)
(org-capture-put-target-region-and-position)
(widen)
;; Make a date/week tree entry, with the current date (or
;; yesterday, if we are extending dates for a couple of
;; hours)
(funcall
(pcase (org-capture-get :tree-type)
(`week #'org-datetree-find-iso-week-create)
(`month #'org-datetree-find-month-create)
(_ #'org-datetree-find-date-create))
(calendar-gregorian-from-absolute
(cond
(org-overriding-default-time
;; Use the overriding default time.
(time-to-days org-overriding-default-time))
((or (org-capture-get :time-prompt)
(equal current-prefix-arg 1))
;; Prompt for date. Bind `org-end-time-was-given' so
;; that `org-read-date-analyze' handles the time range
;; case and returns `prompt-time' with the start value.
(let* ((org-time-was-given nil)
(org-end-time-was-given nil)
(prompt-time (org-read-date
nil t nil "Date for tree entry:")))
(org-capture-put
:default-time
(if (or org-time-was-given
(= (time-to-days prompt-time) (org-today)))
prompt-time
;; Use 00:00 when no time is given for another
;; date than today?
(org-encode-time
(apply #'list
0 0 org-extend-today-until
(cl-cdddr (decode-time prompt-time))))))
(time-to-days prompt-time)))
(t
;; Current date, possibly corrected for late night
;; workers.
(org-today))))
;; the following is the keep-restriction argument for
;; org-datetree-find-date-create
(when outline-path 'subtree-at-point))))
(`(file+function ,path ,(and function (pred functionp)))
(set-buffer (org-capture-target-buffer path))
(org-capture-put-target-region-and-position)
(widen)
(funcall function)
(org-capture-put :exact-position (point))
(setq target-entry-p
(and (derived-mode-p 'org-mode) (org-at-heading-p))))
(`(function ,(and fun (pred functionp)))
(funcall fun)
(org-capture-put :exact-position (point))
(setq target-entry-p
(and (derived-mode-p 'org-mode) (org-at-heading-p))))
(`(clock)
(if (and (markerp org-clock-hd-marker)
(marker-buffer org-clock-hd-marker))
(progn (set-buffer (marker-buffer org-clock-hd-marker))
(org-capture-put-target-region-and-position)
(widen)
(goto-char org-clock-hd-marker))
(user-error "No running clock that could be used as capture target")))
(target (error "Invalid capture target specification: %S" target)))
(org-capture-put :buffer (current-buffer)
:pos (point)
:target-entry-p target-entry-p
:decrypted
(and (featurep 'org-crypt)
(org-at-encrypted-entry-p)
(save-excursion
(org-decrypt-entry)
(and (org-back-to-heading t) (point))))))))
(defun org-capture-expand-file (file)
"Expand functions, symbols and file names for FILE.
When FILE is a function, call it. When it is a form, evaluate
it. When it is a variable, return its value. When it is
a string, treat it as a file name, possibly expanding it
according to `org-directory', and return it. If it is the empty
string, however, return `org-default-notes-file'. In any other
case, raise an error."
(let ((location (cond ((equal file "") org-default-notes-file)
((stringp file) (expand-file-name file org-directory))
((functionp file) (funcall file))
((and (symbolp file) (boundp file)) (symbol-value file))
(t nil))))
(or (org-string-nw-p location)
(error "Invalid file location: %S" location))))
(defun org-capture-target-buffer (file)
"Get a buffer for FILE.
FILE is a generalized file location, as handled by
`org-capture-expand-file'."
(let ((file (org-capture-expand-file file)))
(or (org-find-base-buffer-visiting file)
(progn (org-capture-put :new-buffer t)
(find-file-noselect file)))))
(defun org-capture-place-template (&optional inhibit-wconf-store)
"Insert the template at the target location, and display the buffer.
When INHIBIT-WCONF-STORE is non-nil, don't store the window configuration, as it
may have been stored before."
(unless inhibit-wconf-store
(org-capture-put :return-to-wconf (current-window-configuration)))
(pop-to-buffer
(org-capture-get-indirect-buffer (org-capture-get :buffer) "CAPTURE")
'(org-display-buffer-split))
(widen)
(org-fold-show-all)
(goto-char (org-capture-get :pos))
(setq-local outline-level 'org-outline-level)
(pcase (org-capture-get :type)
((or `nil `entry) (org-capture-place-entry))
(`table-line (org-capture-place-table-line))
(`plain (org-capture-place-plain-text))
(`item (org-capture-place-item))
(`checkitem (org-capture-place-item)))
(setq-local org-capture-current-plist org-capture-plist)
(org-capture--run-template-functions :hook 'local)
(org-capture-mode 1))
(defun org-capture-place-entry ()
"Place the template as a new Org entry."
(let ((template (org-capture-get :template))
(reversed? (org-capture-get :prepend))
(exact-position (org-capture-get :exact-position))
(insert-here? (org-capture-get :insert-here))
(level 1))
(org-capture-verify-tree template)
(when exact-position (goto-char exact-position))
(cond
;; Force insertion at point.
(insert-here?
;; FIXME: level should probably set directly within (let ...).
(setq level (org-get-valid-level
(if (or (org-at-heading-p)
(ignore-errors
(save-excursion (org-back-to-heading t))))
(org-outline-level)
1))))
;; Insert as a child of the current entry.
((org-capture-get :target-entry-p)
(setq level (org-get-valid-level
(if (org-at-heading-p) (org-outline-level) 1)
1))
(if reversed? (outline-next-heading) (org-end-of-subtree t t)))
;; Insert as a top-level entry at the beginning of the file.
(reversed?
(goto-char (point-min))
(unless (org-at-heading-p) (outline-next-heading)))
;; Otherwise, insert as a top-level entry at the end of the file.
(t (goto-char (point-max))
;; Make sure that last point is not folded.
(org-fold-core-cycle-over-indirect-buffers
(org-fold-region (max 1 (1- (point-max))) (point-max) nil))))
(let ((origin (point-marker)))
(unless (bolp) (insert "\n"))
(org-capture-empty-lines-before)
(let ((beg (point)))
(save-restriction
(when insert-here? (narrow-to-region beg beg))
(org-paste-subtree level template 'for-yank))
(org-capture-position-for-last-stored beg)
(org-capture-empty-lines-after)
(unless (org-at-heading-p) (outline-next-heading))
(org-capture-mark-kill-region origin (point))
(org-capture-narrow beg (if (eobp) (point) (1- (point))))
(org-capture--position-cursor beg (point))))))
(defun org-capture-place-item ()
"Place the template as a new plain list item."
(let ((prepend? (org-capture-get :prepend))
(template (org-remove-indentation (org-capture-get :template)))
item)
;; Make template suitable for insertion. In particular, add
;; a main bullet if it is missing.
(unless (string-match-p (concat "\\`" (org-item-re)) template)
(setq template (concat "- " (mapconcat #'identity
(split-string template "\n")
"\n "))))
;; Delimit the area where we should look for a plain list.
(pcase-let ((`(,beg . ,end)
(cond ((org-capture-get :exact-position)
;; User gave a specific position. Start
;; looking for lists from here.
(org-with-point-at (org-capture-get :exact-position)
(cons (line-beginning-position)
(if (org-capture-get :insert-here)
(line-beginning-position)
(org-entry-end-position)))))
((org-capture-get :target-entry-p)
;; At a heading, limit search to its body.
(cons (line-beginning-position 2)
(org-entry-end-position)))
(t
;; Table is not necessarily under a heading.
;; Search whole buffer.
(cons (point-min) (point-max))))))
;; Find the first plain list in the delimited area.
(goto-char beg)
(let ((item-regexp (org-item-beginning-re)))
(catch :found
(while (re-search-forward item-regexp end t)
(when (setq item (org-element-lineage
(org-element-at-point) 'plain-list t))
(goto-char (org-element-property (if prepend? :post-affiliated
:contents-end)
item))
(throw :found t)))
;; No list found. Move to the location when to insert
;; template. Skip planning info and properties drawers, if
;; any.
(goto-char (cond ((org-capture-get :insert-here) beg)
((not prepend?) end)
((org-before-first-heading-p) beg)
(t (max (save-excursion
(org-end-of-meta-data)
(point))
beg)))))))
;; Insert template.
(let ((origin (point-marker)))
(unless (bolp) (insert "\n"))
;; When a new list is created, always obey to `:empty-lines' and
;; friends.
;;
;; When capturing in an existing list, do not change blank lines
;; above or below the list; consider it to be a stable
;; structure. However, we can control how many blank lines
;; separate items. So obey to `:empty-lines' between items as
;; long as it does not insert more than one empty line. In the
;; specific case of empty lines above, it means we only obey the
;; parameter when appending an item.
(unless (and item prepend?)
(org-capture-empty-lines-before
(and item
(not prepend?)
(min 1 (or (org-capture-get :empty-lines-before)
(org-capture-get :empty-lines)
0)))))
(org-capture-position-for-last-stored (point))
(let ((beg (line-beginning-position))
(end (progn
(insert (org-trim template) "\n")
(point-marker))))
(when item
(let ((i (save-excursion
(goto-char (org-element-post-affiliated item))
(org-current-text-indentation))))
(save-excursion
(goto-char beg)
(save-excursion
(while (< (point) end)
(indent-to i)
(forward-line)))
;; Prepending an item could change the type of the list
;; if there is a mismatch. In this situation,
;; prioritize the existing list.
(when prepend?
(let ((ordered? (eq 'ordered (org-element-property :type item))))
(when (org-xor ordered?
(string-match-p "\\`[A-Za-z0-9]\\([.)]\\)"
template))
(org-cycle-list-bullet (if ordered? "1." "-")))))
;; Eventually repair the list for proper indentation and
;; bullets.
(org-list-repair))))
;; Limit number of empty lines. See above for details.
(unless (and item (not prepend?))
(org-capture-empty-lines-after
(and item
prepend?
(min 1 (or (org-capture-get :empty-lines-after)
(org-capture-get :empty-lines)
0)))))
(org-capture-mark-kill-region origin (point))
;; ITEM always end with a newline character. Make sure we do
;; not narrow at the beginning of the next line, possibly
;; altering its structure (e.g., when it is a headline).
(org-capture-narrow beg (1- end))
(org-capture--position-cursor beg end)))))
(defun org-capture-place-table-line ()
"Place the template as a table line."
(require 'org-table)
(let ((text
(pcase (org-trim (org-capture-get :template))
((pred (string-match-p org-table-border-regexp))
"| %?Bad template |")
(text (concat text "\n"))))
(table-line-pos (org-capture-get :table-line-pos))
beg end)
(cond
((org-capture-get :exact-position)
(org-with-point-at (org-capture-get :exact-position)
(setq beg (line-beginning-position))
(setq end (if (org-capture-get :insert-here) beg
(org-entry-end-position)))))
((not (org-capture-get :target-entry-p))
;; Table is not necessarily under a heading. Find first table
;; in the buffer.
(setq beg (point-min) end (point-max)))
(t
;; We are at a heading, limit search to the body.
(setq beg (line-beginning-position 2))
(setq end (save-excursion (outline-next-heading) (point)))))
(goto-char beg)
;; Narrow to the table, possibly creating one if necessary.
(catch :found
(while (re-search-forward org-table-dataline-regexp end t)
(pcase (org-element-lineage (org-element-at-point) 'table t)
(`nil nil)
((pred (lambda (e) (eq 'table.el (org-element-property :type e))))
nil)
(table
(goto-char (org-element-contents-end table))
(narrow-to-region (org-element-post-affiliated table)
(point))
(throw :found t))))
;; No table found. Create it with an empty header.
(goto-char end)
(unless (bolp) (insert "\n"))
(let ((origin (point-marker)))
(insert "| |\n|---|\n")
(narrow-to-region origin (point))))
;; In the current table, find the appropriate location for TEXT.
(cond
((org-capture-get :insert-here) nil)
((and table-line-pos
(string-match "\\(I+\\)\\([-+][0-9]+\\)" table-line-pos))
(goto-char (point-min))
(let ((line
(condition-case _
(progn
(save-match-data (org-table-analyze))
(aref org-table-hlines
(- (match-end 1) (match-beginning 1))))
(error
(error "Invalid table line specification %S" table-line-pos))))
(delta (string-to-number (match-string 2 table-line-pos))))
(forward-line (+ line delta (if (< delta 0) 0 -1)))
(forward-line))) ;insert below
((org-capture-get :prepend)
(goto-char (point-min))
(cond
((not (re-search-forward org-table-hline-regexp nil t)))
((re-search-forward org-table-dataline-regexp nil t) (forward-line 0))
(t (goto-char (org-table-end)))))
(t
(goto-char (org-table-end))))
;; Insert text and position point according to template.
(let ((origin (point-marker)))
(unless (bolp) (insert "\n"))
(let ((beg (point))
(end (save-excursion
(insert text)
(point))))
(org-capture-position-for-last-stored 'table-line)
(org-capture-mark-kill-region origin end)
;; TEXT is guaranteed to end with a newline character. Ignore
;; it when narrowing so as to not alter data on the next line.
(org-capture-narrow beg (1- end))
(org-capture--position-cursor beg (1- end))))))
(defun org-capture-place-plain-text ()
"Place the template plainly.
If the target locator points at an Org node, place the template into
the text of the entry, before the first child. If not, place the
template at the beginning or end of the file.
Of course, if exact position has been required, just put it there."
(cond
((org-capture-get :exact-position)
(goto-char (org-capture-get :exact-position)))
((org-capture-get :target-entry-p)
;; Place the text into this entry.
(if (org-capture-get :prepend)
;; Skip meta data and drawers.
(org-end-of-meta-data t)
;; Go to end of the entry text, before the next headline.
(outline-next-heading)))
(t
;; Beginning or end of file.
(goto-char (if (org-capture-get :prepend) (point-min) (point-max)))))
(let ((origin (point-marker)))
(unless (bolp) (insert "\n"))
(org-capture-empty-lines-before)
(org-capture-position-for-last-stored (point))
(let ((beg (point)))
(insert (org-capture-get :template))
(unless (bolp) (insert "\n"))
;; Ignore the final newline character so as to not alter data
;; after inserted text. Yet, if the template is empty, make
;; sure END matches BEG instead of pointing before it.
(let ((end (max beg (1- (point)))))
(org-capture-empty-lines-after)
(org-capture-mark-kill-region origin (point))
(org-capture-narrow beg end)
(org-capture--position-cursor beg end)))))
(defun org-capture-mark-kill-region (beg end)
"Mark region between BEG and END to be killed on aborted capture."
(let ((m1 (copy-marker beg))
(m2 (copy-marker end t)))
(org-capture-put :begin-marker m1)
(org-capture-put :end-marker m2)))
(defun org-capture-position-for-last-stored (position)
"Put POSITION on `org-capture-plist' for future use as `last capture`."
(cond
((integerp position)
(org-capture-put :position-for-last-stored
(move-marker (make-marker) position
(or (buffer-base-buffer (current-buffer))
(current-buffer)))))
((eq position 'table-line)
(org-capture-put :position-for-last-stored
(list 'table-line
(org-table-current-dline))))
(t (error "This should not happen"))))
(defun org-capture-store-last-position ()
"Store the last-captured position."
(let* ((where (org-capture-get :position-for-last-stored 'local))
(pos (cond
((markerp where)
(prog1 (marker-position where)
(move-marker where nil)))
((and (listp where) (eq (car where) 'table-line))
(if (org-at-table-p)
(save-excursion
(org-table-goto-line (nth 1 where))
(line-beginning-position))
(point))))))
(with-current-buffer (buffer-base-buffer (current-buffer))
(org-with-point-at pos
;; FIXME: `org-capture-bookmark' is obsolete. To be removed
;; in future Org releases.
(when (with-no-warnings org-capture-bookmark)
(let ((bookmark (plist-get org-bookmark-names-plist :last-capture)))
(when bookmark
(condition-case err
(bookmark-set bookmark)
(error
(message "Bookmark set error: %S" err))))))
(move-marker org-capture-last-stored-marker (point))))))
(defun org-capture-narrow (beg end)
"Possibly narrow to region between BEG and END.
If configuration contains non-nil :unnarrowed property, do not narrow."
(unless (org-capture-get :unnarrowed)
(narrow-to-region beg end)))
(defun org-capture--position-cursor (beg end)
"Move point to first \"%?\" location or at start of template.
BEG and END are buffer positions at the beginning and end position
of the template."
(goto-char beg)
(when (search-forward "%?" end t)
(replace-match "")))
(defun org-capture-empty-lines-before (&optional n)
"Insert N empty lines before the insertion point.
Point will be after the empty lines, so insertion can directly be done.
If N is nil, :empty-lines-before or :empty-lines are considered."
(setq n (or n (org-capture-get :empty-lines-before)
(org-capture-get :empty-lines) 0))
(let ((pos (point)))
(org-back-over-empty-lines)
(delete-region (point) pos)
(when (> n 0) (newline n))))
(defun org-capture-empty-lines-after (&optional n)
"Set the correct number of empty lines after the inserted string.
Point will remain at the first line after the inserted text.
If N is nil, :empty-lines-after or :empty-lines are considered."
(setq n (or n (org-capture-get :empty-lines-after)
(org-capture-get :empty-lines) 0))
(org-back-over-empty-lines)
(while (looking-at "[ \t]*\n") (replace-match ""))
(let ((pos (point)))
(when (> n 0) (newline n))
(goto-char pos)))
(defvar org-clock-marker) ; Defined in org.el
(defun org-capture-set-plist (entry)
"Initialize the property list for ENTRY from the template definition."
(setq org-capture-plist (copy-sequence (nthcdr 5 entry)))
(org-capture-put :key (car entry) :description (nth 1 entry)
:target (nth 3 entry))
(let ((txt (nth 4 entry)) (type (or (nth 2 entry) 'entry)))
(when (or (not txt) (and (stringp txt) (not (string-match "\\S-" txt))))
;; The template may be empty or omitted for special types.
;; Here we insert the default templates for such cases.
(cond
((eq type 'item) (setq txt "- %?"))
((eq type 'checkitem) (setq txt "- [ ] %?"))
((eq type 'table-line) (setq txt "| %? |"))
((member type '(nil entry)) (setq txt "* %?\n %a"))))
(org-capture-put :template txt :type type)))
(defun org-capture-goto-target (&optional template-key)
"Go to the target location of a capture template.
If TEMPLATE-KEY is nil, the user is queried for the template."
(interactive)
(let ((entry (org-capture-select-template template-key)))
(unless entry (error "No capture template selected"))
(org-capture-set-plist entry)
(org-capture-set-target-location)
(pop-to-buffer-same-window (org-capture-get :buffer))
(goto-char (org-capture-get :pos))))
(defun org-capture-get-indirect-buffer (&optional buffer prefix)
"Make an indirect BUFFER for a capture process.
Use PREFIX as a prefix for the name of the indirect buffer."
(setq buffer (or buffer (current-buffer)))
(let ((n 1) (base (buffer-name buffer)) bname)
(setq bname (concat prefix "-" base))
(while (buffer-live-p (get-buffer bname))
(setq bname (concat prefix "-" (number-to-string (cl-incf n)) "-" base)))
(condition-case nil
(make-indirect-buffer buffer bname 'clone)
(error
(let ((buf (make-indirect-buffer buffer bname)))
(with-current-buffer buf (org-mode))
buf)))))
(defun org-capture-verify-tree (tree)
"Throw error if TREE is not a valid tree."
(unless (org-kill-is-subtree-p tree)
(error "Template is not a valid Org entry or tree")))
;;; The template code
(defun org-capture-select-template (&optional keys)
"Select a capture template.
Lisp programs can force the template by setting KEYS to a string."
(let ((org-capture-templates
(or (org-contextualize-keys
(org-capture-upgrade-templates org-capture-templates)
org-capture-templates-contexts)
'(("t" "Task" entry (file+headline "" "Tasks")
"* TODO %?\n %u\n %a")))))
(if keys
(or (assoc keys org-capture-templates)
(error "No capture template referred to by \"%s\" keys" keys))
(org-mks org-capture-templates
"Select a capture template\n========================="
"Template key: "
'(("C" "Customize org-capture-templates")
("q" "Abort"))))))
(defvar org-capture--clipboards nil
"List various clipboards values.")
(defun org-capture-fill-template (&optional template initial annotation)
"Fill a TEMPLATE and return the filled template as a string.
The template may still contain \"%?\" for cursor positioning.
INITIAL content and/or ANNOTATION may be specified, but will be overridden
by their respective `org-store-link-plist' properties if present.
Expansion occurs in a temporary Org mode buffer."
(let* ((template (or template (org-capture-get :template)))
(buffer (org-capture-get :buffer))
(file (buffer-file-name (or (buffer-base-buffer buffer) buffer)))
(time (let* ((c (or (org-capture-get :default-time) (current-time)))
(d (decode-time c)))
(if (< (nth 2 d) org-extend-today-until)
(org-encode-time 0 59 23 (1- (nth 3 d)) (nth 4 d) (nth 5 d))
c)))
(v-t (format-time-string (org-time-stamp-format nil) time))
(v-T (format-time-string (org-time-stamp-format t) 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-c (and kill-ring (current-kill 0)))
(v-x (or (org-get-x-clipboard 'PRIMARY)
(org-get-x-clipboard 'CLIPBOARD)
(org-get-x-clipboard 'SECONDARY)
"")) ;ensure it is a string
;; `initial' and `annotation' might have been passed. But if
;; the property list has them, we prefer those values.
(v-i (or (plist-get org-store-link-plist :initial)
(and (stringp initial) (org-no-properties initial))
(org-capture-get :initial)
""))
(v-a
(let ((a (or (plist-get org-store-link-plist :annotation)
annotation
(org-capture-get :annotation)
"")))
;; Is the link empty? Then we do not want it...
(if (equal a "[[]]") "" a)))
(l-re "\\[\\[\\(.*?\\)\\]\\(\\[.*?\\]\\)?\\]")
(v-A (if (and v-a (string-match l-re v-a))
(replace-match "[[\\1][%^{Link description}]]" nil nil v-a)
v-a))
(v-l (if (and v-a (string-match l-re v-a))
(replace-match "[[\\1]]" nil nil v-a)
v-a))
(v-L (if (and v-a (string-match l-re v-a))
(replace-match "\\1" nil nil v-a)
v-a))
(v-n user-full-name)
(v-k (if (marker-buffer org-clock-marker)
(org-no-properties org-clock-heading)
""))
(v-K (if (marker-buffer org-clock-marker)
(let ((original-link-plist org-store-link-plist)
(clocked-task-link (org-with-point-at org-clock-marker
(org-store-link nil nil))))
(setq org-store-link-plist original-link-plist)
clocked-task-link)
""))
(v-f (or (org-capture-get :original-file-nondirectory) ""))
(v-F (or (org-capture-get :original-file) ""))
(org-capture--clipboards
(delq nil
(list v-i
(org-get-x-clipboard 'PRIMARY)
(org-get-x-clipboard 'CLIPBOARD)
(org-get-x-clipboard 'SECONDARY)
v-c))))
(setq org-store-link-plist (plist-put org-store-link-plist :annotation v-a))
(setq org-store-link-plist (plist-put org-store-link-plist :initial v-i))
(unless template
(setq template "")
(message "no template") (ding)
(sit-for 1))
(save-window-excursion
(switch-to-buffer-other-window (get-buffer-create "*Capture*"))
(erase-buffer)
(setq buffer-file-name nil)
(setq mark-active nil)
(insert template)
(org-mode)
(goto-char (point-min))
;; %[] insert contents of a file.
(save-excursion
(while (re-search-forward "%\\[\\(.+\\)\\]" nil t)
(let ((filename (expand-file-name (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)
(condition-case error
(insert-file-contents filename)
(error
(insert (format "%%![could not insert %s: %s]"
filename
error))))))))
;; Mark %() embedded elisp for later evaluation.
(org-capture-expand-embedded-elisp 'mark)
;; Expand non-interactive templates.
(let ((regexp "%\\(:[-A-Za-z]+\\|<\\([^>\n]+\\)>\\|[aAcfFikKlLntTuUx]\\)"))
(save-excursion
(while (re-search-forward regexp nil t)
;; `org-capture-escaped-%' may modify buffer and cripple
;; match-data. Use markers instead. Ditto for other
;; templates.
(let ((pos (copy-marker (match-beginning 0)))
(end (copy-marker (match-end 0)))
(value (match-string 1))
(time-string (match-string 2)))
(unless (org-capture-escaped-%)
(delete-region pos end)
(set-marker pos nil)
(set-marker end nil)
(let* ((inside-sexp? (org-capture-inside-embedded-elisp-p))
(replacement
(pcase (string-to-char value)
(?< (format-time-string time-string time))
(?:
(or (plist-get org-store-link-plist (intern value))
""))
(?i
(if inside-sexp? v-i
;; Outside embedded Lisp, repeat leading
;; characters before initial place holder
;; every line.
(let ((lead (concat "\n"
(org-current-line-string t))))
(replace-regexp-in-string "\n" lead v-i nil t))))
(?a v-a)
(?A v-A)
(?c v-c)
(?f v-f)
(?F v-F)
(?k v-k)
(?K v-K)
(?l v-l)
(?L v-L)
(?n v-n)
(?t v-t)
(?T v-T)
(?u v-u)
(?U v-U)
(?x v-x))))
(insert
(if inside-sexp?
;; Escape sensitive characters.
(replace-regexp-in-string "[\\\"]" "\\\\\\&" replacement)
replacement))))))))
;; Expand %() embedded Elisp. Limit to Sexp originally marked.
(org-capture-expand-embedded-elisp)
;; Expand interactive templates. This is the last step so that
;; template is mostly expanded when prompting happens. Turn on
;; Org mode and set local variables. This is to support
;; completion in interactive prompts.
(let ((org-inhibit-startup t)) (org-mode))
(org-clone-local-variables buffer "\\`org-")
(let (strings) ; Stores interactive answers.
(save-excursion
(let ((regexp "%\\^\\(?:{\\([^}]*\\)}\\)?\\([CgGLptTuU]\\)?"))
(while (re-search-forward regexp nil t)
(let* ((items (and (match-end 1)
(save-match-data
(split-string (match-string-no-properties 1)
"|"))))
(key (match-string 2))
(beg (copy-marker (match-beginning 0)))
(end (copy-marker (match-end 0)))
(prompt (nth 0 items))
(default (nth 1 items))
(completions (nthcdr 2 items)))
(unless (org-capture-escaped-%)
(delete-region beg end)
(set-marker beg nil)
(set-marker end nil)
(pcase key
((or "G" "g")
(let* ((org-last-tags-completion-table
(org-global-tags-completion-table
(cond ((equal key "G") (org-agenda-files))
(file (list file))
(t nil))))
(org-add-colon-after-tag-completion t)
(ins (mapconcat
#'identity
(let ((crm-separator "[ \t]*:[ \t]*"))
(completing-read-multiple
(if prompt (concat prompt ": ") "Tags: ")
org-last-tags-completion-table nil nil nil
'org-tags-history))
":")))
(when (org-string-nw-p ins)
(unless (eq (char-before) ?:) (insert ":"))
(insert ins)
(unless (eq (char-after) ?:) (insert ":"))
(when (org-at-heading-p) (org-align-tags)))))
((or "C" "L")
(let ((insert-fun (if (equal key "C") #'insert
(lambda (s) (org-insert-link 0 s)))))
(pcase org-capture--clipboards
(`nil nil)
(`(,value) (funcall insert-fun value))
(`(,first-value . ,_)
(funcall insert-fun
(read-string "Clipboard/kill value: "
first-value
'org-capture--clipboards
first-value)))
(_ (error "Invalid `org-capture--clipboards' value: %S"
org-capture--clipboards)))))
("p"
;; We remove keyword properties inherited from
;; target buffer so `org-read-property-value' has
;; a chance to find allowed values in sub-trees
;; from the target buffer.
(setq-local org-keyword-properties nil)
(let* ((origin (set-marker (make-marker)
(org-capture-get :pos)
(org-capture-get :buffer)))
;; Find location from where to get allowed
;; values. If `:target-entry-p' is
;; non-nil, the current headline in the
;; target buffer is going to be a parent
;; headline, so location is fine.
;; Otherwise, find the parent headline in
;; the target buffer.
(pom (if (org-capture-get :target-entry-p) origin
(let ((level (progn
(while (org-up-heading-safe))
(org-current-level))))
(org-with-point-at origin
(let ((l (if (org-at-heading-p)
(org-current-level)
most-positive-fixnum)))
(while (and l (>= l level))
(setq l (org-up-heading-safe)))
(if l (point-marker)
(point-min-marker)))))))
(value
(org-read-property-value prompt pom default)))
(org-set-property prompt value)))
((or "t" "T" "u" "U")
;; These are the date/time related ones.
(let* ((upcase? (equal (upcase key) key))
(org-end-time-was-given nil)
(time (org-read-date upcase? t nil prompt)))
(org-insert-timestamp
time (or org-time-was-given upcase?)
(member key '("u" "U"))
nil nil (list org-end-time-was-given))))
(`nil
;; Load history list for current prompt.
(setq org-capture--prompt-history
(gethash prompt org-capture--prompt-history-table))
(push (org-completing-read
(org-format-prompt (or prompt "Enter string") default)
completions
nil nil nil 'org-capture--prompt-history default)
strings)
(insert (car strings))
;; Save updated history list for current prompt.
(puthash prompt org-capture--prompt-history
org-capture--prompt-history-table))
(_
(error "Unknown template placeholder: \"%%^%s\""
key))))))))
;; Replace %n escapes with nth %^{...} string.
(setq strings (nreverse strings))
(save-excursion
(while (re-search-forward "%\\\\\\([1-9][0-9]*\\)" nil t)
(unless (org-capture-escaped-%)
(replace-match
(nth (1- (string-to-number (match-string 1))) strings)
nil t)))))
;; Make sure there are no empty lines before the text, and that
;; it ends with a newline character or it is empty.
(skip-chars-forward " \t\n")
(delete-region (point-min) (line-beginning-position))
(goto-char (point-max))
(skip-chars-backward " \t\n")
(if (bobp) (delete-region (point) (line-end-position))
(end-of-line)
(delete-region (point) (point-max))
(insert "\n"))
;; Return the expanded template and kill the capture buffer.
(untabify (point-min) (point-max))
(set-buffer-modified-p nil)
(prog1 (buffer-substring-no-properties (point-min) (point-max))
(kill-buffer (current-buffer))))))
(defun org-capture-escaped-% ()
"Non-nil if % was escaped.
If yes, unescape it now. Assume `match-data' contains the
placeholder to check."
(save-excursion
(goto-char (match-beginning 0))
(let ((n (abs (skip-chars-backward "\\\\"))))
(delete-char (/ (1+ n) 2))
(= (% n 2) 1))))
(defun org-capture-expand-embedded-elisp (&optional mark)
"Evaluate embedded elisp %(sexp) and replace with the result.
When optional MARK argument is non-nil, mark Sexp with a text
property (`org-embedded-elisp') for later evaluation. Only
marked Sexp are evaluated when this argument is nil."
(save-excursion
(goto-char (point-min))
(while (re-search-forward "%(" nil t)
(cond
((get-text-property (match-beginning 0) 'org-embedded-elisp)
(goto-char (match-beginning 0))
(let ((template-start (point)))
(forward-char 1)
(let* ((sexp (read (current-buffer)))
(result (org-eval
(org-capture--expand-keyword-in-embedded-elisp
sexp))))
(delete-region template-start (point))
(cond
((not result) nil)
((stringp result) (insert result))
(t (error
"Capture template sexp `%s' must evaluate to string or nil"
sexp))))))
((not mark) nil)
;; Only mark valid and non-escaped sexp.
((org-capture-escaped-%) nil)
(t
(let ((end (with-syntax-table emacs-lisp-mode-syntax-table
(ignore-errors (scan-sexps (1- (point)) 1)))))
(when end
(put-text-property (- (point) 2) end 'org-embedded-elisp t))))))))
(defun org-capture--expand-keyword-in-embedded-elisp (attr)
"Recursively replace capture link keywords in ATTR sexp.
Such keywords are prefixed with \"%:\". See
`org-capture-template' for more information."
(cond ((consp attr)
(mapcar 'org-capture--expand-keyword-in-embedded-elisp attr))
((symbolp attr)
(let* ((attr-symbol (symbol-name attr))
(key (and (string-match "%\\(:.*\\)" attr-symbol)
(intern (match-string 1 attr-symbol)))))
(or (plist-get org-store-link-plist key)
attr)))
(t attr)))
(defun org-capture-inside-embedded-elisp-p ()
"Non-nil if point is inside of embedded elisp %(sexp).
Assume sexps have been marked with
`org-capture-expand-embedded-elisp' beforehand."
(get-text-property (point) 'org-embedded-elisp))
;;;###autoload
(defun org-capture-import-remember-templates ()
"Set `org-capture-templates' to be similar to `org-remember-templates'."
(interactive)
(when (and (yes-or-no-p
"Import old remember templates into org-capture-templates? ")
(yes-or-no-p
"Note that this will remove any templates currently defined in `org-capture-templates'. Do you still want to go ahead? "))
(require 'org-remember)
(setq org-capture-templates
(mapcar
(lambda (entry)
(let ((desc (car entry))
(key (char-to-string (nth 1 entry)))
(template (nth 2 entry))
(file (or (nth 3 entry) org-default-notes-file))
(position (or (nth 4 entry) org-remember-default-headline))
(type 'entry)
(prepend org-reverse-note-order)
immediate target jump-to-captured)
(cond
((member position '(top bottom))
(setq target (list 'file file)
prepend (eq position 'top)))
((eq position 'date-tree)
(setq target (list 'file+datetree file)
prepend nil))
(t (setq target (list 'file+headline file position))))
(when (string-match "%!" template)
(setq template (replace-match "" t t template)
immediate t))
(when (string-match "%&" template)
(setq jump-to-captured t))
(append (list key desc type target template)
(and prepend '(:prepend t))
(and immediate '(:immediate-finish t))
(and jump-to-captured '(:jump-to-captured t)))))
org-remember-templates))))
(provide 'org-capture)
;;; org-capture.el ends here
org-mode-9.7.29+dfsg/lisp/org-clock.el 0000664 0000000 0000000 00000373013 15004304337 0017431 0 ustar 00root root 0000000 0000000 ;;; org-clock.el --- The time clocking code for Org mode -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2025 Free Software Foundation, Inc.
;; Author: Carsten Dominik
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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 \
DONE here means any DONE-like state.
A nil value means clock will keep running until stopped explicitly with
`\\[org-clock-out]', or until the clock is started in a different item.
Instead of t, this can also be a list of TODO states that should trigger
clocking out."
:group 'org-clock
:type '(choice
(const :tag "No" nil)
(const :tag "Yes, when done" t)
(repeat :tag "State list"
(string :tag "TODO keyword"))))
(defcustom org-clock-rounding-minutes 0
"Rounding minutes when clocking in or out.
The default value is 0 so that no rounding is done.
When set to a non-integer value, use the car of
`org-timestamp-rounding-minutes', like for setting a timestamp.
E.g. if `org-clock-rounding-minutes' is set to 5, time is 14:47
and you clock in: then the clock starts at 14:45. If you clock
out within the next 5 minutes, the clock line will be removed;
if you clock out 8 minutes after your clocked in, the clock
out time will be 14:50."
:group 'org-clock
:version "24.4"
:package-version '(Org . "8.0")
:type '(choice
(integer :tag "Minutes (0 for no rounding)")
(const :tag "Use `org-time-stamp-rounding-minutes'" same-as-time-stamp)))
(defcustom org-clock-out-remove-zero-time-clocks nil
"Non-nil means remove the clock line when the resulting time is zero."
:group 'org-clock
:type 'boolean)
(defcustom org-clock-in-switch-to-state nil
"Set task to a special todo state while clocking it.
The value should be the state to which the entry should be
switched. If the value is a function, it must take one
parameter (the current TODO state of the item) and return the
state to switch it to."
:group 'org-clock
:group 'org-todo
:type '(choice
(const :tag "Don't force a state" nil)
(string :tag "State")
(symbol :tag "Function")))
(defcustom org-clock-out-switch-to-state nil
"Set task to a special todo state after clocking out.
The value should be the state to which the entry should be
switched. If the value is a function, it must take one
parameter (the current TODO state of the item) and return the
state to switch it to."
:group 'org-clock
:group 'org-todo
:type '(choice
(const :tag "Don't force a state" nil)
(string :tag "State")
(symbol :tag "Function")))
(defcustom org-clock-history-length 5
"Number of clock tasks to remember in history.
Clocking in using history works best if this is at most 35, in
which case all digits and capital letters are used up by the
*Clock Task Select* buffer."
:group 'org-clock
:type 'integer)
(defcustom org-clock-goto-may-find-recent-task t
"Non-nil means `org-clock-goto' can go to recent task if no active clock."
:group 'org-clock
:type 'boolean)
(defcustom org-clock-heading-function nil
"When non-nil, should be a function to create `org-clock-heading'.
This is the string shown in the mode line when a clock is running.
The function is called with point at the beginning of the headline."
:group 'org-clock
:type '(choice (const nil) (function)))
(defcustom org-clock-string-limit 0
"Maximum length of clock strings in the mode line. 0 means no limit."
:group 'org-clock
:type 'integer)
(defcustom org-clock-in-resume nil
"If non-nil, resume clock when clocking into task with open clock.
When clocking into a task with a clock entry which has not been closed,
the clock can be resumed from that point."
:group 'org-clock
:type 'boolean)
(defcustom org-clock-persist nil
"When non-nil, save the running clock when Emacs is closed.
The clock is resumed when Emacs restarts.
When this is t, both the running clock, and the entire clock
history are saved. When this is the symbol `clock', only the
running clock is saved. When this is the symbol `history', only
the clock history is saved.
When Emacs restarts with saved clock information, the file containing
the running clock as well as all files mentioned in the clock history
will be visited.
All this depends on running `org-clock-persistence-insinuate' in your
Emacs initialization file."
:group 'org-clock
:type '(choice
(const :tag "Just the running clock" clock)
(const :tag "Just the history" history)
(const :tag "Clock and history" t)
(const :tag "No persistence" nil)))
(defcustom org-clock-persist-file (locate-user-emacs-file "org-clock-save.el")
"File to save clock data to."
:group 'org-clock
:type 'string)
(defcustom org-clock-persist-query-save nil
"When non-nil, ask before saving the current clock on exit."
:group 'org-clock
:type 'boolean)
(defcustom org-clock-persist-query-resume t
"When non-nil, ask before resuming any stored clock during load."
:group 'org-clock
:type 'boolean)
(defcustom org-clock-sound nil
"Sound to use for notifications.
Possible values are:
nil No sound played
t Standard Emacs beep
file name Play this sound file, fall back to beep"
:group 'org-clock
:type '(choice
(const :tag "No sound" nil)
(const :tag "Standard beep" t)
(file :tag "Play sound file")))
(defcustom org-clock-mode-line-total 'auto
"Default setting for the time included for the mode line clock.
This can be overruled locally using the CLOCK_MODELINE_TOTAL property.
Allowed values are:
current Only the time in the current instance of the clock
today All time clocked into this task today
repeat All time clocked into this task since last repeat
all All time ever recorded for this task
auto Automatically, either `all', or `repeat' for repeating tasks"
:group 'org-clock
:type '(choice
(const :tag "Current clock" current)
(const :tag "Today's task time" today)
(const :tag "Since last repeat" repeat)
(const :tag "All task time" all)
(const :tag "Automatically, `all' or since `repeat'" auto)))
(defvaralias 'org-task-overrun-text 'org-clock-task-overrun-text)
(defcustom org-clock-task-overrun-text nil
"Extra mode line text to indicate that the clock is overrun.
The can be nil to indicate that instead of adding text, the clock time
should get a different face (`org-mode-line-clock-overrun').
When this is a string, it is prepended to the clock string as an indication,
also using the face `org-mode-line-clock-overrun'."
:group 'org-clock
:version "24.1"
:type '(choice
(const :tag "Just mark the time string" nil)
(string :tag "Text to prepend")))
(defcustom org-show-notification-timeout 3
"Number of seconds to wait before closing Org notifications.
This is applied to notifications sent with `notifications-notify'
and `w32-notification-notify' only, not other mechanisms possibly
set through `org-show-notification-handler'."
:group 'org-clock
:package-version '(Org . "9.4")
:type 'integer)
(defcustom org-show-notification-handler nil
"Function or program to send notification with.
The function or program will be called with the notification
string as argument."
:group 'org-clock
:type '(choice
(const nil)
(string :tag "Program")
(function :tag "Function")))
(defgroup org-clocktable nil
"Options concerning the clock table in Org mode."
:tag "Org Clock Table"
:group 'org-clock)
(defcustom org-clocktable-defaults
(list
:maxlevel 2
:lang (or (bound-and-true-p org-export-default-language) "en")
:scope 'file
:block nil
:wstart 1
:mstart 1
:tstart nil
:tend nil
:step nil
:stepskip0 nil
:fileskip0 nil
:tags nil
:match nil
:emphasize nil
:link nil
:narrow '40!
:indent t
:filetitle nil
:hidefiles nil
:formula nil
:timestamp nil
:level nil
:tcolumns nil
:formatter nil)
"Default properties for clock tables."
:group 'org-clock
:package-version '(Org . "9.6")
:type 'plist)
(defcustom org-clock-clocktable-formatter 'org-clocktable-write-default
"Function to turn clocking data into a table.
For more information, see `org-clocktable-write-default'."
:group 'org-clocktable
:version "24.1"
:type 'function)
(defcustom org-clock-clocktable-language-setup
'(("en" "File" "L" "Timestamp" "Headline" "Time" "ALL" "Total time" "File time" "Clock summary at")
("de" "Datei" "E" "Zeitstempel" "Kopfzeile" "Dauer" "GESAMT" "Gesamtdauer" "Dateizeit" "Erstellt am")
("es" "Archivo" "N" "Fecha y hora" "Tarea" "Duración" "TODO" "Duración total" "Tiempo archivo" "Generado el")
("fr" "Fichier" "N" "Horodatage" "En-tête" "Durée" "TOUT" "Durée totale" "Durée fichier" "Horodatage sommaire à")
("nl" "Bestand" "N" "Tijdstip" "Rubriek" "Duur" "ALLES" "Totale duur" "Bestandstijd" "Klok overzicht op")
("nn" "Fil" "N" "Tidspunkt" "Overskrift" "Tid" "ALLE" "Total tid" "Filtid" "Tidsoversyn")
("pl" "Plik" "P" "Data i godzina" "Nagłówek" "Czas" "WSZYSTKO" "Czas całkowity" "Czas pliku" "Poddumowanie zegara na")
("pt-BR" "Arquivo" "N" "Data e hora" "Título" "Hora" "TODOS" "Hora total" "Hora do arquivo" "Resumo das horas em")
("sk" "Súbor" "L" "Časová značka" "Záhlavie" "Čas" "VŠETKO" "Celkový čas" "Čas súboru" "Časový súhrn pre"))
"Terms used in clocktable, translated to different languages."
:group 'org-clocktable
:version "24.1"
:type 'alist)
(defcustom org-clock-clocktable-default-properties '(:maxlevel 2)
"Default properties for new clocktables.
These will be inserted into the BEGIN line, to make it easy for users to
play with them."
:group 'org-clocktable
:package-version '(Org . "9.2")
:type 'plist)
(defcustom org-clock-idle-time nil
"When non-nil, resolve open clocks if the user is idle more than X minutes."
:group 'org-clock
:type '(choice
(const :tag "Never" nil)
(integer :tag "After N minutes")))
(defcustom org-clock-auto-clock-resolution 'when-no-clock-is-running
"When to automatically resolve open clocks found in Org buffers."
:group 'org-clock
:type '(choice
(const :tag "Never" nil)
(const :tag "Always" t)
(const :tag "When no clock is running" when-no-clock-is-running)))
(defcustom org-clock-report-include-clocking-task nil
"When non-nil, include the current clocking task time in clock reports."
:group 'org-clock
:version "24.1"
:type 'boolean)
(defcustom org-clock-resolve-expert nil
"Non-nil means do not show the splash buffer with the clock resolver."
:group 'org-clock
:version "24.1"
:type 'boolean)
(defcustom org-clock-continuously nil
"Non-nil means to start clocking from the last clock-out time, if any."
:type 'boolean
:version "24.1"
:group 'org-clock)
(defcustom org-clock-total-time-cell-format "*%s*"
"Format string for the total time cells."
:group 'org-clock
:version "24.1"
:type 'string)
(defcustom org-clock-file-time-cell-format "*%s*"
"Format string for the file time cells."
:group 'org-clock
:version "24.1"
:type 'string)
(defcustom org-clock-clocked-in-display 'mode-line
"Where to display clocked in task and accumulated time when clocked in.
Allowed values are:
both displays in both mode line and frame title
mode-line displays only in mode line (default)
frame-title displays only in frame title
nil current clock is not displayed"
:group 'org-clock
:type '(choice
(const :tag "Mode line" mode-line)
(const :tag "Frame title" frame-title)
(const :tag "Both" both)
(const :tag "None" nil)))
(defcustom org-clock-frame-title-format '(t org-mode-line-string)
"The value for `frame-title-format' when clocking in.
When `org-clock-clocked-in-display' is set to `frame-title'
or `both', clocking in will replace `frame-title-format' with
this value. Clocking out will restore `frame-title-format'.
This uses the same format as `frame-title-format', which see."
:version "24.1"
:group 'org-clock
:type 'sexp)
(defcustom org-clock-x11idle-program-name
(if (executable-find "xprintidle")
"xprintidle" "x11idle")
"Name of the program which prints X11 idle time in milliseconds.
you can do \"~$ sudo apt-get install xprintidle\" if you are using
a Debian-based distribution.
Alternatively, can find x11idle.c in
https://orgmode.org/worg/code/scripts/x11idle.c"
:group 'org-clock
:package-version '(Org . "9.7")
:type 'string)
(defcustom org-clock-goto-before-context 2
"Number of lines of context to display before currently clocked-in entry.
This applies when using `org-clock-goto'."
:group 'org-clock
:type 'integer)
(defcustom org-clock-display-default-range 'thisyear
"Default range when displaying clocks with `org-clock-display'.
Valid values are: `today', `yesterday', `thisweek', `lastweek',
`thismonth', `lastmonth', `thisyear', `lastyear' and `untilnow'."
:group 'org-clock
:type '(choice (const today)
(const yesterday)
(const thisweek)
(const lastweek)
(const thismonth)
(const lastmonth)
(const thisyear)
(const lastyear)
(const untilnow)
(const :tag "Select range interactively" interactive))
:safe #'symbolp)
(defcustom org-clock-auto-clockout-timer nil
"Timer for auto clocking out when Emacs is idle.
When set to a number, auto clock out the currently clocked in
task after this number of seconds of idle time.
This is only effective when `org-clock-auto-clockout-insinuate'
is added to the user configuration."
:group 'org-clock
:package-version '(Org . "9.4")
:type '(choice
(integer :tag "Clock out after Emacs is idle for X seconds")
(const :tag "Never auto clock out" nil)))
(defcustom org-clock-ask-before-exiting t
"If non-nil, ask if the user wants to clock out before exiting Emacs.
This variable only has effect if set with \\[customize]."
:set (lambda (symbol value)
(if value
(add-hook 'kill-emacs-query-functions #'org-clock-kill-emacs-query)
(remove-hook 'kill-emacs-query-functions #'org-clock-kill-emacs-query))
(set-default-toplevel-value symbol value))
:type 'boolean
:package-version '(Org . "9.5"))
(defvar org-clock-in-prepare-hook nil
"Hook run when preparing the clock.
This hook is run before anything happens to the task that
you want to clock in. For example, you can use this hook
to add an effort property.")
(defvar org-clock-in-hook nil
"Hook run when starting the clock.")
(defvar org-clock-out-hook nil
"Hook run when stopping the current clock.
The point is at the current clock line when the hook is executed.
The hook functions can access `org-clock-out-removed-last-clock' to
check whether the latest CLOCK line has been cleared.")
(defvar org-clock-cancel-hook nil
"Hook run when canceling the current clock.")
(defvar org-clock-goto-hook nil
"Hook run when selecting the currently clocked-in entry.")
(defvar org-clock-has-been-used nil
"Has the clock been used during the current Emacs session?")
(defvar org-clock-stored-history nil
"Clock history, populated by `org-clock-load'.")
(defvar org-clock-stored-resume-clock nil
"Clock to resume, saved by `org-clock-load'.")
;;; The clock for measuring work time.
(defvar org-mode-line-string "")
(put 'org-mode-line-string 'risky-local-variable t)
(defvar org-clock-mode-line-timer nil)
(defvar org-clock-idle-timer nil)
(defvar org-clock-heading) ; defined in org.el
(defvar org-clock-start-time "")
(defvar org-clock-leftover-time nil
"If non-nil, user canceled a clock; this is when leftover time started.")
(defvar org-clock-effort ""
"Effort estimate of the currently clocking task.")
(defvar org-clock-total-time nil
"Holds total time, spent previously on currently clocked item.
This does not include the time in the currently running clock.")
(defvar org-clock-history nil
"List of marker pointing to recent clocked tasks.")
(defvar org-clock-default-task (make-marker)
"Marker pointing to the default task that should clock time.
The clock can be made to switch to this task after clocking out
of a different task.")
(defvar org-clock-interrupted-task (make-marker)
"Marker pointing to the task that has been interrupted by the current clock.")
(defvar org-clock-mode-line-map (make-sparse-keymap))
(define-key org-clock-mode-line-map [mode-line mouse-2] #'org-clock-goto)
(define-key org-clock-mode-line-map [mode-line mouse-1] #'org-clock-menu)
(defun org-clock--translate (s language)
"Translate string S into using string LANGUAGE.
Assume S in the English term to translate. Return S as-is if it
cannot be translated."
(or (nth (pcase s
;; "L" stands for "Level"
;; "ALL" stands for a line summarizing clock data across
;; all the files, when the clocktable includes multiple
;; files.
("File" 1) ("L" 2) ("Timestamp" 3) ("Headline" 4) ("Time" 5)
("ALL" 6) ("Total time" 7) ("File time" 8) ("Clock summary at" 9))
(assoc-string language org-clock-clocktable-language-setup t))
s))
(defun org-clock--mode-line-heading ()
"Return currently clocked heading, formatted for mode line."
(cond ((functionp org-clock-heading-function)
(funcall org-clock-heading-function))
((org-before-first-heading-p) "???")
(t (org-link-display-format
(org-no-properties (org-get-heading t t t t))))))
(defun org-clock-menu ()
"Pop up org-clock menu."
(interactive)
(popup-menu
'("Clock"
["Clock out" org-clock-out t]
["Change effort estimate" org-clock-modify-effort-estimate t]
["Go to clock entry" org-clock-goto t]
["Switch task" (lambda () (interactive) (org-clock-in '(4))) :active t :keys "C-u C-c C-x C-i"])))
(defun org-clock-history-push (&optional pos buffer)
"Push point marker to the clock history.
When POS is provided, use it as marker point.
When BUFFER and POS are provided, use marker at POS in base buffer of
BUFFER."
;; When buffer is provided, POS must be provided.
(cl-assert (or (not buffer) pos))
(setq org-clock-history-length (max 1 org-clock-history-length))
(let ((m (move-marker (make-marker)
(or pos (point)) (org-base-buffer
(or buffer (current-buffer)))))
n l)
(while (setq n (member m org-clock-history))
(move-marker (car n) nil))
(setq org-clock-history
(delq nil
(mapcar (lambda (x) (if (marker-buffer x) x nil))
org-clock-history)))
(when (>= (setq l (length org-clock-history)) org-clock-history-length)
(setq org-clock-history
(nreverse
(nthcdr (- l org-clock-history-length -1)
(nreverse org-clock-history)))))
(push m org-clock-history)))
(defun org-clock-save-markers-for-cut-and-paste (beg end)
"Save relative positions of markers in region BEG..END.
Save `org-clock-marker', `org-clock-hd-marker',
`org-clock-default-task', `org-clock-interrupted-task', and the
markers in `org-clock-history'."
(org-check-and-save-marker org-clock-marker beg end)
(org-check-and-save-marker org-clock-hd-marker beg end)
(org-check-and-save-marker org-clock-default-task beg end)
(org-check-and-save-marker org-clock-interrupted-task beg end)
(dolist (m org-clock-history)
(org-check-and-save-marker m beg end)))
(defun org-clock-drawer-name ()
"Return clock drawer's name for current entry, or nil."
(let ((drawer (org-clock-into-drawer)))
(cond ((integerp drawer)
(let ((log-drawer (org-log-into-drawer)))
(if (stringp log-drawer) log-drawer "LOGBOOK")))
((stringp drawer) drawer)
(t nil))))
(defun org-clocking-p ()
"Return t when clocking a task."
(not (equal (org-clocking-buffer) nil)))
(defvar org-clock-before-select-task-hook nil
"Hook called in task selection just before prompting the user.")
(defun org-clock-select-task (&optional prompt)
"Select a task that was recently associated with clocking.
PROMPT is the prompt text to be used, as a string.
Return marker position of the selected task. Raise an error if
there is no recent clock to choose from."
(let (och chl sel-list rpl (i 0) s)
;; Remove successive dups from the clock history to consider
(dolist (c org-clock-history)
(unless (equal c (car och)) (push c och)))
(setq och (reverse och) chl (length och))
(if (zerop chl)
(user-error "No recent clock")
(save-window-excursion
(switch-to-buffer-other-window
(get-buffer-create "*Clock Task Select*"))
(erase-buffer)
(when (marker-buffer org-clock-default-task)
(insert (org-add-props "Default Task\n" nil 'face 'bold))
(setq s (org-clock-insert-selection-line ?d org-clock-default-task))
(push s sel-list))
(when (marker-buffer org-clock-interrupted-task)
(insert (org-add-props "The task interrupted by starting the last one\n" nil 'face 'bold))
(setq s (org-clock-insert-selection-line ?i org-clock-interrupted-task))
(push s sel-list))
(when (org-clocking-p)
(insert (org-add-props "Current Clocking Task\n" nil 'face 'bold))
(setq s (org-clock-insert-selection-line ?c org-clock-marker))
(push s sel-list))
(insert (org-add-props "Recent Tasks\n" nil 'face 'bold))
(dolist (m och)
(when (marker-buffer m)
(setq i (1+ i)
s (org-clock-insert-selection-line
(if (< i 10)
(+ i ?0)
(+ i (- ?A 10))) m))
(push s sel-list)))
(run-hooks 'org-clock-before-select-task-hook)
(goto-char (point-min))
;; Set min-height relatively to circumvent a possible but in
;; `fit-window-to-buffer'
(fit-window-to-buffer nil nil (if (< chl 10) chl (+ 5 chl)))
(message (or prompt "Select task for clocking:"))
(unwind-protect (setq cursor-type nil rpl (read-char-exclusive))
(when-let* ((window (get-buffer-window "*Clock Task Select*" t)))
(quit-window 'kill window))
(when (get-buffer "*Clock Task Select*")
(kill-buffer "*Clock Task Select*")))
(cond
((eq rpl ?q) nil)
((eq rpl ?x) nil)
((assoc rpl sel-list) (cdr (assoc rpl sel-list)))
(t (user-error "Invalid task choice %c" rpl)))))))
(defun org-clock-insert-selection-line (i marker)
"Insert a line for the clock selection menu.
And return a cons cell with the selection character integer and the marker
pointing to it."
(when (marker-buffer marker)
(let (cat task heading prefix)
(with-current-buffer (org-base-buffer (marker-buffer marker))
(org-with-wide-buffer
(ignore-errors
(goto-char marker)
(setq cat (org-get-category)
heading (org-get-heading 'notags)
prefix (save-excursion
(org-back-to-heading t)
(looking-at org-outline-regexp)
(match-string 0))
task (substring
(org-fontify-like-in-org-mode
(concat prefix heading)
org-odd-levels-only)
(length prefix))))))
(when (and cat task)
(if (string-match-p "[[:print:]]" (make-string 1 i))
(insert (format "[%c] %-12s %s\n" i cat task))
;; Avoid non-printable characters.
(insert (format "[N/A] %-12s %s\n" cat task)))
(cons i marker)))))
(defvar org-clock-task-overrun nil
"Internal flag indicating if the clock has overrun the planned time.")
(defvar org-clock-update-period 60
"Number of seconds between mode line clock string updates.")
(defun org-clock-get-clock-string ()
"Form a clock-string, that will be shown in the mode line.
If an effort estimate was defined for the current item, use
01:30/01:50 format (clocked/estimated).
If not, show simply the clocked time like 01:50."
(let ((clocked-time (org-clock-get-clocked-time)))
(if org-clock-effort
(let* ((effort-in-minutes (org-duration-to-minutes org-clock-effort))
(work-done-str
(propertize (org-duration-from-minutes clocked-time)
'face
(if (and org-clock-task-overrun
(not org-clock-task-overrun-text))
'org-mode-line-clock-overrun
'org-mode-line-clock)))
(effort-str (org-duration-from-minutes effort-in-minutes)))
(format (propertize "[%s/%s] (%s) " 'face 'org-mode-line-clock)
work-done-str effort-str org-clock-heading))
(format (propertize "[%s] (%s) " 'face 'org-mode-line-clock)
(org-duration-from-minutes clocked-time)
org-clock-heading))))
(defun org-clock-get-last-clock-out-time ()
"Get the last clock-out time for the current subtree."
(save-excursion
(let ((end (save-excursion (org-end-of-subtree))))
(when (re-search-forward (concat org-clock-string
".*\\]--\\(\\[[^]]+\\]\\)")
end t)
(org-time-string-to-time (match-string 1))))))
(defun org-clock-update-mode-line (&optional refresh)
"Update mode line with clock information.
When optional argument is non-nil, refresh cached heading."
(if org-clock-effort
(org-clock-notify-once-if-expired)
(setq org-clock-task-overrun nil))
(when refresh (setq org-clock-heading (org-clock--mode-line-heading)))
(setq org-mode-line-string
(propertize
(let ((clock-string (org-clock-get-clock-string))
(help-text "Org mode clock is running.\nmouse-1 shows a \
menu\nmouse-2 will jump to task"))
(if (and (> org-clock-string-limit 0)
(> (length clock-string) org-clock-string-limit))
(propertize
(substring clock-string 0 org-clock-string-limit)
'help-echo (concat help-text ": " org-clock-heading))
(propertize clock-string 'help-echo help-text)))
'local-map org-clock-mode-line-map
'mouse-face 'mode-line-highlight))
(if (and org-clock-task-overrun org-clock-task-overrun-text)
(setq org-mode-line-string
(concat (propertize
org-clock-task-overrun-text
'face 'org-mode-line-clock-overrun)
org-mode-line-string)))
(force-mode-line-update))
(defun org-clock-get-clocked-time ()
"Get the clocked time for the current item in minutes.
The time returned includes the time spent on this task in
previous clocking intervals."
(let ((currently-clocked-time
(floor (org-time-convert-to-integer
(time-since org-clock-start-time))
60)))
(+ currently-clocked-time (or org-clock-total-time 0))))
;;;###autoload
(defun org-clock-modify-effort-estimate (&optional value)
"Add to or set the effort estimate of the item currently being clocked.
VALUE can be a number of minutes, or a string with format hh:mm or mm.
When the string starts with a + or a - sign, the current value of the effort
property will be changed by that amount. If the effort value is expressed
as an unit defined in `org-duration-units' (e.g. \"3h\"), the modified
value will be converted to a hh:mm duration.
This command will update the \"Effort\" property of the currently
clocked item, and the value displayed in the mode line."
(interactive)
(if (org-clock-is-active)
(let ((current org-clock-effort) sign)
(unless value
;; Prompt user for a value or a change
(setq value
(read-string
(format "Set effort (hh:mm or mm%s): "
(if current
(format ", prefix + to add to %s" org-clock-effort)
"")))))
(when (stringp value)
;; A string. See if it is a delta
(setq sign (string-to-char value))
(if (member sign '(?- ?+))
(setq current (org-duration-to-minutes current)
value (substring value 1))
(setq current 0))
(setq value (org-duration-to-minutes value))
(if (equal ?- sign)
(setq value (- current value))
(if (equal ?+ sign) (setq value (+ current value)))))
(setq value (max 0 value)
org-clock-effort (org-duration-from-minutes value))
(org-entry-put org-clock-marker "Effort" org-clock-effort)
(org-clock-update-mode-line)
(message "Effort is now %s" org-clock-effort))
(message "Clock is not currently active")))
(defvar org-clock-notification-was-shown nil
"Shows if we have shown notification already.")
(defun org-clock-notify-once-if-expired ()
"Show notification if we spent more time than we estimated before.
Notification is shown only once."
(when (org-clocking-p)
(let ((effort-in-minutes (org-duration-to-minutes org-clock-effort))
(clocked-time (org-clock-get-clocked-time)))
(if (setq org-clock-task-overrun
(if (or (null effort-in-minutes) (zerop effort-in-minutes))
nil
(>= clocked-time effort-in-minutes)))
(unless org-clock-notification-was-shown
(setq org-clock-notification-was-shown t)
(org-notify
(format-message "Task `%s' should be finished by now. (%s)"
org-clock-heading org-clock-effort)
org-clock-sound))
(setq org-clock-notification-was-shown nil)))))
(defun org-notify (notification &optional play-sound)
"Send a NOTIFICATION and maybe PLAY-SOUND.
If PLAY-SOUND is non-nil, it overrides `org-clock-sound'."
(org-show-notification notification)
(if play-sound (org-clock-play-sound play-sound)))
(defun org-show-notification (notification)
"Show notification.
Use `org-show-notification-handler' if defined,
use libnotify if available, or fall back on a message."
(ignore-errors (require 'notifications))
(cond ((functionp org-show-notification-handler)
(funcall org-show-notification-handler notification))
((stringp org-show-notification-handler)
(start-process "emacs-timer-notification" nil
org-show-notification-handler notification))
((fboundp 'haiku-notifications-notify)
;; N.B. timeouts are not available under Haiku.
(haiku-notifications-notify :title "Org mode message"
:body notification
:urgency 'low))
((fboundp 'android-notifications-notify)
;; N.B. timeouts are not available under Haiku or Android.
(android-notifications-notify :title "Org mode message"
:body notification
;; Low urgency notifications
;; are by default hidden.
:urgency 'normal))
((fboundp 'w32-notification-notify)
(let ((id (w32-notification-notify
:title "Org mode message"
:body notification
:urgency 'low)))
(run-with-timer
org-show-notification-timeout
nil
(lambda () (w32-notification-close id)))))
((fboundp 'ns-do-applescript)
(ns-do-applescript
(format "display notification \"%s\" with title \"Org mode notification\""
(replace-regexp-in-string "\"" "#" notification))))
((fboundp 'notifications-notify)
(notifications-notify
:title "Org mode message"
:body notification
:timeout (* org-show-notification-timeout 1000)
;; FIXME how to link to the Org icon?
;; :app-icon "~/.emacs.d/icons/mail.png"
:urgency 'low))
((executable-find "notify-send")
(start-process "emacs-timer-notification" nil
"notify-send" notification))
;; Maybe the handler will send a message, so only use message as
;; a fall back option
(t (message "%s" notification))))
(defun org-clock-play-sound (&optional clock-sound)
"Play sound as configured by `org-clock-sound'.
Use alsa's aplay tool if available.
If CLOCK-SOUND is non-nil, it overrides `org-clock-sound'."
(let ((org-clock-sound (or clock-sound org-clock-sound)))
(cond
((not org-clock-sound))
((eq org-clock-sound t) (beep t) (beep t))
((stringp org-clock-sound)
(let ((file (expand-file-name org-clock-sound)))
(if (file-exists-p file)
(if (executable-find "aplay")
(start-process "org-clock-play-notification" nil
"aplay" file)
(condition-case-unless-debug nil
(play-sound-file file)
(error (beep t) (beep t))))))))))
(defvar org-clock-mode-line-entry nil
"Information for the mode line about the running clock.")
(defun org-find-open-clocks (file)
"Search through the given file and find all open clocks."
(let ((buf (or (get-file-buffer file)
(find-file-noselect file)))
(org-clock-re (concat org-clock-string " \\(\\[.*?\\]\\)$"))
clocks)
(with-current-buffer buf
(save-excursion
(goto-char (point-min))
(while (re-search-forward org-clock-re nil t)
(when (save-match-data
(org-element-type-p (org-element-at-point) 'clock))
(push (cons (copy-marker (match-end 1) t)
(org-time-string-to-time (match-string 1)))
clocks)))))
clocks))
(defsubst org-is-active-clock (clock)
"Return t if CLOCK is the currently active clock."
(and (org-clock-is-active)
(= org-clock-marker (car clock))))
(defmacro org-with-clock-position (clock &rest forms)
"Evaluate FORMS with CLOCK as the current active clock."
(declare (indent 1) (debug t))
`(with-current-buffer (marker-buffer (car ,clock))
(org-with-wide-buffer
(goto-char (car ,clock))
(forward-line 0)
,@forms)))
(defmacro org-with-clock (clock &rest forms)
"Evaluate FORMS with CLOCK as the current active clock.
This macro also protects the current active clock from being altered."
(declare (indent 1) (debug t))
`(org-with-clock-position ,clock
(let ((org-clock-start-time (cdr ,clock))
(org-clock-total-time)
(org-clock-history)
(org-clock-effort)
(org-clock-marker (car ,clock))
(org-clock-hd-marker (save-excursion
(org-back-to-heading t)
(point-marker))))
,@forms)))
(defsubst org-clock-clock-in (clock &optional resume start-time)
"Clock in to the clock located by CLOCK.
If necessary, clock-out of the currently active clock."
(org-with-clock-position clock
(let ((org-clock-in-resume (or resume org-clock-in-resume)))
(org-clock-in nil start-time))))
(defsubst org-clock-clock-out (clock &optional fail-quietly at-time)
"Clock out of the clock located by CLOCK."
(let ((temp (copy-marker (car clock)
(marker-insertion-type (car clock)))))
(if (org-is-active-clock clock)
(org-clock-out nil fail-quietly at-time)
(org-with-clock clock
(org-clock-out nil fail-quietly at-time)))
(setcar clock temp)))
(defsubst org-clock-clock-cancel (clock)
"Cancel the clock located by CLOCK."
(let ((temp (copy-marker (car clock)
(marker-insertion-type (car clock)))))
(if (org-is-active-clock clock)
(org-clock-cancel)
(org-with-clock clock
(org-clock-cancel)))
(setcar clock temp)))
(defvar org-clock-clocking-in nil)
(defvar org-clock-resolving-clocks nil)
(defvar org-clock-resolving-clocks-due-to-idleness nil)
(defun org-clock-resolve-clock
(clock resolve-to clock-out-time close restart fail-quietly)
"Resolve CLOCK given the time RESOLVE-TO, and the present.
CLOCK is a cons cell of the form (MARKER START-TIME)."
(let ((org-clock-resolving-clocks t)
;; If the clocked entry contained only a clock and possibly
;; the associated drawer, and we either cancel it or clock it
;; out, `org-clock-out-remove-zero-time-clocks' may clear all
;; contents, and leave point on the /next/ headline. We store
;; the current entry location to be able to get back here when
;; we need to clock in again the previously clocked task.
(heading (org-with-point-at (car clock)
(org-back-to-heading t)
(point-marker))))
(pcase resolve-to
(`nil
(org-clock-clock-cancel clock)
(when (and restart (not org-clock-clocking-in))
(org-with-point-at heading (org-clock-in))))
(`now
(cond
(restart (error "RESTART is not valid here"))
((or close org-clock-clocking-in)
(org-clock-clock-out clock fail-quietly))
((org-is-active-clock clock) nil)
(t (org-clock-clock-in clock t))))
((pred (time-less-p nil))
(error "RESOLVE-TO must refer to a time in the past"))
(_
(when restart (error "RESTART is not valid here"))
(org-clock-clock-out clock fail-quietly (or clock-out-time resolve-to))
(cond
(org-clock-clocking-in nil)
(close
(setq org-clock-leftover-time (and (null clock-out-time) resolve-to)))
(t
(org-with-point-at heading
(org-clock-in nil (and clock-out-time resolve-to)))))))))
(defun org-clock-jump-to-current-clock (&optional effective-clock)
"When an Org clock is running, jump to it."
(let ((drawer (org-clock-into-drawer))
(clock (or effective-clock (cons org-clock-marker
org-clock-start-time))))
(unless (marker-buffer (car clock))
(user-error "No Org clock is currently running"))
(org-with-clock clock (org-clock-goto))
(with-current-buffer (marker-buffer (car clock))
(goto-char (car clock))
(when drawer
(org-with-wide-buffer
(let ((drawer-re (format "^[ \t]*:%s:[ \t]*$"
(regexp-quote (if (stringp drawer) drawer "LOGBOOK"))))
(beg (save-excursion (org-back-to-heading t) (point))))
(catch 'exit
(while (re-search-backward drawer-re beg t)
(let ((element (org-element-at-point)))
(when (org-element-type-p element 'drawer)
(when (> (org-element-end element) (car clock))
(org-fold-hide-drawer-toggle 'off nil element))
(throw 'exit nil)))))))))))
(defun org-clock-resolve (clock &optional prompt-fn last-valid fail-quietly)
"Resolve an open Org clock.
An open clock was found, with `dangling' possibly being non-nil.
If this function was invoked with a prefix argument, non-dangling
open clocks are ignored. The given clock requires some sort of
user intervention to resolve it, either because a clock was left
dangling or due to an idle timeout. The clock resolution can
either be:
(a) deleted, the user doesn't care about the clock
(b) restarted from the current time (if no other clock is open)
(c) closed, giving the clock X minutes
(d) closed and then restarted
(e) resumed, as if the user had never left
The format of clock is (CONS MARKER START-TIME), where MARKER
identifies the buffer and position the clock is open at (and
thus, the heading it's under), and START-TIME is when the clock
was started."
(cl-assert clock)
(let* ((ch
(save-window-excursion
(save-excursion
(unless org-clock-resolving-clocks-due-to-idleness
(org-clock-jump-to-current-clock clock))
(unless org-clock-resolve-expert
(with-output-to-temp-buffer "*Org Clock*"
(princ (format-message "Select a Clock Resolution Command:
i/q Ignore this question; the same as keeping all the idle time.
k/K Keep X minutes of the idle time (default is all). If this
amount is less than the default, you will be clocked out
that many minutes after the time that idling began, and then
clocked back in at the present time.
t/T Like `k', but will ask you to specify a time (when you got
distracted away), instead of a number of minutes.
g/G Indicate that you \"got back\" X minutes ago. This is quite
different from `k': it clocks you out from the beginning of
the idle period and clock you back in X minutes ago.
s/S Subtract the idle time from the current clock. This is the
same as keeping 0 minutes.
C Cancel the open timer altogether. It will be as though you
never clocked in.
j/J Jump to the current clock, to make manual adjustments.
For all these options, using uppercase makes your final state
to be CLOCKED OUT."))))
(org-fit-window-to-buffer (get-buffer-window "*Org Clock*"))
(let (char-pressed)
(while (or (null char-pressed)
(and (not (memq char-pressed
'(?k ?K ?g ?G ?s ?S ?C
?j ?J ?i ?q ?t ?T)))
(or (ding) t)))
(setq char-pressed
(read-char-exclusive (concat (funcall prompt-fn clock)
" [jkKtTgGSscCiq]? ")
nil 45)))
(and (not (memq char-pressed '(?i ?q))) char-pressed)))))
(default
(floor (org-time-convert-to-integer (time-since last-valid))
60))
(keep
(or (and (memq ch '(?k ?K))
(read-number "Keep how many minutes: " default))
(and (memq ch '(?t ?T))
(floor
(/ (float-time
(time-subtract (org-read-date t t) last-valid))
60)))))
(gotback
(and (memq ch '(?g ?G))
(read-number "Got back how many minutes ago: " default)))
(subtractp (memq ch '(?s ?S)))
(barely-started-p (time-less-p
(time-subtract last-valid (cdr clock))
45))
(start-over (and subtractp barely-started-p)))
(cond
((memq ch '(?j ?J))
(if (eq ch ?J)
(org-clock-resolve-clock clock 'now nil t nil fail-quietly))
(org-clock-jump-to-current-clock clock))
((or (null ch)
(not (memq ch '(?k ?K ?g ?G ?s ?S ?C ?t ?T))))
(message ""))
(t
(org-clock-resolve-clock
clock (cond
((or (eq ch ?C)
;; If the time on the clock was less than a minute before
;; the user went away, and they've ask to subtract all the
;; time...
start-over)
nil)
((or subtractp
(and gotback (= gotback 0)))
last-valid)
((or (and keep (= keep default))
(and gotback (= gotback default)))
'now)
(keep
(time-add last-valid (* 60 keep)))
(gotback
(time-since (* 60 gotback)))
(t
(error "Unexpected, please report this as a bug")))
(and gotback last-valid)
(memq ch '(?K ?G ?S ?T))
(and start-over
(not (memq ch '(?K ?G ?S ?C))))
fail-quietly)))))
;;;###autoload
(defun org-resolve-clocks (&optional only-dangling-p prompt-fn last-valid)
"Resolve all currently open Org clocks.
If `only-dangling-p' is non-nil, only ask to resolve dangling
\(i.e., not currently open and valid) clocks."
(interactive "P")
(unless org-clock-resolving-clocks
(let ((org-clock-resolving-clocks t))
(dolist (file (org-files-list))
(let ((clocks (org-find-open-clocks file)))
(dolist (clock clocks)
(let ((dangling (or (not (org-clock-is-active))
(/= (car clock) org-clock-marker))))
(if (or (not only-dangling-p) dangling)
(org-clock-resolve
clock
(or prompt-fn
(lambda (clock)
(format
"Dangling clock started %d mins ago"
(floor (org-time-convert-to-integer
(time-since (cdr clock)))
60))))
(or last-valid
(cdr clock)))))))))))
(defun org-emacs-idle-seconds ()
"Return the current Emacs idle time in seconds, or nil if not idle."
(let ((idle-time (current-idle-time)))
(if idle-time
(float-time idle-time)
0)))
(defun org-mac-idle-seconds ()
"Return the current Mac idle time in seconds."
(string-to-number (shell-command-to-string "ioreg -c IOHIDSystem | perl -ane 'if (/Idle/) {$idle=(pop @F)/1000000000; print $idle; last}'")))
(defvar org-x11idle-exists-p
;; Check that x11idle exists. But don't do that on DOS/Windows,
;; since the command definitely does NOT exist there, and invoking
;; COMMAND.COM on MS-Windows is a bad idea -- it hangs.
(and (null (memq system-type '(windows-nt ms-dos)))
(eq 0 (call-process-shell-command
(format "command -v %s" org-clock-x11idle-program-name)))
;; Check that x11idle can retrieve the idle time
;; FIXME: Why "..-shell-command" rather than just `call-process'?
(eq 0 (call-process-shell-command org-clock-x11idle-program-name))))
(defun org-x11-idle-seconds ()
"Return the current X11 idle time in seconds."
(/ (string-to-number (shell-command-to-string org-clock-x11idle-program-name)) 1000))
(defvar org-logind-dbus-session-path
(when (and (boundp 'dbus-runtime-version)
(require 'dbus nil t)
(member "org.freedesktop.login1" (dbus-list-activatable-names)))
(ignore-errors
(dbus-call-method
:system "org.freedesktop.login1"
"/org/freedesktop/login1"
"org.freedesktop.login1.Manager"
"GetSessionByPID" (emacs-pid))))
"D-Bus session path for the elogind interface.")
(defun org-logind-user-idle-seconds ()
"Return the number of idle seconds for the user according to logind."
(- (float-time)
(/ (dbus-get-property
:system "org.freedesktop.login1"
org-logind-dbus-session-path
"org.freedesktop.login1.Session" "IdleSinceHint")
1e6)))
(defun org-user-idle-seconds ()
"Return the number of seconds the user has been idle for.
This routine returns a floating point number."
(cond
((eq system-type 'darwin)
(org-mac-idle-seconds))
((and (eq window-system 'x) org-x11idle-exists-p)
(org-x11-idle-seconds))
((and
org-logind-dbus-session-path
(dbus-get-property
:system "org.freedesktop.login1"
org-logind-dbus-session-path
"org.freedesktop.login1.Session" "IdleHint"))
(org-logind-user-idle-seconds))
(t
(org-emacs-idle-seconds))))
(defvar org-clock-user-idle-seconds)
(defun org-resolve-clocks-if-idle ()
"Resolve all currently open Org clocks.
This is performed after `org-clock-idle-time' minutes, to check
if the user really wants to stay clocked in after being idle for
so long."
(when (and org-clock-idle-time (not org-clock-resolving-clocks)
org-clock-marker (marker-buffer org-clock-marker))
(let* ((org-clock-user-idle-seconds (org-user-idle-seconds))
(org-clock-user-idle-start
(time-since org-clock-user-idle-seconds))
(org-clock-resolving-clocks-due-to-idleness t))
(when (> org-clock-user-idle-seconds (* 60 org-clock-idle-time))
(cancel-timer org-clock-idle-timer)
(setq org-clock-idle-timer nil)
(org-clock-resolve
(cons org-clock-marker
org-clock-start-time)
(lambda (_)
(format "Clocked in & idle for %.1f mins"
(/ (float-time
(time-since org-clock-user-idle-start))
60)))
org-clock-user-idle-start)
(when (and (org-clocking-p) (not org-clock-idle-timer))
(setq org-clock-idle-timer
(run-with-timer 60 60 #'org-resolve-clocks-if-idle)))))))
(defvar org-clock-current-task nil "Task currently clocked in.")
(defvar org-clock-out-time nil) ; store the time of the last clock-out
(defvar org--msg-extra)
;;;###autoload
(defun org-clock-in (&optional select start-time)
"Start the clock on the current item.
If necessary, clock-out of the currently active clock.
With a `\\[universal-argument]' prefix argument SELECT, offer a list of \
recently clocked
tasks to clock into.
When SELECT is `\\[universal-argument] \ \\[universal-argument]', \
clock into the current task and mark it as
the default task, a special task that will always be offered in the
clocking selection, associated with the letter `d'.
When SELECT is `\\[universal-argument] \\[universal-argument] \
\\[universal-argument]', clock in by using the last clock-out
time as the start time. See `org-clock-continuously' to make this
the default behavior."
(interactive "P")
(setq org-clock-notification-was-shown nil)
(catch 'abort
(let ((interrupting (and (not org-clock-resolving-clocks-due-to-idleness)
(org-clocking-p)))
ts selected-task target-pos (org--msg-extra "")
(leftover (and (not org-clock-resolving-clocks)
org-clock-leftover-time)))
(when (and org-clock-auto-clock-resolution
(or (not interrupting)
(eq t org-clock-auto-clock-resolution))
(not org-clock-clocking-in)
(not org-clock-resolving-clocks))
(setq org-clock-leftover-time nil)
(let ((org-clock-clocking-in t))
(org-resolve-clocks))) ; check if any clocks are dangling
(when (equal select '(64))
;; Set start-time to `org-clock-out-time'
(let ((org-clock-continuously t))
(org-clock-in nil org-clock-out-time)
(throw 'abort nil)))
(when (equal select '(4))
(pcase (org-clock-select-task "Clock-in on task: ")
(`nil (error "Abort"))
(task (setq selected-task (copy-marker task)))))
(when (equal select '(16))
;; Mark as default clocking task
(org-clock-mark-default-task))
(when interrupting
;; We are interrupting the clocking of a different task. Save
;; a marker to this task, so that we can go back. First check
;; if we are trying to clock into the same task!
(when (or selected-task (derived-mode-p 'org-mode))
(org-with-point-at selected-task
(unless selected-task (org-back-to-heading t))
(when (and (eq (marker-buffer org-clock-hd-marker)
(org-base-buffer (current-buffer)))
(= (point) (marker-position org-clock-hd-marker))
(equal org-clock-current-task (org-get-heading t t t t)))
(message "Clock continues in %S" org-clock-heading)
(throw 'abort nil))))
(move-marker org-clock-interrupted-task
(marker-position org-clock-marker)
(marker-buffer org-clock-marker))
(let ((org-clock-clocking-in t))
(org-clock-out nil t)))
;; Clock in at which position?
(setq target-pos
(if (and (eobp) (not (org-at-heading-p)))
(org-with-wide-buffer (line-beginning-position 0))
(point)))
(save-excursion
(when (and selected-task (marker-buffer selected-task))
;; There is a selected task, move to the correct buffer
;; and set the new target position.
(set-buffer (org-base-buffer (marker-buffer selected-task)))
(setq target-pos (marker-position selected-task))
(move-marker selected-task nil))
(org-with-wide-buffer
(goto-char target-pos)
(org-back-to-heading t)
(or interrupting (move-marker org-clock-interrupted-task nil))
(run-hooks 'org-clock-in-prepare-hook)
(org-clock-history-push)
(setq org-clock-current-task (org-get-heading t t t t))
(cond ((functionp org-clock-in-switch-to-state)
(let ((case-fold-search nil))
(looking-at org-complex-heading-regexp))
(let ((newstate (funcall org-clock-in-switch-to-state
(match-string 2))))
(when newstate (org-todo newstate))))
((and org-clock-in-switch-to-state
(not (looking-at (concat org-outline-regexp "[ \t]*"
org-clock-in-switch-to-state
"\\(?:[ \t]\\|$\\)"))))
(org-todo org-clock-in-switch-to-state)))
(setq org-clock-heading (org-clock--mode-line-heading))
(org-clock-find-position org-clock-in-resume)
(cond
((and org-clock-in-resume
(looking-at
(concat "^[ \t]*" org-clock-string
" \\[\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}"
" *\\sw+.? +[012][0-9]:[0-5][0-9]\\)\\][ \t]*$")))
(message "Matched %s" (match-string 1))
(setq ts (concat "[" (match-string 1) "]"))
(goto-char (match-end 1))
(setq org-clock-start-time
(org-time-string-to-time (match-string 1)))
(setq org-clock-effort (org-entry-get (point) org-effort-property))
(setq org-clock-total-time (org-clock-sum-current-item
(org-clock-get-sum-start))))
((eq org-clock-in-resume 'auto-restart)
;; called from org-clock-load during startup,
;; do not interrupt, but warn!
(message "Cannot restart clock because task does not contain unfinished clock")
(ding)
(sit-for 2)
(throw 'abort nil))
(t
;; Make sure that point moves after clock line upon
;; inserting it. Then, users can continue typing even if
;; point was right where the clock is inserted.
(insert-before-markers-and-inherit "\n")
(backward-char 1)
(when (and (save-excursion
(end-of-line 0)
(org-in-item-p)))
(forward-line 0)
(indent-line-to (max 0 (- (current-indentation) 2))))
(insert-and-inherit org-clock-string " ")
(setq org-clock-effort (org-entry-get (point) org-effort-property))
(setq org-clock-total-time (org-clock-sum-current-item
(org-clock-get-sum-start)))
(setq org-clock-start-time
(or (and org-clock-continuously org-clock-out-time)
(and leftover
(y-or-n-p
(format
"You stopped another clock %d mins ago; start this one from then? "
(/ (org-time-convert-to-integer
(time-subtract
(org-current-time org-clock-rounding-minutes t)
leftover))
60)))
leftover)
start-time
(org-current-time org-clock-rounding-minutes t)))
(setq ts (org-insert-timestamp org-clock-start-time
'with-hm 'inactive))
(org-indent-line)))
(move-marker org-clock-marker (point) (buffer-base-buffer))
(move-marker org-clock-hd-marker
(save-excursion (org-back-to-heading t) (point))
(buffer-base-buffer))
(setq org-clock-has-been-used t)
;; add to mode line
(when (or (eq org-clock-clocked-in-display 'mode-line)
(eq org-clock-clocked-in-display 'both))
(or global-mode-string (setq global-mode-string '("")))
(or (memq 'org-mode-line-string global-mode-string)
(setq global-mode-string
(append global-mode-string '(org-mode-line-string)))))
;; add to frame title
(when (or (eq org-clock-clocked-in-display 'frame-title)
(eq org-clock-clocked-in-display 'both))
(setq org-frame-title-format-backup frame-title-format)
(setq frame-title-format org-clock-frame-title-format))
(org-clock-update-mode-line)
(when org-clock-mode-line-timer
(cancel-timer org-clock-mode-line-timer)
(setq org-clock-mode-line-timer nil))
(when org-clock-clocked-in-display
(setq org-clock-mode-line-timer
(run-with-timer org-clock-update-period
org-clock-update-period
#'org-clock-update-mode-line)))
(when org-clock-idle-timer
(cancel-timer org-clock-idle-timer)
(setq org-clock-idle-timer nil))
(setq org-clock-idle-timer
(run-with-timer 60 60 #'org-resolve-clocks-if-idle))
(message "Clock starts at %s - %s" ts org--msg-extra)
(run-hooks 'org-clock-in-hook))))))
(defvar org-clock--auto-clockout-timer-obj nil
"Timer object holding the existing clockout timer.")
(defun org-clock--auto-clockout-maybe ()
"Clock out the currently clocked in task when idle.
See `org-clock-auto-clockout-timer' to set the idle time span.
This function is to be called by a timer."
(when (and (numberp org-clock-auto-clockout-timer)
org-clock-current-task)
(let ((user-idle-seconds (org-user-idle-seconds)))
(cond
;; Already idle. Clock out.
((>= user-idle-seconds org-clock-auto-clockout-timer)
(setq org-clock--auto-clockout-timer-obj nil)
(org-clock-out))
;; Emacs is idle but system is not. Retry assuming that system will remain idle.
((>= (org-emacs-idle-seconds) org-clock-auto-clockout-timer)
(setq org-clock--auto-clockout-timer-obj
(run-with-timer
(- org-clock-auto-clockout-timer user-idle-seconds)
nil #'org-clock--auto-clockout-maybe)))
;; Emacs is not idle. Check again next time we are idle.
(t
(setq org-clock--auto-clockout-timer-obj
(run-with-idle-timer
org-clock-auto-clockout-timer nil #'org-clock--auto-clockout-maybe)))))))
(defun org-clock-auto-clockout ()
"Clock out the currently clocked in task if Emacs is idle.
See `org-clock-auto-clockout-timer' to set the idle time span.
This is only effective when `org-clock-auto-clockout-insinuate'
is present in the user configuration."
(when (and (numberp org-clock-auto-clockout-timer)
org-clock-current-task
(not (timerp org-clock--auto-clockout-timer-obj)))
(setq org-clock--auto-clockout-timer-obj
(run-with-idle-timer
org-clock-auto-clockout-timer nil #'org-clock--auto-clockout-maybe))))
;;;###autoload
(defun org-clock-toggle-auto-clockout ()
(interactive)
(if (memq 'org-clock-auto-clockout org-clock-in-hook)
(progn (remove-hook 'org-clock-in-hook #'org-clock-auto-clockout)
(message "Auto clock-out after idle time turned off"))
(add-hook 'org-clock-in-hook #'org-clock-auto-clockout t)
(message "Auto clock-out after idle time turned on")))
;;;###autoload
(defun org-clock-in-last (&optional arg)
"Clock in the last closed clocked item.
When already clocking in, send a warning.
With a universal prefix argument, select the task you want to
clock in from the last clocked in tasks.
With two universal prefix arguments, start clocking using the
last clock-out time, if any.
With three universal prefix arguments, interactively prompt
for a todo state to switch to, overriding the existing value
`org-clock-in-switch-to-state'."
(interactive "P")
(if (equal arg '(4)) (org-clock-in arg)
(let ((start-time (if (or org-clock-continuously (equal arg '(16)))
(or org-clock-out-time
(org-current-time org-clock-rounding-minutes t))
(org-current-time org-clock-rounding-minutes t))))
(if (null org-clock-history)
(message "No last clock")
(let ((org-clock-in-switch-to-state
(if (and (not org-clock-current-task) (equal arg '(64)))
(completing-read "Switch to state: "
(and org-clock-history
(with-current-buffer
(marker-buffer (car org-clock-history))
org-todo-keywords-1)))
org-clock-in-switch-to-state))
(already-clocking org-clock-current-task))
(org-clock-clock-in (list (car org-clock-history)) nil start-time)
(or already-clocking
;; Don't display a message if we are already clocking in
(message "Clocking back: %s (in %s)"
org-clock-current-task
(buffer-name (marker-buffer org-clock-marker)))))))))
(defun org-clock-mark-default-task ()
"Mark current task as default task."
(interactive)
(save-excursion
(org-back-to-heading t)
(move-marker org-clock-default-task (point))))
(defun org-clock-get-sum-start ()
"Return the time from which clock times should be counted.
This is for the currently running clock as it is displayed in the
mode line. This function looks at the properties LAST_REPEAT and
in particular CLOCK_MODELINE_TOTAL and the corresponding variable
`org-clock-mode-line-total' and then decides which time to use.
The time is always returned as UTC."
(let ((cmt (or (org-entry-get nil "CLOCK_MODELINE_TOTAL" 'selective)
(symbol-name org-clock-mode-line-total)))
(lr (org-entry-get nil "LAST_REPEAT")))
(cond
((equal cmt "current")
(setq org--msg-extra "showing time in current clock instance")
(current-time))
((equal cmt "today")
(setq org--msg-extra "showing today's task time.")
(let* ((dt (decode-time))
(hour (nth 2 dt))
(day (nth 3 dt)))
(if (< hour org-extend-today-until) (setf (nth 3 dt) (1- day)))
(setf (nth 2 dt) org-extend-today-until)
(org-encode-time (apply #'list 0 0 (nthcdr 2 dt)))))
((or (equal cmt "all")
(and (or (not cmt) (equal cmt "auto"))
(not lr)))
(setq org--msg-extra "showing entire task time.")
nil)
((or (equal cmt "repeat")
(and (or (not cmt) (equal cmt "auto"))
lr))
(setq org--msg-extra "showing task time since last repeat.")
(and lr (org-time-string-to-time lr)))
(t nil))))
(defun org-clock-find-position (find-unclosed)
"Find the location where the next clock line should be inserted.
When FIND-UNCLOSED is non-nil, first check if there is an unclosed clock
line and position cursor in that line."
(org-back-to-heading t)
(catch 'exit
(let* ((beg (line-beginning-position))
(end (save-excursion (outline-next-heading) (point)))
(org-clock-into-drawer (org-clock-into-drawer))
(drawer (org-clock-drawer-name)))
;; Look for a running clock if FIND-UNCLOSED in non-nil.
(when find-unclosed
(let ((open-clock-re
(concat "^[ \t]*"
org-clock-string
" \\[\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}"
" *\\sw+ +[012][0-9]:[0-5][0-9]\\)\\][ \t]*$")))
(while (re-search-forward open-clock-re end t)
(let ((element (org-element-at-point)))
(when (and (org-element-type-p element 'clock)
(eq (org-element-property :status element) 'running))
(forward-line 0)
(throw 'exit t))))))
;; Look for an existing clock drawer.
(when drawer
(goto-char beg)
(let ((drawer-re (concat "^[ \t]*:" (regexp-quote drawer) ":[ \t]*$")))
(while (re-search-forward drawer-re end t)
(let ((element (org-element-at-point)))
(when (org-element-type-p element 'drawer)
(let ((cend (org-element-contents-end element)))
(if (and (not org-log-states-order-reversed) cend)
(goto-char cend)
(forward-line))
(throw 'exit t)))))))
(goto-char beg)
(let ((clock-re (concat "^[ \t]*" org-clock-string))
(count 0)
positions)
;; Count the CLOCK lines and store their positions.
(save-excursion
(while (re-search-forward clock-re end t)
(let ((element (org-element-at-point)))
(when (org-element-type-p element 'clock)
(setq positions (cons (line-beginning-position) positions)
count (1+ count))))))
(cond
((null positions)
(org-fold-core-ignore-modifications
;; Skip planning line and property drawer, if any.
(org-end-of-meta-data)
(unless (bolp) (insert-before-markers-and-inherit "\n"))
;; Create a new drawer if necessary.
(when (and org-clock-into-drawer
(or (not (wholenump org-clock-into-drawer))
(< org-clock-into-drawer 2)))
(let ((beg (point)))
;; Make sure that point moves after drawer upon
;; inserting it. Then, users can continue typing even
;; if point was right where the clock is inserted.
(insert-before-markers-and-inherit ":" drawer ":\n:END:\n")
(org-indent-region beg (point))
(org-fold-region (line-end-position -1) (1- (point)) t 'drawer)
(forward-line -1)))))
;; When a clock drawer needs to be created because of the
;; number of clock items or simply if it is missing, collect
;; all clocks in the section and wrap them within the drawer.
((if (wholenump org-clock-into-drawer)
(>= (1+ count) org-clock-into-drawer)
drawer)
;; Skip planning line and property drawer, if any.
(org-end-of-meta-data)
(org-fold-core-ignore-modifications
(let ((beg (point)))
(insert-and-inherit
(mapconcat
(lambda (p)
(save-excursion
(goto-char p)
(org-trim (delete-and-extract-region
(save-excursion (skip-chars-backward " \r\t\n")
(line-beginning-position 2))
(line-beginning-position 2)))))
positions "\n")
"\n:END:\n")
(let ((end (point-marker)))
(goto-char beg)
(save-excursion (insert-before-markers-and-inherit ":" drawer ":\n"))
(org-fold-region (line-end-position) (1- end) t 'outline)
(org-indent-region (point) end)
(forward-line)
(unless org-log-states-order-reversed
(goto-char end)
(forward-line -2))
(set-marker end nil)))))
(org-log-states-order-reversed (goto-char (car (last positions))))
(t (goto-char (car positions))))))))
(defun org-clock-restore-frame-title-format ()
"Restore `frame-title-format' from `org-frame-title-format-backup'.
`frame-title-format' is restored if `org-frame-title-format-backup' is not nil
and current `frame-title-format' is equal to `org-clock-frame-title-format'."
(when (and org-frame-title-format-backup
(equal frame-title-format org-clock-frame-title-format))
(setq frame-title-format org-frame-title-format-backup)))
(defvar org-clock-out-removed-last-clock nil
"When non-nil, the last `org-clock-out' removed the clock line.
This can happen when `org-clock-out-remove-zero-time-clocks' is set to
non-nil and the latest clock took 0 minutes.")
;;;###autoload
(defun org-clock-out (&optional switch-to-state fail-quietly at-time)
"Stop the currently running clock.
Throw an error if there is no running clock and FAIL-QUIETLY is nil.
With a universal prefix, prompt for a state to switch the clocked out task
to, overriding the existing value of `org-clock-out-switch-to-state'."
(interactive "P")
(catch 'exit
(when (not (org-clocking-p))
(setq global-mode-string
(delq 'org-mode-line-string global-mode-string))
(org-clock-restore-frame-title-format)
(force-mode-line-update)
(if fail-quietly (throw 'exit t) (user-error "No active clock")))
(let ((org-clock-out-switch-to-state
(if switch-to-state
(completing-read "Switch to state: "
(with-current-buffer
(marker-buffer org-clock-marker)
org-todo-keywords-1)
nil t "DONE")
org-clock-out-switch-to-state))
(now (org-current-time org-clock-rounding-minutes))
ts te s h m remove)
(setq org-clock-out-time (or at-time now))
(save-excursion ; Do not replace this with `with-current-buffer'.
(with-no-warnings (set-buffer (org-clocking-buffer)))
(save-restriction
(widen)
(goto-char org-clock-marker)
(forward-line 0)
(if (and (looking-at (concat "[ \t]*" org-keyword-time-regexp))
(equal (match-string 1) org-clock-string))
(setq ts (match-string 2))
(if fail-quietly (throw 'exit nil) (error "Clock start time is gone")))
(goto-char (match-end 0))
(delete-region (point) (line-end-position))
(org-fold-core-ignore-modifications
(insert-and-inherit "--")
(setq te (org-insert-timestamp (or at-time now) 'with-hm 'inactive))
(setq s (org-time-convert-to-integer
(time-subtract
(org-time-string-to-time te)
(org-time-string-to-time ts)))
h (floor s 3600)
m (floor (mod s 3600) 60))
(insert-and-inherit " => " (format "%2d:%02d" h m))
(move-marker org-clock-marker nil)
(move-marker org-clock-hd-marker nil)
;; Possibly remove zero time clocks.
(when (and org-clock-out-remove-zero-time-clocks
(= 0 h m))
(setq remove t)
(delete-region (line-beginning-position)
(line-beginning-position 2)))
(org-clock-remove-empty-clock-drawer))
(when org-clock-mode-line-timer
(cancel-timer org-clock-mode-line-timer)
(setq org-clock-mode-line-timer nil))
(when org-clock-idle-timer
(cancel-timer org-clock-idle-timer)
(setq org-clock-idle-timer nil))
(setq global-mode-string
(delq 'org-mode-line-string global-mode-string))
(org-clock-restore-frame-title-format)
(when org-clock-out-switch-to-state
(save-excursion
(org-back-to-heading t)
(let ((org-clock-out-when-done nil))
(cond
((functionp org-clock-out-switch-to-state)
(let ((case-fold-search nil))
(looking-at org-complex-heading-regexp))
(let ((newstate (funcall org-clock-out-switch-to-state
(match-string 2))))
(when newstate (org-todo newstate))))
((and org-clock-out-switch-to-state
(not (looking-at
(concat
org-outline-regexp "[ \t]*"
org-clock-out-switch-to-state
"\\(?:[ \t]\\|$\\)"))))
(org-todo org-clock-out-switch-to-state))))))
(force-mode-line-update)
(message (if remove
"Clock stopped at %s after %s => LINE REMOVED"
"Clock stopped at %s after %s")
te (org-duration-from-minutes (+ (* 60 h) m)))
(unless (org-clocking-p)
(setq org-clock-current-task nil))
(setq org-clock-out-removed-last-clock remove)
(run-hooks 'org-clock-out-hook)
;; Add a note, but only if we didn't remove the clock line.
(when (and org-log-note-clock-out (not remove))
(org-add-log-setup
'clock-out nil nil nil
(concat "# Task: " (org-get-heading t) "\n\n"))))))))
(defun org-clock-remove-empty-clock-drawer ()
"Remove empty clock drawers in current subtree."
(save-excursion
(org-back-to-heading t)
(org-map-tree
(lambda ()
(let ((drawer (org-clock-drawer-name))
(case-fold-search t))
(when drawer
(let ((re (format "^[ \t]*:%s:[ \t]*$" (regexp-quote drawer)))
(end (save-excursion (outline-next-heading))))
(while (re-search-forward re end t)
(org-remove-empty-drawer-at (point))))))))))
(defun org-clock-timestamps-up (&optional n)
"Increase CLOCK timestamps at cursor.
Optional argument N tells to change by that many units."
(interactive "P")
(org-clock-timestamps-change 'up n))
(defun org-clock-timestamps-down (&optional n)
"Decrease CLOCK timestamps at cursor.
Optional argument N tells to change by that many units."
(interactive "P")
(org-clock-timestamps-change 'down n))
(defun org-clock-timestamps-change (updown &optional n)
"Change CLOCK timestamps synchronously at cursor.
UPDOWN tells whether to change `up' or `down'.
Optional argument N tells to change by that many units."
(let ((tschange (if (eq updown 'up) 'org-timestamp-up
'org-timestamp-down))
(timestamp? (org-at-timestamp-p 'lax))
ts1 begts1 ts2 begts2 updatets1 tdiff)
(when timestamp?
(save-excursion
(move-beginning-of-line 1)
(re-search-forward org-ts-regexp3 nil t)
(setq ts1 (match-string 0) begts1 (match-beginning 0))
(when (re-search-forward org-ts-regexp3 nil t)
(setq ts2 (match-string 0) begts2 (match-beginning 0))))
;; Are we on the second timestamp?
(if (<= begts2 (point)) (setq updatets1 t))
(if (not ts2)
;; fall back on org-timestamp-up if there is only one
(funcall tschange n)
(funcall tschange n)
(let ((ts (if updatets1 ts2 ts1))
(begts (if updatets1 begts1 begts2)))
(setq tdiff
(time-subtract
(org-time-string-to-time
(save-excursion
(goto-char (if updatets1 begts2 begts1))
(looking-at org-ts-regexp3)
(match-string 0)))
(org-time-string-to-time ts)))
;; `save-excursion' won't work because
;; `org-timestamp-change' deletes and re-inserts the
;; timestamp.
(let ((origin (point)))
(save-excursion
(goto-char begts)
(org-timestamp-change
(round (/ (float-time tdiff)
(pcase timestamp?
(`minute 60)
(`hour 3600)
(`day (* 24 3600))
(`month (* 24 3600 31))
(`year (* 24 3600 365.2)))))
timestamp? 'updown))
;; Move back to initial position, but never beyond updated
;; clock.
(unless (< (point) origin)
(goto-char origin))))))))
;;;###autoload
(defun org-clock-cancel ()
"Cancel the running clock by removing the start timestamp."
(interactive)
(when (not (org-clocking-p))
(setq global-mode-string
(delq 'org-mode-line-string global-mode-string))
(org-clock-restore-frame-title-format)
(force-mode-line-update)
(user-error "No active clock"))
(save-excursion ; Do not replace this with `with-current-buffer'.
(with-no-warnings (set-buffer (org-clocking-buffer)))
(goto-char org-clock-marker)
(if (looking-back (concat "^[ \t]*" org-clock-string ".*")
(line-beginning-position))
(progn (delete-region (1- (line-beginning-position)) (line-end-position))
(org-remove-empty-drawer-at (point)))
(message "Clock gone, cancel the timer anyway")
(sit-for 2)))
(move-marker org-clock-marker nil)
(move-marker org-clock-hd-marker nil)
(setq org-clock-current-task nil)
(setq global-mode-string
(delq 'org-mode-line-string global-mode-string))
(org-clock-restore-frame-title-format)
(force-mode-line-update)
(message "Clock canceled")
(run-hooks 'org-clock-cancel-hook))
;;;###autoload
(defun org-clock-goto (&optional select)
"Go to the currently clocked-in entry, or to the most recently clocked one.
With prefix arg SELECT, offer recently clocked tasks for selection."
(interactive "@P")
(let* ((recent nil)
(m (cond
(select
(or (org-clock-select-task "Select task to go to: ")
(user-error "No task selected")))
((org-clocking-p) org-clock-marker)
((and org-clock-goto-may-find-recent-task
(car org-clock-history)
(marker-buffer (car org-clock-history)))
(setq recent t)
(car org-clock-history))
(t (user-error "No active or recent clock task")))))
(pop-to-buffer-same-window (marker-buffer m))
(if (or (< m (point-min)) (> m (point-max))) (widen))
(goto-char m)
(org-fold-show-entry)
(org-back-to-heading t)
(recenter org-clock-goto-before-context)
(org-fold-reveal)
(if recent
(message "No running clock, this is the most recently clocked task"))
(run-hooks 'org-clock-goto-hook)))
(defvar-local org-clock-file-total-minutes nil
"Holds the file total time in minutes, after a call to `org-clock-sum'.")
;;;###autoload
(defun org-clock-sum-today (&optional headline-filter)
"Sum the times for each subtree for today."
(let ((range (org-clock-special-range 'today)))
(org-clock-sum (car range) (cadr range)
headline-filter :org-clock-minutes-today)))
(defun org-clock-sum-custom (&optional headline-filter range propname)
"Sum the times for each subtree for today."
(let ((r (or (and (symbolp range) (org-clock-special-range range))
(org-clock-special-range
(intern (completing-read
"Range: "
'("today" "yesterday" "thisweek" "lastweek"
"thismonth" "lastmonth" "thisyear" "lastyear"
"interactive")
nil t))))))
(org-clock-sum (car r) (cadr r)
headline-filter (or propname :org-clock-minutes-custom))))
;;;###autoload
(defun org-clock-sum (&optional tstart tend headline-filter propname)
"Sum the times for each subtree.
Puts the resulting times in minutes as a text property on each headline.
TSTART and TEND can mark a time range to be considered.
HEADLINE-FILTER is a zero-arg function that, if specified, is called for
each headline in the time range with point at the headline. Headlines for
which HEADLINE-FILTER returns nil are excluded from the clock summation.
PROPNAME lets you set a custom text property instead of :org-clock-minutes."
(with-silent-modifications
(let* ((re (concat "^\\(\\*+\\)[ \t]\\|^[ \t]*"
org-clock-string
"[ \t]*\\(?:\\(\\[.*?\\]\\)-+\\(\\[.*?\\]\\)\\|=>[ \t]+\\([0-9]+\\):\\([0-9]+\\)\\)"))
(lmax 30)
(ltimes (make-vector lmax 0))
(level 0)
(tstart (cond ((stringp tstart) (org-time-string-to-seconds tstart))
((consp tstart) (float-time tstart))
(t tstart)))
(tend (cond ((stringp tend) (org-time-string-to-seconds tend))
((consp tend) (float-time tend))
(t tend)))
(t1 0)
time)
(remove-text-properties (point-min) (point-max)
`(,(or propname :org-clock-minutes) t
:org-clock-force-headline-inclusion t))
(save-excursion
(goto-char (point-max))
(while (re-search-backward re nil t)
(let* ((element (save-match-data (org-element-at-point)))
(element-type (org-element-type element)))
(cond
((and (eq element-type 'clock) (match-end 2))
;; Two time stamps.
(condition-case nil
(let* ((timestamp (org-element-property :value element))
(ts (float-time
(org-encode-time
(list 0
(org-element-property :minute-start timestamp)
(org-element-property :hour-start timestamp)
(org-element-property :day-start timestamp)
(org-element-property :month-start timestamp)
(org-element-property :year-start timestamp)
nil -1 nil))))
(te (float-time
(org-encode-time
(list 0
(org-element-property :minute-end timestamp)
(org-element-property :hour-end timestamp)
(org-element-property :day-end timestamp)
(org-element-property :month-end timestamp)
(org-element-property :year-end timestamp)
nil -1 nil))))
(dt (- (if tend (min te tend) te)
(if tstart (max ts tstart) ts))))
(when (> dt 0) (cl-incf t1 (floor dt 60))))
(error
(org-display-warning (format "org-clock-sum: Ignoring invalid %s" (org-current-line-string))))))
((match-end 4)
;; A naked time.
(setq t1 (+ t1 (string-to-number (match-string 5))
(* 60 (string-to-number (match-string 4))))))
((memq element-type '(headline inlinetask)) ;A headline
;; Add the currently clocking item time to the total.
(when (and org-clock-report-include-clocking-task
(eq (org-clocking-buffer) (current-buffer))
(eq (marker-position org-clock-hd-marker) (point))
tstart
tend
(>= (float-time org-clock-start-time) tstart)
(<= (float-time org-clock-start-time) tend))
(let ((time (floor (org-time-convert-to-integer
(time-since org-clock-start-time))
60)))
(setq t1 (+ t1 time))))
(let* ((headline-forced
(get-text-property (point)
:org-clock-force-headline-inclusion))
(headline-included
(or (null headline-filter)
(save-excursion
(save-match-data (funcall headline-filter))))))
(setq level (- (match-end 1) (match-beginning 1)))
(when (>= level lmax)
(setq ltimes (vconcat ltimes (make-vector lmax 0)) lmax (* 2 lmax)))
(when (or (> t1 0) (> (aref ltimes level) 0))
(when (or headline-included headline-forced)
(if headline-included
(cl-loop for l from 0 to level do
(aset ltimes l (+ (aref ltimes l) t1))))
(setq time (aref ltimes level))
(goto-char (match-beginning 0))
(put-text-property (point) (line-end-position)
(or propname :org-clock-minutes) time)
(when headline-filter
(save-excursion
(save-match-data
(while (org-up-heading-safe)
(put-text-property
(point) (line-end-position)
:org-clock-force-headline-inclusion t))))))
(setq t1 0)
(cl-loop for l from level to (1- lmax) do
(aset ltimes l 0))))))))
(setq org-clock-file-total-minutes (aref ltimes 0))))))
(defun org-clock-sum-current-item (&optional tstart)
"Return time, clocked on current item in total."
(save-excursion
(save-restriction
(if (and (featurep 'org-inlinetask)
(or (org-inlinetask-at-task-p)
(org-inlinetask-in-task-p)))
(narrow-to-region (save-excursion (org-inlinetask-goto-beginning) (point))
(save-excursion (org-inlinetask-goto-end) (point)))
(org-narrow-to-subtree))
(org-clock-sum tstart)
org-clock-file-total-minutes)))
;;;###autoload
(defun org-clock-display (&optional arg)
"Show subtree times in the entire buffer.
By default, show the total time for the range defined in
`org-clock-display-default-range'. With `\\[universal-argument]' \
prefix, show
the total time for today instead.
With `\\[universal-argument] \\[universal-argument]' prefix, \
use a custom range, entered at prompt.
With `\\[universal-argument] \ \\[universal-argument] \
\\[universal-argument]' prefix, display the total time in the
echo area.
Use `\\[org-clock-remove-overlays]' to remove the subtree times."
(interactive "P")
(org-clock-remove-overlays)
(let* ((todayp (equal arg '(4)))
(customp (member arg '((16) today yesterday
thisweek lastweek thismonth
lastmonth thisyear lastyear
untilnow interactive)))
(prop (cond ((not arg) :org-clock-minutes-default)
(todayp :org-clock-minutes-today)
(customp :org-clock-minutes-custom)
(t :org-clock-minutes))))
(cond ((not arg) (org-clock-sum-custom
nil org-clock-display-default-range prop))
(todayp (org-clock-sum-today))
(customp (org-clock-sum-custom nil arg))
(t (org-clock-sum)))
(unless (equal arg '(64))
(save-excursion
(goto-char (point-min))
(let ((p nil))
(while (or (and (equal (setq p (point)) (point-min))
(get-text-property p prop))
(setq p (next-single-property-change (point) prop)))
(goto-char p)
(let ((time (get-text-property p prop)))
(when time (org-clock-put-overlay time)))))
;; Arrange to remove the overlays upon next change.
(when org-remove-highlights-with-change
(add-hook 'before-change-functions #'org-clock-remove-overlays
nil 'local))))
(let* ((h (/ org-clock-file-total-minutes 60))
(m (- org-clock-file-total-minutes (* 60 h))))
(message (cond
(todayp
"Total file time for today: %s (%d hours and %d minutes)")
(customp
"Total file time (custom): %s (%d hours and %d minutes)")
(t
"Total file time: %s (%d hours and %d minutes)"))
(org-duration-from-minutes org-clock-file-total-minutes)
h m))))
(defvar-local org-clock-overlays nil)
(put 'org-clock-overlays 'permanent-local t)
(defun org-clock-put-overlay (time)
"Put an overlay on the headline at point, displaying TIME.
Create a new overlay and store it in `org-clock-overlays', so
that it will be easy to remove. This function assumes point is
on a headline."
(org-match-line org-complex-heading-regexp)
(goto-char (match-beginning 4))
(let* ((headline (match-string 4))
(text (concat headline
(org-add-props
(make-string
(max (- (- 60 (current-column))
(org-string-width headline)
(length (org-get-at-bol 'line-prefix)))
0)
?\·)
'(face shadow))
(org-add-props
(format " %9s " (org-duration-from-minutes time))
'(face org-clock-overlay))))
(o (make-overlay (point) (line-end-position))))
(org-overlay-display o text)
(push o org-clock-overlays)))
;;;###autoload
(defun org-clock-remove-overlays (&optional _beg _end noremove)
"Remove the occur highlights from the buffer.
If NOREMOVE is nil, remove this function from the
`before-change-functions' in the current buffer."
(interactive)
(unless org-inhibit-highlight-removal
(mapc #'delete-overlay org-clock-overlays)
(setq org-clock-overlays nil)
(unless noremove
(remove-hook 'before-change-functions
#'org-clock-remove-overlays 'local))))
;;;###autoload
(defun org-clock-out-if-current ()
"Clock out if the current entry contains the running clock.
This is used to stop the clock after a TODO entry is marked DONE,
and is only done if the variable `org-clock-out-when-done' is not nil."
(when (and (org-clocking-p)
org-clock-out-when-done
(marker-buffer org-clock-marker)
(or (and (eq t org-clock-out-when-done)
(member org-state org-done-keywords))
(and (listp org-clock-out-when-done)
(member org-state org-clock-out-when-done)))
(equal (or (buffer-base-buffer (org-clocking-buffer))
(org-clocking-buffer))
(or (buffer-base-buffer (current-buffer))
(current-buffer)))
(< (point) org-clock-marker)
(> (org-with-wide-buffer (org-entry-end-position))
org-clock-marker))
;; Clock out, but don't accept a logging message for this.
(let ((org-log-note-clock-out nil)
(org-clock-out-switch-to-state nil))
(org-clock-out))))
;;;###autoload
(defun org-clock-get-clocktable (&rest props)
"Get a formatted clocktable with parameters according to PROPS.
The table is created in a temporary buffer, fully formatted and
fontified, and then returned."
;; Set the defaults
(setq props (plist-put props :name "clocktable"))
(unless (plist-member props :maxlevel)
(setq props (plist-put props :maxlevel 2)))
(unless (plist-member props :scope)
(setq props (plist-put props :scope 'agenda)))
(with-temp-buffer
(org-mode)
(org-create-dblock props)
(org-update-dblock)
(font-lock-ensure)
(forward-line 2)
(buffer-substring (point) (progn
(re-search-forward "^[ \t]*#\\+END" nil t)
(line-beginning-position)))))
;;;###autoload
(defun org-clock-report (&optional arg)
"Update or create a table containing a report about clocked time.
If point is inside an existing clocktable block, update it.
Otherwise, insert a new one.
The new table inherits its properties from the variable
`org-clock-clocktable-default-properties'.
The scope of the clocktable, when not specified in the previous
variable, is `subtree' of the current heading when the function is
called from inside heading, and `file' elsewhere (before the first
heading).
When called with a prefix argument, move to the first clock table
in the buffer and update it."
(interactive "P")
(org-clock-remove-overlays)
(when arg
(org-find-dblock "clocktable")
(org-fold-show-entry))
(pcase (org-in-clocktable-p)
(`nil
(org-create-dblock
(org-combine-plists
(list :scope (if (org-before-first-heading-p) 'file 'subtree))
org-clock-clocktable-default-properties
'(:name "clocktable"))))
(start (goto-char start)))
(org-update-dblock))
;;;###autoload
(eval-after-load 'org
'(progn
(org-dynamic-block-define "clocktable" #'org-clock-report)))
(defun org-day-of-week (day month year)
"Return the day of the week as an integer."
(nth 6
(decode-time
(date-to-time
(format "%d-%02d-%02dT00:00:00" year month day)))))
(defun org-quarter-to-date (quarter year)
"Get the date (week day year) of the first day of a given quarter."
(let (startday)
(cond
((= quarter 1)
(setq startday (org-day-of-week 1 1 year))
(cond
((= startday 0)
(list 52 7 (- year 1)))
((= startday 6)
(list 52 6 (- year 1)))
((<= startday 4)
(list 1 startday year))
((> startday 4)
(list 53 startday (- year 1)))
)
)
((= quarter 2)
(setq startday (org-day-of-week 1 4 year))
(cond
((= startday 0)
(list 13 startday year))
((< startday 4)
(list 14 startday year))
((>= startday 4)
(list 13 startday year))
)
)
((= quarter 3)
(setq startday (org-day-of-week 1 7 year))
(cond
((= startday 0)
(list 26 startday year))
((< startday 4)
(list 27 startday year))
((>= startday 4)
(list 26 startday year))
)
)
((= quarter 4)
(setq startday (org-day-of-week 1 10 year))
(cond
((= startday 0)
(list 39 startday year))
((<= startday 4)
(list 40 startday year))
((> startday 4)
(list 39 startday year)))))))
(defun org-clock-special-range (key &optional time as-strings wstart mstart)
"Return two times bordering a special time range.
KEY is a symbol specifying the range and can be one of `today',
`yesterday', `thisweek', `lastweek', `thismonth', `lastmonth',
`thisyear', `lastyear' or `untilnow'. If set to `interactive',
user is prompted for range boundaries. It can be a string or an
integer.
By default, a week starts Monday 0:00 and ends Sunday 24:00. The
range is determined relative to TIME, which defaults to current
time.
The return value is a list containing two internal times, one for
the beginning of the range and one for its end, like the ones
returned by `current-time' or `encode-time' and a string used to
display information. If AS-STRINGS is non-nil, the returned
times will be formatted strings. Note that the first element is
always nil when KEY is `untilnow'.
If WSTART is non-nil, use this number to specify the starting day
of a week (monday is 1). If MSTART is non-nil, use this number
to specify the starting day of a month (1 is the first day of the
month). If you can combine both, the month starting day will
have priority."
(let* ((tm (decode-time time))
(m (nth 1 tm))
(h (nth 2 tm))
(d (nth 3 tm))
(month (nth 4 tm))
(y (nth 5 tm))
(dow (nth 6 tm))
(skey (format "%s" key))
(shift 0)
(q (cond ((>= month 10) 4)
((>= month 7) 3)
((>= month 4) 2)
(t 1)))
h1 d1 month1 y1 shiftedy shiftedm shiftedq) ;; m1
(cond
((string-match "\\`[0-9]+\\'" skey)
(setq y (string-to-number skey) month 1 d 1 key 'year))
((string-match "\\`\\([0-9]+\\)-\\([0-9]\\{1,2\\}\\)\\'" skey)
(setq y (string-to-number (match-string 1 skey))
month (string-to-number (match-string 2 skey))
d 1
key 'month))
((string-match "\\`\\([0-9]+\\)-[wW]\\([0-9]\\{1,2\\}\\)\\'" skey)
(require 'cal-iso)
(let ((date (calendar-gregorian-from-absolute
(calendar-iso-to-absolute
(list (string-to-number (match-string 2 skey))
1
(string-to-number (match-string 1 skey)))))))
(setq d (nth 1 date)
month (car date)
y (nth 2 date)
dow 1
key 'week)))
((string-match "\\`\\([0-9]+\\)-[qQ]\\([1-4]\\)\\'" skey)
(require 'cal-iso)
(setq q (string-to-number (match-string 2 skey)))
(let ((date (calendar-gregorian-from-absolute
(calendar-iso-to-absolute
(org-quarter-to-date
q (string-to-number (match-string 1 skey)))))))
(setq d (nth 1 date)
month (car date)
y (nth 2 date)
dow 1
key 'quarter)))
((string-match
"\\`\\([0-9]+\\)-\\([0-9]\\{1,2\\}\\)-\\([0-9]\\{1,2\\}\\)\\'"
skey)
(setq y (string-to-number (match-string 1 skey))
month (string-to-number (match-string 2 skey))
d (string-to-number (match-string 3 skey))
key 'day))
((string-match "\\([-+][0-9]+\\)\\'" skey)
(setq shift (string-to-number (match-string 1 skey))
key (intern (substring skey 0 (match-beginning 1))))
(when (and (memq key '(quarter thisq)) (> shift 0))
(error "Looking forward with quarters isn't implemented"))))
(when (= shift 0)
(pcase key
(`yesterday (setq key 'today shift -1))
(`lastweek (setq key 'week shift -1))
(`lastmonth (setq key 'month shift -1))
(`lastyear (setq key 'year shift -1))
(`lastq (setq key 'quarter shift -1))))
;; Prepare start and end times depending on KEY's type.
(pcase key
((or `day `today) (setq m 0
h org-extend-today-until
h1 (+ 24 org-extend-today-until)
d (+ d shift)))
((or `week `thisweek)
(let* ((ws (or wstart 1))
(diff (+ (* -7 shift) (mod (+ dow 7 (- ws)) 7))))
(setq m 0 h org-extend-today-until d (- d diff) d1 (+ 7 d))))
((or `month `thismonth)
(setq h org-extend-today-until m 0 d (or mstart 1)
month (+ month shift) month1 (1+ month)))
((or `quarter `thisq)
;; Compute if this shift remains in this year. If not, compute
;; how many years and quarters we have to shift (via floor*) and
;; compute the shifted years, months and quarters.
(cond
((< (+ (- q 1) shift) 0) ; Shift not in this year.
(let* ((interval (* -1 (+ (- q 1) shift)))
;; Set tmp to ((years to shift) (quarters to shift)).
(tmp (cl-floor interval 4)))
;; Due to the use of floor, 0 quarters actually means 4.
(if (= 0 (nth 1 tmp))
(setq shiftedy (- y (nth 0 tmp))
shiftedm 1
shiftedq 1)
(setq shiftedy (- y (+ 1 (nth 0 tmp)))
shiftedm (- 13 (* 3 (nth 1 tmp)))
shiftedq (- 5 (nth 1 tmp)))))
(setq m 0 h org-extend-today-until d 1
month shiftedm month1 (+ 3 shiftedm) y shiftedy))
((> (+ q shift) 0) ; Shift is within this year.
(setq shiftedq (+ q shift))
(setq shiftedy y)
(let ((qshift (* 3 (1- (+ q shift)))))
(setq m 0 h org-extend-today-until d 1
month (+ 1 qshift) month1 (+ 4 qshift))))))
((or `year `thisyear)
(setq m 0 h org-extend-today-until d 1 month 1 y (+ y shift) y1 (1+ y)))
((or `interactive `untilnow)) ; Special cases, ignore them.
(_ (user-error "No such time block %s" key)))
;; Format start and end times according to AS-STRINGS.
(let* ((start (pcase key
(`interactive (org-read-date nil t nil "Range start? "))
(`untilnow nil)
(_ (org-encode-time 0 m h d month y))))
(end (pcase key
(`interactive (org-read-date nil t nil "Range end? "))
(`untilnow (current-time))
(_ (org-encode-time 0
m ;; (or m1 m)
(or h1 h)
(or d1 d)
(or month1 month)
(or y1 y)))))
(text
(pcase key
((or `day `today) (format-time-string "%A, %B %d, %Y" start))
((or `week `thisweek) (format-time-string "week %G-W%V" start))
((or `month `thismonth) (format-time-string "%B %Y" start))
((or `year `thisyear) (format-time-string "the year %Y" start))
((or `quarter `thisq)
(concat (org-count-quarter shiftedq)
" quarter of " (number-to-string shiftedy)))
(`interactive "(Range interactively set)")
(`untilnow "now"))))
(if (not as-strings) (list start end text)
(let ((f (org-time-stamp-format 'with-time)))
(list (and start (format-time-string f start))
(format-time-string f end)
text))))))
(defun org-count-quarter (n)
(cond
((= n 1) "1st")
((= n 2) "2nd")
((= n 3) "3rd")
((= n 4) "4th")))
;;;###autoload
(defun org-clocktable-shift (dir n)
"Try to shift the :block date of the clocktable at point.
Point must be in the #+BEGIN: line of a clocktable, or this function
will throw an error.
DIR is a direction, a symbol `left', `right', `up', or `down'.
Both `left' and `down' shift the block toward the past, `up' and `right'
push it toward the future.
N is the number of shift steps to take. The size of the step depends on
the currently selected interval size."
(setq n (prefix-numeric-value n))
(and (memq dir '(left down)) (setq n (- n)))
(save-excursion
(goto-char (line-beginning-position))
(if (not (looking-at "^[ \t]*#\\+BEGIN:[ \t]+clocktable\\>.*?:block[ \t]+\\(\\S-+\\)"))
(user-error "Line needs a :block definition before this command works")
(let* ((b (match-beginning 1)) (e (match-end 1))
(s (match-string 1))
block shift ins y mw d date wp) ;; m
(cond
((equal s "yesterday") (setq s "today-1"))
((equal s "lastweek") (setq s "thisweek-1"))
((equal s "lastmonth") (setq s "thismonth-1"))
((equal s "lastyear") (setq s "thisyear-1"))
((equal s "lastq") (setq s "thisq-1")))
(cond
((string-match "^\\(today\\|thisweek\\|thismonth\\|thisyear\\|thisq\\)\\([-+][0-9]+\\)?$" s)
(setq block (match-string 1 s)
shift (if (match-end 2)
(string-to-number (match-string 2 s))
0))
(setq shift (+ shift n))
(setq ins (if (= shift 0) block (format "%s%+d" block shift))))
((string-match "\\([0-9]+\\)\\(-\\([wWqQ]?\\)\\([0-9]\\{1,2\\}\\)\\(-\\([0-9]\\{1,2\\}\\)\\)?\\)?" s)
;; 1 1 2 3 3 4 4 5 6 6 5 2
(setq y (string-to-number (match-string 1 s))
wp (and (match-end 3) (match-string 3 s))
mw (and (match-end 4) (string-to-number (match-string 4 s)))
d (and (match-end 6) (string-to-number (match-string 6 s))))
(cond
(d (setq ins (format-time-string
"%Y-%m-%d"
(org-encode-time 0 0 0 (+ d n) nil y)))) ;; m
((and wp (string-match "w\\|W" wp) mw (> (length wp) 0))
(require 'cal-iso)
(setq date (calendar-gregorian-from-absolute
(calendar-iso-to-absolute (list (+ mw n) 1 y))))
(setq ins (format-time-string
"%G-W%V"
(org-encode-time 0 0 0 (nth 1 date) (car date) (nth 2 date)))))
((and wp (string-match "q\\|Q" wp) mw (> (length wp) 0))
(require 'cal-iso)
; if the 4th + 1 quarter is requested we flip to the 1st quarter of the next year
(if (> (+ mw n) 4)
(setq mw 0
y (+ 1 y))
())
; if the 1st - 1 quarter is requested we flip to the 4th quarter of the previous year
(if (= (+ mw n) 0)
(setq mw 5
y (- y 1))
())
(setq date (calendar-gregorian-from-absolute
(calendar-iso-to-absolute (org-quarter-to-date (+ mw n) y))))
(setq ins (format-time-string
(concat (number-to-string y) "-Q" (number-to-string (+ mw n)))
(org-encode-time 0 0 0 (nth 1 date) (car date) (nth 2 date)))))
(mw
(setq ins (format-time-string
"%Y-%m"
(org-encode-time 0 0 0 1 (+ mw n) y))))
(y
(setq ins (number-to-string (+ y n))))))
(t (user-error "Cannot shift clocktable block")))
(when ins
(goto-char b)
(insert ins)
(delete-region (point) (+ (point) (- e b)))
(forward-line 0)
(org-update-dblock)
t)))))
;;;###autoload
(defun org-dblock-write:clocktable (params)
"Write the standard clocktable."
(setq params (org-combine-plists org-clocktable-defaults params))
(catch 'exit
(let* ((scope (plist-get params :scope))
(base-buffer (org-base-buffer (current-buffer)))
(files (pcase scope
(`agenda
(org-agenda-files t))
(`agenda-with-archives
(org-add-archive-files (org-agenda-files t)))
(`file-with-archives
(let ((base-file (buffer-file-name base-buffer)))
(and base-file
(org-add-archive-files (list base-file)))))
((or `nil `file `subtree `tree
(and (pred symbolp)
(guard (string-match "\\`tree\\([0-9]+\\)\\'"
(symbol-name scope)))))
base-buffer)
((pred functionp) (funcall scope))
((pred consp) scope)
(_ (user-error "Unknown scope: %S" scope))))
(block (plist-get params :block))
(ts (plist-get params :tstart))
(te (plist-get params :tend))
(ws (plist-get params :wstart))
(ms (plist-get params :mstart))
(step (plist-get params :step))
(hide-files (plist-get params :hidefiles))
(formatter (or (plist-get params :formatter)
org-clock-clocktable-formatter
'org-clocktable-write-default))
cc)
;; Check if we need to do steps
(when block
;; Get the range text for the header
(setq cc (org-clock-special-range block nil t ws ms)
ts (car cc)
te (nth 1 cc)))
(when step
;; Write many tables, in steps
(unless (or block (and ts te))
(user-error "Clocktable `:step' can only be used with `:block' or `:tstart', `:tend'"))
(org-clocktable-steps params)
(throw 'exit nil))
(org-agenda-prepare-buffers (if (consp files) files (list files)))
(let ((origin (point))
(tables
(if (consp files)
(mapcar (lambda (file)
(with-current-buffer (find-buffer-visiting file)
(save-excursion
(save-restriction
(org-clock-get-table-data file params)))))
files)
;; Get the right restriction for the scope.
(save-restriction
(cond
((not scope)) ;use the restriction as it is now
((eq scope 'file) (widen))
((eq scope 'subtree) (org-narrow-to-subtree))
((eq scope 'tree)
(while (org-up-heading-safe))
(org-narrow-to-subtree))
((and (symbolp scope)
(string-match "\\`tree\\([0-9]+\\)\\'"
(symbol-name scope)))
(let ((level (string-to-number
(match-string 1 (symbol-name scope)))))
(catch 'exit
(while (org-up-heading-safe)
(looking-at org-outline-regexp)
(when (<= (org-reduced-level (funcall outline-level))
level)
(throw 'exit nil))))
(org-narrow-to-subtree))))
(list (org-clock-get-table-data nil params)))))
(multifile
;; Even though `file-with-archives' can consist of
;; multiple files, we consider this is one extended file
;; instead.
(and (not hide-files)
(consp files)
(not (eq scope 'file-with-archives)))))
(funcall formatter
origin
tables
(org-combine-plists params `(:multifile ,multifile)))))))
(defun org-clocktable-write-default (ipos tables params)
"Write out a clock table at position IPOS in the current buffer.
TABLES is a list of tables with clocking data as produced by
`org-clock-get-table-data'. PARAMS is the parameter property list obtained
from the dynamic block definition."
;; This function looks quite complicated, mainly because there are a
;; lot of options which can add or remove columns. I have massively
;; commented this function, the I hope it is understandable. If
;; someone wants to write their own special formatter, this maybe
;; much easier because there can be a fixed format with a
;; well-defined number of columns...
(let* ((lang (or (plist-get params :lang) "en"))
(multifile (plist-get params :multifile))
(block (plist-get params :block))
(sort (plist-get params :sort))
(header (plist-get params :header))
(link (plist-get params :link))
(maxlevel (or (plist-get params :maxlevel) 3))
(emph (plist-get params :emphasize))
(compact? (plist-get params :compact))
(narrow (or (plist-get params :narrow) (and compact? '40!)))
(filetitle (plist-get params :filetitle))
(level? (and (not compact?) (plist-get params :level)))
(timestamp (plist-get params :timestamp))
(tags (plist-get params :tags))
(properties (plist-get params :properties))
(time-columns
(if (or compact? (< maxlevel 2)) 1
;; Deepest headline level is a hard limit for the number
;; of time columns.
(let ((levels
(cl-mapcan
(lambda (table)
(pcase table
(`(,_ ,(and (pred wholenump) (pred (/= 0))) ,entries)
(mapcar #'car entries))))
tables)))
(min maxlevel
(or (plist-get params :tcolumns) 100)
(if (null levels) 1 (apply #'max levels))))))
(indent (or compact? (plist-get params :indent)))
(formula (plist-get params :formula))
(case-fold-search t)
(total-time (apply #'+ (mapcar #'cadr tables)))
recalc narrow-cut-p)
(when (and narrow (integerp narrow) link)
;; We cannot have both integer narrow and link.
(message "Using hard narrowing in clocktable to allow for links")
(setq narrow (intern (format "%d!" narrow))))
(pcase narrow
((or `nil (pred integerp)) nil) ;nothing to do
((and (pred symbolp)
(guard (string-match-p "\\`[0-9]+!\\'" (symbol-name narrow))))
(setq narrow-cut-p t)
(setq narrow (string-to-number (symbol-name narrow))))
(_ (user-error "Invalid value %s of :narrow property in clock table" narrow)))
;; Now we need to output this table stuff.
(goto-char ipos)
;; Insert the text *before* the actual table.
(insert-before-markers
(or header
;; Format the standard header.
(format "#+CAPTION: %s %s%s\n"
(org-clock--translate "Clock summary at" lang)
(format-time-string (org-time-stamp-format t t))
(if block
(let ((range-text
(nth 2 (org-clock-special-range
block nil t
(plist-get params :wstart)
(plist-get params :mstart)))))
(format ", for %s." range-text))
""))))
;; Insert the narrowing line
(when (and narrow (integerp narrow) (not narrow-cut-p))
(insert-before-markers
"|" ;table line starter
(if multifile "|" "") ;file column, maybe
(if level? "|" "") ;level column, maybe
(if timestamp "|" "") ;timestamp column, maybe
(if tags "|" "") ;tags columns, maybe
(if properties ;properties columns, maybe
(make-string (length properties) ?|)
"")
(format "<%d>| |\n" narrow))) ;headline and time columns
;; Insert the table header line
(insert-before-markers
"|" ;table line starter
(if multifile ;file column, maybe
(concat (org-clock--translate "File" lang) "|")
"")
(if level? ;level column, maybe
(concat (org-clock--translate "L" lang) "|")
"")
(if timestamp ;timestamp column, maybe
(concat (org-clock--translate "Timestamp" lang) "|")
"")
(if tags "Tags |" "") ;tags columns, maybe
(if properties ;properties columns, maybe
(concat (mapconcat #'identity properties "|") "|")
"")
(concat (org-clock--translate "Headline" lang)"|")
(concat (org-clock--translate "Time" lang) "|")
(make-string (max 0 (1- time-columns)) ?|) ;other time columns
(if (eq formula '%) "%|\n" "\n"))
;; Insert the total time in the table
(insert-before-markers
"|-\n" ;a hline
"|" ;table line starter
(if multifile (format "| %s " (org-clock--translate "ALL" lang)) "")
;file column, maybe
(if level? "|" "") ;level column, maybe
(if timestamp "|" "") ;timestamp column, maybe
(if tags "|" "") ;timestamp column, maybe
(make-string (length properties) ?|) ;properties columns, maybe
(concat (format org-clock-total-time-cell-format
(org-clock--translate "Total time" lang))
"| ")
(format org-clock-total-time-cell-format
(org-duration-from-minutes (or total-time 0))) ;time
"|"
(make-string (max 0 (1- time-columns)) ?|)
(cond ((not (eq formula '%)) "")
((or (not total-time) (= total-time 0)) "0.0|")
(t "100.0|"))
"\n")
;; Now iterate over the tables and insert the data but only if any
;; time has been collected.
(when (and total-time (> total-time 0))
(pcase-dolist (`(,file-name ,file-time ,entries) tables)
(when (or (and file-time (> file-time 0))
(not (plist-get params :fileskip0)))
(insert-before-markers "|-\n") ;hline at new file
;; First the file time, if we have multiple files.
(when multifile
;; Summarize the time collected from this file.
(insert-before-markers
(format (concat "| %s %s | %s%s%s"
(format org-clock-file-time-cell-format
(org-clock--translate "File time" lang))
;; The file-time rollup value goes in the first time
;; column (of which there is always at least one)...
" | *%s*|"
;; ...and the remaining file time cols (if any) are blank.
(make-string (max 0 (1- time-columns)) ?|)
;; Optionally show the percentage contribution of "this"
;; file time to the total time.
(if (eq formula '%) " %s |" "")
"\n")
(if filetitle
(or (org-get-title file-name)
(file-name-nondirectory file-name))
(file-name-nondirectory file-name))
(if level? "| " "") ;level column, maybe
(if timestamp "| " "") ;timestamp column, maybe
(if tags "| " "") ;tags column, maybe
(if properties ;properties columns, maybe
(make-string (length properties) ?|)
"")
(org-duration-from-minutes file-time) ;time
(cond ((not (eq formula '%)) "") ;time percentage, maybe
((or (not total-time) (= total-time 0)) "0.0")
(t
(format "%.1f" (* 100 (/ file-time (float total-time)))))))))
;; Get the list of node entries and iterate over it
(when (> maxlevel 0)
(pcase-dolist (`(,level ,headline ,tgs ,ts ,time ,props) entries)
(when narrow-cut-p
(setq headline
(if (and (string-match
(format "\\`%s\\'" org-link-bracket-re)
headline)
(match-end 2))
(format "[[%s][%s]]"
(match-string 1 headline)
(org-shorten-string (match-string 2 headline)
narrow))
(org-shorten-string headline narrow))))
(cl-flet ((format-field (f) (format (cond ((not emph) "%s |")
((= level 1) "*%s* |")
((= level 2) "/%s/ |")
(t "%s |"))
f)))
(insert-before-markers
"|" ;start the table line
(if multifile "|" "") ;free space for file name column?
(if level? (format "%d|" level) "") ;level, maybe
(if timestamp (concat ts "|") "") ;timestamp, maybe
(if tags (concat (mapconcat #'identity tgs ", ") "|") "") ;tags, maybe
(if properties ;properties columns, maybe
(concat (mapconcat (lambda (p) (or (cdr (assoc p props)) ""))
properties
"|")
"|")
"")
(if indent ;indentation
(org-clocktable-indent-string level)
"")
(format-field headline)
;; Empty fields for higher levels.
(make-string (max 0 (1- (min time-columns level))) ?|)
(format-field (org-duration-from-minutes time))
(make-string (max 0 (- time-columns level)) ?|)
(if (eq formula '%)
(format "%.1f |" (* 100 (/ time (float total-time))))
"")
"\n")))))))
(delete-char -1)
(cond
;; Possibly rescue old formula?
((or (not formula) (eq formula '%))
(let ((contents (org-string-nw-p (plist-get params :content))))
(when (and contents (string-match "^\\([ \t]*#\\+tblfm:.*\\)" contents))
(setq recalc t)
(insert "\n" (match-string 1 contents))
(forward-line -1))))
;; Insert specified formula line.
((stringp formula)
(insert "\n#+TBLFM: " formula)
(setq recalc t))
(t
(user-error "Invalid :formula parameter in clocktable")))
;; Back to beginning, align the table, recalculate if necessary.
(goto-char ipos)
(skip-chars-forward "^|")
(org-table-align)
(when org-hide-emphasis-markers
;; We need to align a second time.
(org-table-align))
(when sort
(save-excursion
(org-table-goto-line 3)
(org-table-goto-column (car sort))
(org-table-sort-lines nil (cdr sort))))
(when recalc (org-table-recalculate 'all))
total-time))
(defun org-clocktable-indent-string (level)
"Return indentation string according to LEVEL.
LEVEL is an integer. Indent by two spaces per level above 1."
(if (= level 1) ""
(concat "\\_" (make-string (* 2 (1- level)) ?\s))))
(defun org-clocktable-steps (params)
"Create one or more clock tables, according to PARAMS.
Step through the range specifications in plist PARAMS to make
a number of clock tables."
(let* ((ignore-empty-tables (plist-get params :stepskip0))
(step (plist-get params :step))
(step-header
(pcase step
(`day "Daily report: ")
(`week "Weekly report starting on: ")
(`semimonth "Semimonthly report starting on: ")
(`month "Monthly report starting on: ")
(`year "Annual report starting on: ")
(`quarter "Quarterly report starting on: ")
(_ (user-error "Unknown `:step' specification: %S" step))))
(week-start (or (plist-get params :wstart) 1))
(month-start (or (plist-get params :mstart) 1))
(range
(pcase (plist-get params :block)
(`nil nil)
(range
(org-clock-special-range range nil t week-start month-start))))
;; For both START and END, any number is an absolute day
;; number from Agenda. Otherwise, consider value to be an Org
;; timestamp string. The `:block' property has precedence
;; over `:tstart' and `:tend'.
(start
(pcase (if range (car range) (plist-get params :tstart))
((and (pred numberp) n)
(pcase-let ((`(,m ,d ,y) (calendar-gregorian-from-absolute n)))
(org-encode-time 0 0 org-extend-today-until d m y)))
(timestamp
(seconds-to-time
(org-matcher-time (or timestamp
;; The year Org was born.
"<2003-01-01 Thu 00:00>"))))))
(end
(pcase (if range (nth 1 range) (plist-get params :tend))
((and (pred numberp) n)
(pcase-let ((`(,m ,d ,y) (calendar-gregorian-from-absolute n)))
(org-encode-time 0 0 org-extend-today-until d m y)))
(timestamp (seconds-to-time (org-matcher-time timestamp))))))
(while (time-less-p start end)
(unless (bolp) (insert "\n"))
;; Insert header before each clock table.
(insert "\n"
step-header
(format-time-string (org-time-stamp-format nil t) start)
"\n")
;; Compute NEXT, which is the end of the current clock table,
;; according to step.
(let* ((next
;; In Emacs-27 and Emacs-28 `encode-time' does not support 6 elements
;; list argument so `org-encode-time' can not be outside of `pcase'.
(pcase-let
((`(,_ ,_ ,_ ,d ,m ,y ,dow . ,_) (decode-time start)))
(pcase step
(`day (org-encode-time 0 0 org-extend-today-until (1+ d) m y))
(`week
(let ((offset (if (= dow week-start) 7
(mod (- week-start dow) 7))))
(org-encode-time 0 0 org-extend-today-until (+ d offset) m y)))
(`semimonth (org-encode-time 0 0 0
(if (< d 16) 16 1)
(if (< d 16) m (1+ m)) y))
(`month (org-encode-time 0 0 0 month-start (1+ m) y))
(`quarter (org-encode-time 0 0 0 month-start (+ 3 m) y))
(`year (org-encode-time 0 0 org-extend-today-until 1 1 (1+ y))))))
(table-begin (line-beginning-position 0))
(step-time
;; Write clock table between START and NEXT.
(org-dblock-write:clocktable
(org-combine-plists
params (list :header ""
:step nil
:block nil
:tstart (format-time-string
(org-time-stamp-format t t)
start)
:tend (format-time-string
(org-time-stamp-format t t)
;; Never include clocks past END.
(if (time-less-p end next) end next)))))))
(let ((case-fold-search t)) (re-search-forward "^[ \t]*#\\+END:"))
;; Remove the table if it is empty and `:stepskip0' is
;; non-nil.
(when (and ignore-empty-tables (equal step-time 0))
(delete-region (line-beginning-position) table-begin))
(setq start next))
(end-of-line 0))))
(defun org-clock-get-table-data (file params)
"Get the clocktable data for file FILE, with parameters PARAMS.
FILE is only for identification - this function assumes that
the correct buffer is current, and that the wanted restriction is
in place.
The return value will be a list with the file name and the total
file time (in minutes) as 1st and 2nd elements. The third element
of this list will be a list of headline entries. Each entry has the
following structure:
(LEVEL HEADLINE TAGS TIMESTAMP TIME PROPERTIES)
LEVEL: The level of the headline, as an integer. This will be
the reduced level, so 1,2,3,... even if only odd levels
are being used.
HEADLINE: The text of the headline. Depending on PARAMS, this may
already be formatted like a link.
TAGS: The list of tags of the headline.
TIMESTAMP: If PARAMS require it, this will be a time stamp found in the
entry, any of SCHEDULED, DEADLINE, NORMAL, or first inactive,
in this sequence.
TIME: The sum of all time spend in this tree, in minutes. This time
will of cause be restricted to the time block and tags match
specified in PARAMS.
PROPERTIES: The list properties specified in the `:properties' parameter
along with their value, as an alist following the pattern
(NAME . VALUE)."
(let* ((maxlevel (or (plist-get params :maxlevel) 3))
(timestamp (plist-get params :timestamp))
(ts (plist-get params :tstart))
(te (plist-get params :tend))
(ws (plist-get params :wstart))
(ms (plist-get params :mstart))
(block (plist-get params :block))
(link (plist-get params :link))
(tags (plist-get params :tags))
(match (plist-get params :match))
(properties (plist-get params :properties))
(inherit-property-p (plist-get params :inherit-props))
(matcher (and match (cdr (org-make-tags-matcher match))))
cc st p tbl)
(setq org-clock-file-total-minutes nil)
(when block
(setq cc (org-clock-special-range block nil t ws ms)
ts (car cc)
te (nth 1 cc)))
(when (integerp ts) (setq ts (calendar-gregorian-from-absolute ts)))
(when (integerp te) (setq te (calendar-gregorian-from-absolute te)))
(when (and ts (listp ts))
(setq ts (format "%4d-%02d-%02d" (nth 2 ts) (car ts) (nth 1 ts))))
(when (and te (listp te))
(setq te (format "%4d-%02d-%02d" (nth 2 te) (car te) (nth 1 te))))
;; Now the times are strings we can parse.
(if ts (setq ts (org-matcher-time ts)))
(if te (setq te (org-matcher-time te)))
(save-excursion
(org-clock-sum ts te
(when matcher
(lambda ()
(let* ((todo (org-get-todo-state))
(tags-list (org-get-tags))
(org-scanner-tags tags-list)
(org-trust-scanner-tags t)
(level (org-current-level)))
(funcall matcher todo tags-list level)))))
(goto-char (point-min))
(setq st t)
(while (or (and (bobp) (prog1 st (setq st nil))
(get-text-property (point) :org-clock-minutes)
(setq p (point-min)))
(setq p (next-single-property-change
(point) :org-clock-minutes)))
(goto-char p)
(let ((time (get-text-property p :org-clock-minutes)))
(when (and time (> time 0) (org-at-heading-p))
(let ((level (org-reduced-level (org-current-level))))
(when (<= level maxlevel)
(let* ((headline (org-get-heading t t t t))
(hdl
(if (not link) headline
(let ((search
(org-link-heading-search-string headline)))
(org-link-make-string
(if (not (buffer-file-name)) search
(format "file:%s::%s" (buffer-file-name) search))
;; Prune statistics cookies. Replace
;; links with their description, or
;; a plain link if there is none.
(org-trim
(org-link-display-format
(replace-regexp-in-string
"\\[[0-9]*\\(?:%\\|/[0-9]*\\)\\]" ""
headline)))))))
(tgs (and tags (org-get-tags)))
(tsp
(and timestamp
(cl-some (lambda (p) (org-entry-get (point) p))
'("SCHEDULED" "DEADLINE" "TIMESTAMP"
"TIMESTAMP_IA"))))
(props
(and properties
(delq nil
(mapcar
(lambda (p)
(let ((v (org-entry-get
(point) p inherit-property-p)))
(and v (cons p v))))
properties)))))
(push (list level hdl tgs tsp time props) tbl)))))))
(list file org-clock-file-total-minutes (nreverse tbl)))))
;; Saving and loading the clock
(defvar org-clock-loaded nil
"Was the clock file loaded?")
;;;###autoload
(defun org-clock-update-time-maybe ()
"If this is a CLOCK line, update it and return t.
Otherwise, return nil."
(interactive)
(let ((origin (point))) ;; `save-excursion' may not work when deleting.
(prog1
(save-excursion
(forward-line 0)
(skip-chars-forward " \t")
(when (looking-at org-clock-string)
(let ((re (concat "[ \t]*" org-clock-string
" *[[<]\\([^]>]+\\)[]>]\\(-+[[<]\\([^]>]+\\)[]>]"
"\\([ \t]*=>.*\\)?\\)?"))
ts te h m s neg)
(cond
((not (looking-at re))
nil)
((not (match-end 2))
(when (and (equal (marker-buffer org-clock-marker) (current-buffer))
(> org-clock-marker (point))
(<= org-clock-marker (line-end-position)))
;; The clock is running here
(setq org-clock-start-time
(org-time-string-to-time (match-string 1)))
(org-clock-update-mode-line)))
(t
;; Prevent recursive call from `org-timestamp-change'.
(cl-letf (((symbol-function 'org-clock-update-time-maybe) #'ignore))
;; Update timestamps.
(save-excursion
(goto-char (match-beginning 1)) ; opening timestamp
(save-match-data (org-timestamp-change 0 'day)))
;; Refresh match data.
(looking-at re)
(save-excursion
(goto-char (match-beginning 3)) ; closing timestamp
(save-match-data (org-timestamp-change 0 'day))))
;; Refresh match data.
(looking-at re)
(and (match-end 4) (delete-region (match-beginning 4) (match-end 4)))
(end-of-line 1)
(setq ts (match-string 1)
te (match-string 3))
(setq s (- (org-time-string-to-seconds te)
(org-time-string-to-seconds ts))
neg (< s 0)
s (abs s)
h (floor (/ s 3600))
s (- s (* 3600 h))
m (floor (/ s 60))
s (- s (* 60 s)))
(insert " => " (format (if neg "-%d:%02d" "%2d:%02d") h m))
t)))))
;; Move back to initial position, but never beyond updated
;; clock.
(unless (< (point) origin)
(goto-char origin)))))
(defun org-clock-save ()
"Persist various clock-related data to disk.
The details of what will be saved are regulated by the variable
`org-clock-persist'."
(when (and org-clock-persist
(or org-clock-loaded
org-clock-has-been-used
(not (file-exists-p org-clock-persist-file))))
(with-temp-file org-clock-persist-file
(insert (format ";; %s - %s at %s -*- lexical-binding: t; -*-\n"
(file-name-nondirectory org-clock-persist-file)
(system-name)
(format-time-string (org-time-stamp-format t))))
;; Store clock to be resumed.
(when (and (memq org-clock-persist '(t clock))
(let ((b (org-base-buffer (org-clocking-buffer))))
(and (buffer-live-p b)
(buffer-file-name b)
(or (not org-clock-persist-query-save)
(y-or-n-p (format "Save current clock (%s)?"
org-clock-heading))))))
(insert
(format "(setq org-clock-stored-resume-clock '(%S . %d))\n"
(buffer-file-name (org-base-buffer (org-clocking-buffer)))
(marker-position org-clock-marker))))
;; Store clocked task history. Tasks are stored reversed to
;; make reading simpler.
(when (and (memq org-clock-persist '(t history))
org-clock-history)
(insert
(format "(setq org-clock-stored-history '(%s))\n"
(mapconcat
(lambda (m)
(let ((b (org-base-buffer (marker-buffer m))))
(when (and (buffer-live-p b)
(buffer-file-name b))
(format "(%S . %d)"
(buffer-file-name b)
(marker-position m)))))
(reverse org-clock-history)
" ")))))))
(defun org-clock-load ()
"Load clock-related data from disk, maybe resuming a stored clock."
(when (and org-clock-persist (not org-clock-loaded))
(if (not (file-readable-p org-clock-persist-file))
(message "Not restoring clock data; %S not found" org-clock-persist-file)
(message "Restoring clock data")
;; Load history.
(load-file org-clock-persist-file)
(setq org-clock-loaded t)
(pcase-dolist (`(,(and file (pred file-exists-p)) . ,position)
org-clock-stored-history)
(org-clock-history-push position (find-file-noselect file)))
;; Resume clock.
(pcase org-clock-stored-resume-clock
(`(,(and file (pred file-exists-p)) . ,position)
(with-current-buffer (find-file-noselect file)
(when (or (not org-clock-persist-query-resume)
(y-or-n-p (format "Resume clock (%s)?"
(save-excursion
(goto-char position)
(org-get-heading t t)))))
(goto-char position)
(let ((org-clock-in-resume 'auto-restart)
(org-clock-auto-clock-resolution nil))
(org-clock-in)
(when (org-invisible-p) (org-fold-show-context))))))
(_ nil)))))
(defun org-clock-kill-emacs-query ()
"Query user when killing Emacs.
This function is added to `kill-emacs-query-functions'."
(let ((buf (org-clocking-buffer)))
(when (and buf (yes-or-no-p "Clock out and save? "))
(with-current-buffer buf
(org-clock-out)
(save-buffer))))
;; Unconditionally return t for `kill-emacs-query-functions'.
t)
;; Suggested bindings
(org-defkey org-mode-map "\C-c\C-x\C-e" 'org-clock-modify-effort-estimate)
(provide 'org-clock)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; coding: utf-8
;; End:
;;; org-clock.el ends here
org-mode-9.7.29+dfsg/lisp/org-colview.el 0000664 0000000 0000000 00000215305 15004304337 0020005 0 ustar 00root root 0000000 0000000 ;;; org-colview.el --- Column View in Org -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2025 Free Software Foundation, Inc.
;; Author: Carsten Dominik
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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 `\\[org-columns-edit-value]' \
to edit property")))))))))
(defun org-columns--truncate-below-width (string width)
"Return a substring of STRING no wider than WIDTH.
This substring must start at 0, and must be the longest possible
substring whose `string-width' does not exceed WIDTH."
(declare (side-effect-free t))
(let ((end (min width (length string))) res)
(while (and end (>= end 0))
(let* ((curr (string-width (substring string 0 end)))
(excess (- curr width)))
(if (> excess 0)
(cl-decf end (max 1 (/ excess 2)))
(setq res (substring string 0 end) end nil))))
res))
(defun org-columns-add-ellipses (string width)
"Truncate STRING with WIDTH characters, with ellipses."
(cond
((<= (string-width string) width) string)
((<= width (string-width org-columns-ellipses))
(org-columns--truncate-below-width org-columns-ellipses width))
(t (concat
(org-columns--truncate-below-width
string (- width (string-width org-columns-ellipses)))
org-columns-ellipses))))
(defvar org-columns-full-header-line-format nil
"The full header line format, will be shifted by horizontal scrolling." )
(defvar org-previous-header-line-format nil
"The header line format before column view was turned on.")
(defvar org-columns-inhibit-recalculation nil
"Inhibit recomputing of columns on column view startup.")
(defvar org-columns-flyspell-was-active nil
"Remember the state of `flyspell-mode' before column view.
Flyspell-mode can cause problems in columns view, so it is turned off
for the duration of the command.")
(defvar header-line-format)
(defvar org-columns-previous-hscroll 0)
(defun org-columns--display-here-title ()
"Overlay the newline before the current line with the table title."
(interactive)
(let ((title "")
(linum-offset (org-line-number-display-width 'columns))
(i 0))
(dolist (column org-columns-current-fmt-compiled)
(pcase column
(`(,property ,name . ,_)
(let* ((width (aref org-columns-current-maxwidths i))
(fmt (format "%%-%d.%ds | " width width)))
(setq title (concat title (format fmt (or name property)))))))
(cl-incf i))
(setq-local org-previous-header-line-format header-line-format)
(setq org-columns-full-header-line-format
(concat
(org-add-props " " nil 'display `(space :align-to ,linum-offset))
(org-add-props (substring title 0 -1) nil 'face 'org-column-title)))
(setq org-columns-previous-hscroll -1)
(add-hook 'post-command-hook #'org-columns-hscroll-title nil 'local)))
(defun org-columns-hscroll-title ()
"Set the `header-line-format' so that it scrolls along with the table."
(sit-for .0001) ; need to force a redisplay to update window-hscroll
(let ((hscroll (window-hscroll)))
(when (/= org-columns-previous-hscroll hscroll)
(setq header-line-format
(concat (substring org-columns-full-header-line-format 0 1)
(substring org-columns-full-header-line-format
(min (length org-columns-full-header-line-format)
(1+ hscroll))))
org-columns-previous-hscroll hscroll)
(force-mode-line-update))))
(defvar org-colview-initial-truncate-line-value nil
"Remember the value of `truncate-lines' across colview.")
;;;###autoload
(defun org-columns-remove-overlays ()
"Remove all currently active column overlays."
(interactive)
(when org-columns-header-line-remap
(face-remap-remove-relative org-columns-header-line-remap)
(setq org-columns-header-line-remap nil))
(when org-columns-overlays
(when (local-variable-p 'org-previous-header-line-format)
(setq header-line-format org-previous-header-line-format)
(kill-local-variable 'org-previous-header-line-format)
(remove-hook 'post-command-hook #'org-columns-hscroll-title 'local))
(when (markerp org-columns-begin-marker)
(set-marker org-columns-begin-marker nil))
(when (markerp org-columns-top-level-marker)
(set-marker org-columns-top-level-marker nil))
(with-silent-modifications
(mapc #'delete-overlay org-columns-overlays)
(setq org-columns-overlays nil)
(let ((inhibit-read-only t))
(remove-text-properties (point-min) (point-max) '(read-only t))))
(when org-columns-flyspell-was-active
(flyspell-mode 1))
(when (local-variable-p 'org-colview-initial-truncate-line-value)
(setq truncate-lines org-colview-initial-truncate-line-value))))
(defun org-columns-show-value ()
"Show the full value of the property."
(interactive)
(let ((value (get-char-property (point) 'org-columns-value)))
(message "Value is: %s" (or value ""))))
(defvar org-agenda-columns-active) ;; defined in org-agenda.el
(defun org-columns-quit ()
"Remove the column overlays and in this way exit column editing."
(interactive)
(with-silent-modifications
(org-columns-remove-overlays)
(let ((inhibit-read-only t))
(remove-text-properties (point-min) (point-max) '(read-only t))))
(if (not (eq major-mode 'org-agenda-mode))
(setq org-columns-current-fmt nil)
(setq org-agenda-columns-active nil)
(message
"Modification not yet reflected in Agenda buffer, use `r' to refresh")))
(defun org-columns-check-computed ()
"Throw an error if current column value is computed."
(let ((spec (nth (org-current-text-column) org-columns-current-fmt-compiled)))
(and
(nth 3 spec)
(assoc spec (get-text-property (line-beginning-position) 'org-summaries))
(error "This value is computed from the entry's children"))))
(defun org-columns-todo (&optional _arg)
"Change the TODO state during column view."
(interactive "P")
(org-columns-edit-value "TODO"))
(defun org-columns-toggle-or-columns-quit ()
"Toggle checkbox at point, or quit column view."
(interactive)
(or (org-columns--toggle)
(org-columns-quit)))
(defun org-columns--toggle ()
"Toggle checkbox at point. Return non-nil if toggle happened, else nil.
See info documentation about realizing a suitable checkbox."
(when (string-match "\\`\\[[ xX-]\\]\\'"
(get-char-property (point) 'org-columns-value))
(org-columns-next-allowed-value)
t))
(defvar org-overriding-columns-format nil
"When set, overrides any other format definition for the agenda.
Don't set this, this is meant for dynamic scoping. Set
`org-columns-default-format' and `org-columns-default-format-for-agenda'
instead. You should use this variable only in the local settings
section for a custom agenda view.")
(defvar-local org-local-columns-format nil
"When set, overrides any other format definition for the agenda.
This can be set as a buffer local value to avoid interfering with
dynamic scoping for `org-overriding-columns-format'.")
(defun org-columns-edit-value (&optional key)
"Edit the value of the property at point in column view.
Where possible, use the standard interface for changing this line."
(interactive)
(org-columns-check-computed)
(let* ((col (current-column))
(bol (line-beginning-position))
(eol (line-end-position))
(pom (or (get-text-property bol 'org-hd-marker) (point)))
(key (or key (get-char-property (point) 'org-columns-key)))
(org-columns--time (float-time))
(action
(pcase key
("CLOCKSUM"
(user-error "This special column cannot be edited"))
("ITEM"
(lambda () (org-with-point-at pom (org-edit-headline))))
("TODO"
(lambda ()
(org-with-point-at pom (call-interactively #'org-todo))))
("PRIORITY"
(lambda ()
(org-with-point-at pom
(call-interactively #'org-priority))))
("TAGS"
(lambda ()
(org-with-point-at pom
(let ((org-fast-tag-selection-single-key
(if (eq org-fast-tag-selection-single-key 'expert)
t
org-fast-tag-selection-single-key)))
(call-interactively #'org-set-tags-command)))))
("DEADLINE"
(lambda ()
(org-with-point-at pom (call-interactively #'org-deadline))))
("SCHEDULED"
(lambda ()
(org-with-point-at pom (call-interactively #'org-schedule))))
("BEAMER_ENV"
(lambda ()
(org-with-point-at pom
(call-interactively #'org-beamer-select-environment))))
(_
(let* ((allowed (org-property-get-allowed-values pom key 'table))
(value (get-char-property (point) 'org-columns-value))
(nval (org-trim
(if (null allowed) (read-string "Edit: " value)
(completing-read
"Value: " allowed nil
(not (get-text-property
0 'org-unrestricted (caar allowed))))))))
(and (not (equal nval value))
(lambda () (org-entry-put pom key nval))))))))
(cond
((null action))
((eq major-mode 'org-agenda-mode)
(org-columns--call action)
;; The following let preserves the current format, and makes
;; sure that in only a single file things need to be updated.
(let* ((org-overriding-columns-format org-columns-current-fmt)
(buffer (marker-buffer pom))
(org-agenda-contributing-files
(list (with-current-buffer buffer
(buffer-file-name (buffer-base-buffer))))))
(org-agenda-columns)))
(t
(let ((inhibit-read-only t))
(with-silent-modifications
(remove-text-properties (max (point-min) (1- bol)) eol '(read-only t)))
(org-columns--call action))
;; Some properties can modify headline (e.g., "TODO"), and
;; possible shuffle overlays. Make sure they are still all at
;; the right place on the current line.
(let ((org-columns-inhibit-recalculation)) (org-columns-redo))
(org-columns-update key)
(org-move-to-column col)))))
(defun org-columns-edit-allowed ()
"Edit the list of allowed values for the current property."
(interactive)
(let* ((pom (or (org-get-at-bol 'org-marker)
(org-get-at-bol 'org-hd-marker)
(point)))
(key (concat (or (get-char-property (point) 'org-columns-key)
(user-error "No column to edit at point"))
"_ALL"))
(allowed (org-entry-get pom key t))
(new-value (read-string "Allowed: " allowed)))
;; FIXME: Cover editing TODO, TAGS etc in-buffer settings.????
;; FIXME: Write back to #+PROPERTY setting if that is needed.
(org-entry-put
(cond ((marker-position org-entry-property-inherited-from)
org-entry-property-inherited-from)
((marker-position org-columns-top-level-marker)
org-columns-top-level-marker)
(t pom))
key new-value)))
(defun org-columns--call (fun)
"Call function FUN while preserving heading visibility.
FUN is a function called with no argument."
(let ((hide-body (and (/= (line-end-position) (point-max))
(save-excursion
(move-beginning-of-line 2)
(org-at-heading-p)))))
(unwind-protect (funcall fun)
(when hide-body (org-fold-hide-entry)))))
(defun org-columns-previous-allowed-value ()
"Switch to the previous allowed value for this column."
(interactive)
(org-columns-next-allowed-value t))
(defun org-columns-next-allowed-value (&optional previous nth)
"Switch to the next allowed value for this column.
When PREVIOUS is set, go to the previous value. When NTH is
an integer, select that value."
(interactive)
(org-columns-check-computed)
(let* ((column (org-current-text-column))
(visible-column (current-column))
(key (get-char-property (point) 'org-columns-key))
(value (get-char-property (point) 'org-columns-value))
(pom (or (get-text-property (line-beginning-position) 'org-hd-marker)
(point)))
(allowed
(let ((all
(or (org-property-get-allowed-values pom key)
(pcase (nth column org-columns-current-fmt-compiled)
(`(,_ ,_ ,_ ,(or "X" "X/" "X%") ,_) org-columns-checkbox-allowed-values))
(org-colview-construct-allowed-dates value))))
(if previous (reverse all) all))))
(when (equal key "ITEM") (error "Cannot edit item headline from here"))
(unless (or allowed (member key '("SCHEDULED" "DEADLINE" "CLOCKSUM")))
(error "Allowed values for this property have not been defined"))
(let* ((l (length allowed))
(new
(cond
((member key '("SCHEDULED" "DEADLINE" "CLOCKSUM"))
(if previous 'earlier 'later))
((integerp nth)
(when (> (abs nth) l)
(user-error "Only %d allowed values for property `%s'" l key))
(nth (mod (1- nth) l) allowed))
((member value allowed)
(when (= l 1) (error "Only one allowed value for this property"))
(or (nth 1 (member value allowed)) (car allowed)))
(t (car allowed))))
(action (lambda () (org-entry-put pom key new))))
(cond
((eq major-mode 'org-agenda-mode)
(org-columns--call action)
;; The following let preserves the current format, and makes
;; sure that in only a single file things need to be updated.
(let* ((org-overriding-columns-format org-columns-current-fmt)
(buffer (marker-buffer pom))
(org-agenda-contributing-files
(list (with-current-buffer buffer
(buffer-file-name (buffer-base-buffer))))))
(org-agenda-columns)))
(t
(let ((inhibit-read-only t))
(remove-text-properties (line-end-position 0) (line-end-position)
'(read-only t))
(org-columns--call action))
;; Some properties can modify headline (e.g., "TODO"), and
;; possible shuffle overlays. Make sure they are still all at
;; the right place on the current line.
(let ((org-columns-inhibit-recalculation)) (org-columns-redo))
(org-columns-update key)
(org-move-to-column visible-column))))))
(defun org-colview-construct-allowed-dates (s)
"Construct a list of three dates around the date in S.
This respects the format of the time stamp in S, active or non-active,
and also including time or not. S must be just a time stamp, no text
around it."
(when (and s (string-match (concat "^" org-ts-regexp3 "$") s))
(let* ((time (org-parse-time-string s 'nodefaults))
(active (equal (string-to-char s) ?<))
(fmt (org-time-stamp-format (nth 1 time) (not active)))
time-before time-after)
(setf (car time) (or (car time) 0))
(setf (nth 1 time) (or (nth 1 time) 0))
(setf (nth 2 time) (or (nth 2 time) 0))
(setq time-before (copy-sequence time))
(setq time-after (copy-sequence time))
(setf (nth 3 time-before) (1- (nth 3 time)))
(setf (nth 3 time-after) (1+ (nth 3 time)))
(mapcar (lambda (x) (format-time-string fmt (org-encode-time x)))
(list time-before time time-after)))))
(defun org-columns-open-link (&optional arg)
(interactive "P")
(let ((value (get-char-property (point) 'org-columns-value)))
(org-link-open-from-string value arg)))
;;;###autoload
(defun org-columns-get-format-and-top-level ()
(let ((fmt (org-columns-get-format)))
(org-columns-goto-top-level)
fmt))
(defun org-columns-get-format (&optional fmt-string)
"Return columns format specifications.
When optional argument FMT-STRING is non-nil, use it as the
current specifications. This function also sets
`org-columns-current-fmt-compiled' and
`org-columns-current-fmt'."
(interactive)
(let ((format
(or fmt-string
(org-entry-get nil "COLUMNS" t)
(org-with-wide-buffer
(goto-char (point-min))
(catch :found
(let ((case-fold-search t))
(while (re-search-forward "^[ \t]*#\\+COLUMNS: .+$" nil t)
(let ((element (org-element-at-point)))
(when (org-element-type-p element 'keyword)
(throw :found (org-element-property :value element)))))
nil)))
org-columns-default-format)))
(setq org-columns-current-fmt format)
(org-columns-compile-format format)
format))
(defun org-columns-goto-top-level ()
"Move to the beginning of the column view area.
Also sets `org-columns-top-level-marker' to the new position."
(unless (markerp org-columns-top-level-marker)
(setq org-columns-top-level-marker (make-marker)))
(goto-char
(move-marker
org-columns-top-level-marker
(cond ((org-before-first-heading-p) (point-min))
((org-entry-get nil "COLUMNS" t) org-entry-property-inherited-from)
(t (org-back-to-heading) (point))))))
;;;###autoload
(defun org-columns (&optional global columns-fmt-string)
"Turn on column view on an Org mode file.
Column view applies to the whole buffer if point is before the first
headline. Otherwise, it applies to the first ancestor setting
\"COLUMNS\" property. If there is none, it defaults to the current
headline. With a `\\[universal-argument]' prefix \ argument, GLOBAL,
turn on column view for the whole buffer unconditionally.
When COLUMNS-FMT-STRING is non-nil, use it as the column format."
(interactive "P")
(org-columns-remove-overlays)
(setq-local org-columns-global global)
(save-excursion
(when global (goto-char (point-min)))
(if (markerp org-columns-begin-marker)
(move-marker org-columns-begin-marker (point))
(setq org-columns-begin-marker (point-marker)))
(org-columns-goto-top-level)
;; Initialize `org-columns-current-fmt' and
;; `org-columns-current-fmt-compiled'.
(let ((org-columns--time (float-time)))
(org-columns-get-format columns-fmt-string)
(unless org-columns-inhibit-recalculation (org-columns-compute-all))
(save-restriction
(when (and (not global) (org-at-heading-p))
(narrow-to-region (point) (org-end-of-subtree t t)))
(when (assoc "CLOCKSUM" org-columns-current-fmt-compiled)
(org-clock-sum))
(when (assoc "CLOCKSUM_T" org-columns-current-fmt-compiled)
(org-clock-sum-today))
(let ((cache
;; Collect contents of columns ahead of time so as to
;; compute their maximum width.
(org-scan-tags
(lambda () (cons (point-marker) (org-columns--collect-values))) t org--matcher-tags-todo-only)))
(when cache
(org-columns--set-widths cache)
(org-columns--display-here-title)
(when (setq-local org-columns-flyspell-was-active
(bound-and-true-p flyspell-mode))
(flyspell-mode 0))
(unless (local-variable-p 'org-colview-initial-truncate-line-value)
(setq-local org-colview-initial-truncate-line-value
truncate-lines))
(if (not global-visual-line-mode)
(setq truncate-lines t))
(dolist (entry cache)
(goto-char (car entry))
(org-columns--display-here (cdr entry)))))))))
(defun org-columns-new (&optional spec &rest attributes)
"Insert a new column, to the left of the current column.
Interactively fill attributes for new column. When column format
specification SPEC is provided, edit it instead.
When optional argument attributes can be a list of columns
specifications attributes to create the new column
non-interactively. See `org-columns-compile-format' for
details."
(interactive)
(let ((new (or attributes
(let ((prop
(completing-read
"Property: "
(mapcar #'list (org-buffer-property-keys t nil t))
nil nil (nth 0 spec))))
(list prop
(read-string (format "Column title [%s]: " prop)
(nth 1 spec))
;; Use `read-string' instead of `read-number'
;; to allow empty width.
(let ((w (read-string
"Column width: "
(and (nth 2 spec)
(number-to-string (nth 2 spec))))))
(and (org-string-nw-p w) (string-to-number w)))
(org-string-nw-p
(completing-read
"Summary: "
(delete-dups
(cons '("") ;Allow empty operator.
(mapcar (lambda (x) (list (car x)))
(append
org-columns-summary-types
org-columns-summary-types-default))))
nil t (nth 3 spec)))
(org-string-nw-p
(read-string "Format: " (nth 4 spec))))))))
(if spec
(progn (setcar spec (car new))
(setcdr spec (cdr new)))
(push new (nthcdr (org-current-text-column) org-columns-current-fmt-compiled)))
(org-columns-store-format)
(org-columns-redo)))
(defun org-columns-delete ()
"Delete the column at point from columns view."
(interactive)
(let ((spec (nth (org-current-text-column) org-columns-current-fmt-compiled)))
(when (y-or-n-p (format "Are you sure you want to remove column %S? "
(nth 1 spec)))
(setq org-columns-current-fmt-compiled
(delq spec org-columns-current-fmt-compiled))
(org-columns-store-format)
;; This may leave a now wrong value in a node property. However
;; updating it may prove counter-intuitive. See comments in
;; `org-columns-move-right' for details.
(let ((org-columns-inhibit-recalculation t)) (org-columns-redo))
(when (>= (org-current-text-column) (length org-columns-current-fmt-compiled))
(backward-char)))))
(defun org-columns-edit-attributes ()
"Edit the attributes of the current column."
(interactive)
(org-columns-new (nth (org-current-text-column) org-columns-current-fmt-compiled)))
(defun org-columns-widen (arg)
"Make the column wider by ARG characters."
(interactive "p")
(let* ((n (org-current-text-column))
(entry (nth n org-columns-current-fmt-compiled))
(width (aref org-columns-current-maxwidths n)))
(setq width (max 1 (+ width arg)))
(setcar (nthcdr 2 entry) width)
(org-columns-store-format)
(let ((org-columns-inhibit-recalculation t)) (org-columns-redo))))
(defun org-columns-narrow (arg)
"Make the column narrower by ARG characters."
(interactive "p")
(org-columns-widen (- arg)))
(defun org-columns-move-up ()
"In column view, move cursor up one row.
When in agenda column view, also call `org-agenda-do-context-action'."
(interactive)
(let ((col (current-column)))
(forward-line -1)
(while (and (org-invisible-p2) (not (bobp)))
(forward-line -1))
(move-to-column col)
(if (eq major-mode 'org-agenda-mode)
(org-agenda-do-context-action))))
(defun org-columns-move-down ()
"In column view, move cursor down one row.
When in agenda column view, also call `org-agenda-do-context-action'."
(interactive)
(let ((col (current-column)))
(forward-line 1)
(while (and (org-invisible-p2) (not (eobp)))
(forward-line 1))
(move-to-column col)
(if (derived-mode-p 'org-agenda-mode)
(org-agenda-do-context-action))))
(defun org-columns-move-right ()
"Swap this column with the one to the right."
(interactive)
(let* ((n (org-current-text-column))
(cell (nthcdr n org-columns-current-fmt-compiled))
e)
(when (>= n (1- (length org-columns-current-fmt-compiled)))
(error "Cannot shift this column further to the right"))
(setq e (car cell))
(setcar cell (car (cdr cell)))
(setcdr cell (cons e (cdr (cdr cell))))
(org-columns-store-format)
;; Do not compute again properties, since we're just moving
;; columns around. It can put a property value a bit off when
;; switching between an non-computed and a computed value for the
;; same property, e.g. from "%A %A{+}" to "%A{+} %A".
;;
;; In this case, the value needs to be updated since the first
;; column related to a property determines how its value is
;; computed. However, (correctly) updating the value could be
;; surprising, so we leave it as-is nonetheless.
(let ((org-columns-inhibit-recalculation t)) (org-columns-redo))
(forward-char 1)))
(defun org-columns-move-left ()
"Swap this column with the one to the left."
(interactive)
(let* ((n (org-current-text-column)))
(when (= n 0)
(error "Cannot shift this column further to the left"))
(backward-char 1)
(org-columns-move-right)
(backward-char 1)))
(defun org-columns--move-row (&optional up)
"Move the current table row down.
With non-nil optional argument UP, move it up."
(let ((inhibit-read-only t)
(col (current-column)))
(if up (org-move-subtree-up)
(org-move-subtree-down))
(let ((org-columns-inhibit-recalculation t))
(org-columns-redo)
(move-to-column col))))
(defun org-columns-move-row-down ()
"Move the current table row down."
(interactive)
(org-columns--move-row))
(defun org-columns-move-row-up ()
"Move the current table row up."
(interactive)
(org-columns--move-row 'up))
(defun org-columns-store-format ()
"Store the text version of the current columns format.
The format is stored either in the COLUMNS property of the node
starting the current column display, or in a #+COLUMNS line of
the current buffer."
(let ((fmt (org-columns-uncompile-format org-columns-current-fmt-compiled)))
(setq-local org-columns-current-fmt fmt)
(when org-columns-overlays
(org-with-point-at org-columns-top-level-marker
(if (and (org-at-heading-p) (org-entry-get nil "COLUMNS"))
(org-entry-put nil "COLUMNS" fmt)
(goto-char (point-min))
(let ((case-fold-search t))
;; Try to replace the first COLUMNS keyword available.
(catch :found
(while (re-search-forward "^[ \t]*#\\+COLUMNS:\\(.*\\)" nil t)
(let ((element (save-match-data (org-element-at-point))))
(when (and (org-element-type-p element 'keyword)
(equal (org-element-property :key element)
"COLUMNS"))
(replace-match (concat " " fmt) t t nil 1)
(throw :found nil))))
;; No COLUMNS keyword in the buffer. Insert one at the
;; beginning, right before the first heading, if any.
(goto-char (point-min))
(unless (org-at-heading-p) (outline-next-heading))
(let ((inhibit-read-only t))
(insert-before-markers "#+COLUMNS: " fmt "\n"))))
(setq-local org-columns-default-format fmt))))))
(defun org-columns-update (property)
"Recompute PROPERTY, and update the columns display for it."
(org-columns-compute property)
(org-with-wide-buffer
(let ((p (upcase property)))
(dolist (ov org-columns-overlays)
(let ((key (overlay-get ov 'org-columns-key)))
(when (and key (equal key p) (overlay-start ov))
(goto-char (overlay-start ov))
(let* ((spec (nth (org-current-text-column) org-columns-current-fmt-compiled))
(value
(or (cdr (assoc spec
(get-text-property (line-beginning-position)
'org-summaries)))
(org-entry-get (point) key))))
(when value
(let ((displayed (org-columns--displayed-value spec value))
(format (overlay-get ov 'org-columns-format))
(width
(aref org-columns-current-maxwidths (org-current-text-column))))
(overlay-put ov 'org-columns-value value)
(overlay-put ov 'org-columns-value-modified displayed)
(overlay-put ov
'display
(org-columns--overlay-text
displayed format width property value)))))))))))
(defun org-columns-redo ()
"Construct the column display again."
(interactive)
(when org-columns-overlays
(message "Recomputing columns...")
(org-with-point-at org-columns-begin-marker
(org-columns-remove-overlays)
(if (derived-mode-p 'org-mode)
;; Since we already know the columns format, provide it
;; instead of computing again.
(funcall-interactively #'org-columns org-columns-global org-columns-current-fmt)
(org-agenda-redo)
(call-interactively #'org-agenda-columns)))
(message "Recomputing columns...done")))
(defun org-columns-uncompile-format (compiled)
"Turn the compiled columns format back into a string representation.
COMPILED is an alist, as returned by `org-columns-compile-format'."
(mapconcat
(lambda (spec)
(pcase spec
(`(,prop ,title ,width ,op ,printf)
(concat "%"
(and width (number-to-string width))
prop
(and title (not (equal prop title)) (format "(%s)" title))
(cond ((not op) nil)
(printf (format "{%s;%s}" op printf))
(t (format "{%s}" op)))))))
compiled " "))
(defun org-columns-compile-format (fmt)
"Turn a column format string FMT into an alist of specifications.
The alist has one entry for each column in the format. The elements of
that list are:
property the property name, as an upper-case string
title the title field for the columns, as a string
width the column width in characters, can be nil for automatic width
operator the summary operator, as a string, or nil
printf a printf format for computed values, as a string, or nil
This function updates `org-columns-current-fmt-compiled'."
(setq org-columns-current-fmt-compiled nil)
(let ((start 0))
(while (string-match
"%\\([0-9]+\\)?\\([[:alnum:]_-]+\\)\\(?:(\\([^)]+\\))\\)?\
\\(?:{\\([^}]+\\)}\\)?\\s-*"
fmt start)
(setq start (match-end 0))
(let* ((width (and (match-end 1) (string-to-number (match-string 1 fmt))))
(prop (match-string-no-properties 2 fmt))
(title (or (match-string-no-properties 3 fmt) prop))
(operator (match-string-no-properties 4 fmt)))
(push (if (not operator) (list (upcase prop) title width nil nil)
(let (printf)
(when (string-match ";" operator)
(setq printf (substring operator (match-end 0)))
(setq operator (substring operator 0 (match-beginning 0))))
(list (upcase prop) title width operator printf)))
org-columns-current-fmt-compiled)))
(setq org-columns-current-fmt-compiled
(nreverse org-columns-current-fmt-compiled))))
;;;; Column View Summary
(defun org-columns--age-to-minutes (s)
"Turn age string S into a number of minutes.
An age is either computed from a given timestamp, or indicated
as a canonical duration, i.e., using units defined in
`org-duration-canonical-units'."
(cond
((string-match-p org-ts-regexp s)
(/ (- org-columns--time
(float-time (org-time-string-to-time s)))
60))
((org-duration-p s) (org-duration-to-minutes s t)) ;skip user units
(t (user-error "Invalid age: %S" s))))
(defun org-columns--format-age (minutes)
"Format MINUTES float as an age string."
(org-duration-from-minutes minutes
'(("d" . nil) ("h" . nil) ("min" . nil))
t)) ;ignore user's custom units
(defun org-columns--summary-apply-times (fun times)
"Apply FUN to time values TIMES.
Return the result as a duration."
(org-duration-from-minutes
(apply fun (mapcar #'org-duration-to-minutes times))
(org-duration-h:mm-only-p times)))
(defun org-columns--compute-spec (spec &optional update)
"Update tree according to SPEC.
SPEC is a column format specification. When optional argument
UPDATE is non-nil, summarized values can replace existing ones in
properties drawers."
(let* ((lmax (if (bound-and-true-p org-inlinetask-max-level)
org-inlinetask-max-level
29)) ;Hard-code deepest level.
(lvals (make-vector (1+ lmax) nil))
(level 0)
(inminlevel lmax)
(last-level lmax)
(property (car spec))
(printf (nth 4 spec))
;; Special properties cannot be collected nor summarized, as
;; they have their own way to be computed. Therefore, ignore
;; any operator attached to them.
(operator (and (not (member property org-special-properties))
(nth 3 spec)))
(collect (and operator (org-columns--collect operator)))
(summarize (and operator (org-columns--summarize operator))))
(org-with-wide-buffer
;; Find the region to compute.
(goto-char org-columns-top-level-marker)
(goto-char (condition-case nil (org-end-of-subtree t) (error (point-max))))
;; Walk the tree from the back and do the computations.
(while (re-search-backward
org-outline-regexp-bol org-columns-top-level-marker t)
(unless (or (= level 0) (eq level inminlevel))
(setq last-level level))
(setq level (org-reduced-level (org-outline-level)))
(let* ((pos (match-beginning 0))
(value (if collect (funcall collect property)
(org-entry-get (point) property)))
(value-set (org-string-nw-p value)))
(cond
((< level last-level)
;; Collect values from lower levels and inline tasks here
;; and summarize them using SUMMARIZE. Store them in text
;; property `org-summaries', in alist whose key is SPEC.
(let* ((summary
(and summarize
(let ((values
(cl-loop for l from (1+ level) to lmax
append (aref lvals l))))
(and values (funcall summarize values printf))))))
;; Leaf values are not summaries: do not mark them.
(when summary
(let* ((summaries-alist (get-text-property pos 'org-summaries))
(old (assoc spec summaries-alist)))
(if old (setcdr old summary)
(push (cons spec summary) summaries-alist)
(with-silent-modifications
(add-text-properties
pos (1+ pos) (list 'org-summaries summaries-alist)))))
;; When PROPERTY exists in current node, even if empty,
;; but its value doesn't match the one computed, use
;; the latter instead.
;;
;; Ignore leading or trailing white spaces that might
;; have been introduced in summary, since those are not
;; significant in properties value.
(let ((new-value (org-trim summary)))
(when (and update value (not (equal value new-value)))
(org-entry-put (point) property new-value))))
;; Add current to current level accumulator.
(when (or summary value-set)
(push (or summary value) (aref lvals level)))
;; Clear accumulators for deeper levels.
(cl-loop for l from (1+ level) to lmax do (aset lvals l nil))))
(value-set (push value (aref lvals level)))
(t nil)))))))
;;;###autoload
(defun org-columns-compute (property)
"Summarize the values of PROPERTY hierarchically.
Also update existing values for PROPERTY according to the first
column specification."
(interactive)
(let ((main-flag t)
(upcase-prop (upcase property)))
(dolist (spec org-columns-current-fmt-compiled)
(pcase spec
(`(,(pred (equal upcase-prop)) . ,_)
(org-columns--compute-spec spec main-flag)
;; Only the first summary can update the property value.
(when main-flag (setq main-flag nil)))))))
(defun org-columns-compute-all ()
"Compute all columns that have operators defined."
(with-silent-modifications
(remove-text-properties (point-min) (point-max) '(org-summaries t)))
(let ((org-columns--time (float-time))
seen)
(dolist (spec org-columns-current-fmt-compiled)
(let ((property (car spec)))
;; Property value is updated only the first time a given
;; property is encountered.
(org-columns--compute-spec spec (not (member property seen)))
(push property seen)))))
(defun org-columns--summary-sum (values printf)
"Compute the sum of VALUES.
When PRINTF is non-nil, use it to format the result."
(format (or printf "%s") (apply #'+ (mapcar #'string-to-number values))))
(defun org-columns--summary-currencies (values _)
"Compute the sum of VALUES, with two decimals."
(format "%.2f" (apply #'+ (mapcar #'string-to-number values))))
(defun org-columns--summary-checkbox (check-boxes _)
"Summarize CHECK-BOXES with a check-box."
(let ((done (cl-count "[X]" check-boxes :test #'equal))
(all (length check-boxes)))
(cond ((= done all) "[X]")
((> done 0) "[-]")
(t "[ ]"))))
(defun org-columns--summary-checkbox-count (check-boxes _)
"Summarize CHECK-BOXES with a check-box cookie."
(format "[%d/%d]"
(cl-count-if (lambda (b) (or (equal b "[X]")
(string-match-p "\\[\\([1-9]\\)/\\1\\]" b)))
check-boxes)
(length check-boxes)))
(defun org-columns--summary-checkbox-percent (check-boxes _)
"Summarize CHECK-BOXES with a check-box percent."
(format "[%d%%]"
(round (* 100.0 (cl-count-if (lambda (b) (member b '("[X]" "[100%]")))
check-boxes))
(length check-boxes))))
(defun org-columns--summary-min (values printf)
"Compute the minimum of VALUES.
When PRINTF is non-nil, use it to format the result."
(format (or printf "%s")
(apply #'min (mapcar #'string-to-number values))))
(defun org-columns--summary-max (values printf)
"Compute the maximum of VALUES.
When PRINTF is non-nil, use it to format the result."
(format (or printf "%s")
(apply #'max (mapcar #'string-to-number values))))
(defun org-columns--summary-mean (values printf)
"Compute the mean of VALUES.
When PRINTF is non-nil, use it to format the result."
(format (or printf "%s")
(/ (apply #'+ (mapcar #'string-to-number values))
(float (length values)))))
(defun org-columns--summary-sum-times (times _)
"Sum TIMES."
(org-columns--summary-apply-times #'+ times))
(defun org-columns--summary-min-time (times _)
"Compute the minimum time among TIMES."
(org-columns--summary-apply-times #'min times))
(defun org-columns--summary-max-time (times _)
"Compute the maximum time among TIMES."
(org-columns--summary-apply-times #'max times))
(defun org-columns--summary-mean-time (times _)
"Compute the mean time among TIMES."
(org-columns--summary-apply-times
(lambda (&rest values) (/ (apply #'+ values) (float (length values))))
times))
(defun org-columns--summary-min-age (ages _)
"Compute the minimum age among AGES."
(org-columns--format-age
(apply #'min (mapcar #'org-columns--age-to-minutes ages))))
(defun org-columns--summary-max-age (ages _)
"Compute the maximum age among AGES."
(org-columns--format-age
(apply #'max (mapcar #'org-columns--age-to-minutes ages))))
(defun org-columns--summary-mean-age (ages _)
"Compute the mean age among AGES."
(org-columns--format-age
(/ (apply #'+ (mapcar #'org-columns--age-to-minutes ages))
(float (length ages)))))
(defun org-columns--summary-estimate (estimates _)
"Combine a list of estimates, using mean and variance.
The mean and variance of the result will be the sum of the means
and variances (respectively) of the individual estimates."
(let ((mean 0)
(var 0))
(dolist (e estimates)
(pcase (mapcar #'string-to-number (split-string e "-"))
(`(,low ,high)
(let ((m (/ (+ low high) 2.0)))
(cl-incf mean m)
(cl-incf var (- (/ (+ (* low low) (* high high)) 2.0) (* m m)))))
(`(,value) (cl-incf mean value))))
(let ((sd (sqrt var)))
(format "%s-%s"
(format "%.0f" (- mean sd))
(format "%.0f" (+ mean sd))))))
;;; Dynamic block for Column view
(defun org-columns--capture-view (maxlevel match skip-empty exclude-tags format local)
"Get the column view of the current buffer.
MAXLEVEL sets the level limit. SKIP-EMPTY tells whether to skip
empty rows, an empty row being one where all the column view
specifiers but ITEM are empty. EXCLUDE-TAGS is a list of tags
that will be excluded from the resulting view. FORMAT is a
format string for columns, or nil. When LOCAL is non-nil, only
capture headings in current subtree.
This function returns a list containing the title row and all other
rows. Each row is either a list, or the symbol `hline'. The first list
is the heading row as a list of strings with the column titles according
to FORMAT. All subsequent lists each represent a body row as a list
whose first element is an integer indicating the outline level of the
entry, and whose remaining elements are strings with the contents for
the columns according to FORMAT."
(org-columns (not local) format)
(goto-char org-columns-top-level-marker)
(let ((columns (length org-columns-current-fmt-compiled))
(has-item (assoc "ITEM" org-columns-current-fmt-compiled))
table)
(org-map-entries
(lambda ()
(when (get-char-property (point) 'org-columns-key)
(let (row)
(dotimes (i columns)
(let* ((col (+ (line-beginning-position) i))
(p (get-char-property col 'org-columns-key)))
(push (get-char-property col
(if (string= p "ITEM")
'org-columns-value
'org-columns-value-modified))
row)))
(unless (or
(and skip-empty
(let ((r (delete-dups (remove "" row))))
(or (null r) (and has-item (= (length r) 1)))))
(and exclude-tags
(cl-some (lambda (tag) (member tag exclude-tags))
(org-get-tags))))
(push (cons (org-reduced-level (org-current-level)) (nreverse row))
table)))))
(if match
(concat match (and maxlevel (format "+LEVEL<=%d" maxlevel)))
(and maxlevel (format "LEVEL<=%d" maxlevel)))
(and local 'tree)
'archive 'comment)
(org-columns-quit)
;; Add column titles and a horizontal rule in front of the table.
(cons (mapcar #'cadr org-columns-current-fmt-compiled)
(cons 'hline (nreverse table)))))
(defun org-columns--clean-item (item)
"Remove sensitive contents from string ITEM.
This includes objects that may not be duplicated within
a document, e.g., a target, or those forbidden in tables, e.g.,
an inline src-block."
(let ((data (org-element-parse-secondary-string
item (org-element-restriction 'headline))))
(org-element-map data
'(footnote-reference inline-babel-call inline-src-block target
radio-target statistics-cookie)
#'org-element-extract)
(org-quote-vert
(org-no-properties
(org-element-interpret-data data)))))
;;;###autoload
(defun org-dblock-write:columnview (params)
"Write the column view table.
PARAMS is a property list of parameters:
`:id' (mandatory)
The ID property of the entry where the columns view should be
built. When the symbol `local', call locally. When `global'
call column view with the cursor at the beginning of the
buffer (usually this means that the whole buffer switches to
column view). When \"file:path/to/file.org\", invoke column
view at the start of that file. Otherwise, the ID is located
using `org-id-find'.
`:exclude-tags'
List of tags to exclude from column view table.
`:format'
When non-nil, specify the column view format to use.
`:hlines'
When non-nil, insert a hline before each item. When
a number, insert a hline before each level inferior or equal
to that number.
`:indent'
When non-nil, indent each ITEM field according to its level.
`:match'
When set to a string, use this as a tags/property match filter.
`:maxlevel'
When set to a number, don't capture headlines below this level.
`:skip-empty-rows'
When non-nil, skip rows where all specifiers other than ITEM
are empty.
`:vlines'
When non-nil, make each column a column group to enforce
vertical lines.
`:link'
Link the item headlines in the table to their origins.
`:formatter'
A function to format the data and insert it into the
buffer. Overrides the default formatting function set in
`org-columns-dblock-formatter'."
(let ((table
(let ((id (plist-get params :id))
view-file view-pos)
(pcase id
(`global nil)
((or `local `nil) (setq view-pos (point)))
((and (let id-string (format "%s" id))
(guard (string-match "^file:\\(.*\\)" id-string)))
(setq view-file (match-string-no-properties 1 id-string))
(unless (file-exists-p view-file)
(user-error "No such file: %S" id-string)))
((and (let idpos (org-find-entry-with-id id)) (guard idpos))
(setq view-pos idpos))
((let `(,filename . ,position) (org-id-find id))
(setq view-file filename)
(setq view-pos position))
(_ (user-error "Cannot find entry with :ID: %s" id)))
(with-current-buffer (if view-file (org-get-agenda-file-buffer view-file)
(current-buffer))
(org-with-wide-buffer
(when view-pos (goto-char view-pos))
(org-columns--capture-view (plist-get params :maxlevel)
(plist-get params :match)
(plist-get params :skip-empty-rows)
(plist-get params :exclude-tags)
(plist-get params :format)
view-pos)))))
(formatter (or (plist-get params :formatter)
org-columns-dblock-formatter
#'org-columns-dblock-write-default)))
(funcall formatter (point) table params)))
(defun org-columns-dblock-write-default (ipos table params)
"Write out a columnview table at position IPOS in the current buffer.
TABLE is a table with data as produced by `org-columns--capture-view'.
PARAMS is the parameter property list obtained from the dynamic block
definition."
(let ((link (plist-get params :link))
(width-specs
(mapcar (lambda (spec) (nth 2 spec))
org-columns-current-fmt-compiled)))
(when table
;; Prune level information from the table. Also normalize
;; headings: remove stars, add indentation entities, if
;; required, and possibly precede some of them with a horizontal
;; rule.
(let ((item-index
(let ((p (assoc "ITEM" org-columns-current-fmt-compiled)))
(and p (cl-position p
org-columns-current-fmt-compiled
:test #'equal))))
(hlines (plist-get params :hlines))
(indent (plist-get params :indent))
new-table)
;; Copy header and first rule.
(push (pop table) new-table)
(push (pop table) new-table)
(dolist (row table (setq table (nreverse new-table)))
(let ((level (car row)))
(when (and (not (eq (car new-table) 'hline))
(or (eq hlines t)
(and (numberp hlines) (<= level hlines))))
(push 'hline new-table))
(when item-index
(let* ((raw (nth item-index (cdr row)))
(cleaned (org-columns--clean-item raw))
(item (if (not link) cleaned
(let ((search (org-link-heading-search-string raw)))
(org-link-make-string
(if (not (buffer-file-name)) search
(format "file:%s::%s" (buffer-file-name) search))
cleaned)))))
(setf (nth item-index (cdr row))
(if (and indent (> level 1))
(concat "\\_" (make-string (* 2 (1- level)) ?\s) item)
item))))
(push (cdr row) new-table))))
(when (plist-get params :vlines)
(setq table
(let ((size (length org-columns-current-fmt-compiled)))
(append (mapcar (lambda (x) (if (eq 'hline x) x (cons "" x)))
table)
(list (cons "/" (make-list size "<>")))))))
(when (seq-find #'identity width-specs)
;; There are width specifiers in column format. Pass them
;; to the resulting table, adding alignment field as the first
;; row.
(push (mapcar (lambda (width) (when width (format "<%d>" width))) width-specs) table))
;; now insert the table into the buffer
(goto-char ipos)
(let ((content-lines (org-split-string (plist-get params :content) "\n"))
recalc)
;; Insert affiliated keywords before the table.
(when content-lines
(while (string-match-p "\\`[ \t]*#\\+" (car content-lines))
(insert (string-trim-left (pop content-lines)) "\n")))
(save-excursion
;; Insert table at point.
(insert
(mapconcat (lambda (row)
(if (eq row 'hline) "|-|"
(format "|%s|" (mapconcat #'identity row "|"))))
table
"\n"))
;; Insert TBLFM lines following table.
(let ((case-fold-search t))
(dolist (line content-lines)
(when (string-match-p "\\`[ \t]*#\\+TBLFM:" line)
(insert "\n" (string-trim-left line))
(unless recalc (setq recalc t))))))
(when recalc (org-table-recalculate 'all t))
(org-table-align)
(when (seq-find #'identity width-specs)
(org-table-shrink))))))
;;;###autoload
(defun org-columns-insert-dblock ()
"Create a dynamic block capturing a column view table."
(interactive)
(let ((id (completing-read
"Capture columns (local, global, entry with :ID: property) [local]: "
(append '(("global") ("local"))
(mapcar #'list (org-property-values "ID"))))))
(org-create-dblock
(list :name "columnview"
:hlines 1
:id (cond ((string= id "global") 'global)
((member id '("" "local")) 'local)
(id)))))
(org-update-dblock))
;;;###autoload
(eval-after-load 'org
'(progn
(org-dynamic-block-define "columnview" #'org-columns-insert-dblock)))
;;; Column view in the agenda
;;;###autoload
(defun org-agenda-columns ()
"Turn on or update column view in the agenda."
(interactive)
(org-columns-remove-overlays)
(if (markerp org-columns-begin-marker)
(move-marker org-columns-begin-marker (point))
(setq org-columns-begin-marker (point-marker)))
(let* ((org-columns--time (float-time))
(org-done-keywords org-done-keywords-for-agenda)
(fmt
(cond
((bound-and-true-p org-overriding-columns-format))
((bound-and-true-p org-local-columns-format))
((bound-and-true-p org-columns-default-format-for-agenda))
((let ((m (org-get-at-bol 'org-hd-marker)))
(and m
(or (org-entry-get m "COLUMNS" t)
(with-current-buffer (marker-buffer m)
org-columns-default-format)))))
((and (local-variable-p 'org-columns-current-fmt)
org-columns-current-fmt))
((let ((m (next-single-property-change (point-min) 'org-hd-marker)))
(and m
(let ((m (get-text-property m 'org-hd-marker)))
(or (org-entry-get m "COLUMNS" t)
(with-current-buffer (marker-buffer m)
org-columns-default-format))))))
(t org-columns-default-format)))
(compiled-fmt (org-columns-compile-format fmt)))
(setq org-columns-current-fmt fmt)
(when org-agenda-columns-compute-summary-properties
(org-agenda-colview-compute org-columns-current-fmt-compiled))
(save-excursion
;; Collect properties for each headline in current view.
(goto-char (point-min))
(let (cache)
(while (not (eobp))
(let ((m (org-get-at-bol 'org-hd-marker)))
(when m
(push (cons (line-beginning-position)
;; `org-columns-current-fmt-compiled' is
;; initialized but only set locally to the
;; agenda buffer. Since current buffer is
;; changing, we need to force the original
;; compiled-fmt there.
(org-with-point-at m
(org-columns--collect-values compiled-fmt)))
cache)))
(forward-line))
(when cache
(org-columns--set-widths cache)
(org-columns--display-here-title)
(when (setq-local org-columns-flyspell-was-active
(bound-and-true-p flyspell-mode))
(flyspell-mode 0))
(dolist (entry cache)
(goto-char (car entry))
(org-columns--display-here (cdr entry)))
(setq-local org-agenda-columns-active t)
(when org-agenda-columns-show-summaries
(org-agenda-colview-summarize cache)))))))
(defun org-agenda-colview-summarize (cache)
"Summarize the summarizable columns in column view in the agenda.
This will add overlays to the date lines, to show the summary for each day."
(let ((fmt (mapcar
(lambda (spec)
(pcase spec
(`(,property ,title ,width . ,_)
(if (member property '("CLOCKSUM" "CLOCKSUM_T"))
(list property title width ":" nil)
spec))))
org-columns-current-fmt-compiled)))
;; Ensure there's at least one summation column.
(when (cl-some (lambda (spec) (nth 3 spec)) fmt)
(goto-char (point-max))
(catch :complete
(while t
(when (or (get-text-property (point) 'org-date-line)
(eq (get-text-property (point) 'face)
'org-agenda-structure))
;; OK, this is a date line that should be used.
(let (entries)
(let (rest)
(dolist (c cache)
(if (> (car c) (point))
(push c entries)
(push c rest)))
(setq cache rest))
;; ENTRIES contains entries below the current one.
;; CACHE is the rest. Compute the summaries for the
;; properties we want, set nil properties for the rest.
(when (setq entries (mapcar #'cdr entries))
(org-columns--display-here
(mapcar
(lambda (spec)
(pcase spec
(`("ITEM" . ,_)
;; Replace ITEM with current date. Preserve
;; properties for fontification.
(let ((date (buffer-substring
(line-beginning-position)
(line-end-position))))
(list spec date date)))
(`(,_ ,_ ,_ nil ,_) (list spec "" ""))
(`(,_ ,_ ,_ ,operator ,printf)
(let* ((summarize (org-columns--summarize operator))
(values
;; Use real values for summary, not
;; those prepared for display.
(delq nil
(mapcar
(lambda (e) (org-string-nw-p
(nth 1 (assoc spec e))))
entries)))
(final (if values
(funcall summarize values printf)
"")))
(unless (equal final "")
(put-text-property 0 (length final)
'face 'bold final))
(list spec final final)))))
fmt)
'dateline))))
(if (bobp) (throw :complete t) (forward-line -1)))))))
(defun org-agenda-colview-compute (fmt)
"Compute the relevant columns in the contributing source buffers."
(dolist (file org-agenda-contributing-files)
(let ((b (find-buffer-visiting file)))
(with-current-buffer (or (buffer-base-buffer b) b)
(org-with-wide-buffer
(with-silent-modifications
(remove-text-properties (point-min) (point-max) '(org-summaries t)))
(goto-char (point-min))
(org-columns-get-format-and-top-level)
(dolist (spec fmt)
(let ((prop (car spec)))
(cond
((equal prop "CLOCKSUM") (org-clock-sum))
((equal prop "CLOCKSUM_T") (org-clock-sum-today))
((and (nth 3 spec)
(let ((a (assoc prop org-columns-current-fmt-compiled)))
(equal (nth 3 a) (nth 3 spec))))
(org-columns-compute prop))))))))))
(provide 'org-colview)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; org-colview.el ends here
org-mode-9.7.29+dfsg/lisp/org-compat.el 0000664 0000000 0000000 00000212104 15004304337 0017612 0 ustar 00root root 0000000 0000000 ;;; org-compat.el --- Compatibility Code for Older Emacsen -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2025 Free Software Foundation, Inc.
;; Author: Carsten Dominik
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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
;; 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
;; Keywords: org, text
;; 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 >. 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 <> 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
;; ============
;;
;; Download and install Exuberant ctags -- "https://ctags.sourceforge.net/"
;; Edit your .emacs file (see next section) and load emacs.
;; To put in your init file (.emacs):
;; ==================================
;;
;; Assuming you already have org mode installed and set up:
;;
;; (setq org-ctags-path-to-ctags "/path/to/ctags/executable")
;; (add-hook 'org-mode-hook
;; (lambda ()
;; (define-key org-mode-map "\C-co" 'org-ctags-find-tag-interactive)))
;; (with-eval-after-load "org-ctags"
;; (org-ctags-enable))
;;
;; To activate the library, you need to call `org-ctags-enable' explicitly.
;; It used to be invoked during library loading, but it was against Emacs
;; policy and caused inconvenience of Org users who do not use `org-ctags'.
;;
;; By default, with org-ctags loaded, org will first try and visit the tag
;; with the same name as the link; then, if unsuccessful, ask the user if
;; he/she wants to rebuild the 'TAGS' database and try again; then ask if
;; the user wishes to append 'tag' as a new toplevel heading at the end of
;; the buffer; and finally, defer to org's default behavior which is to
;; search the entire text of the current buffer for 'tag'.
;;
;; This behavior can be modified by changing the value of
;; ORG-CTAGS-OPEN-LINK-FUNCTIONS. For example, I have the following in my
;; .emacs, which describes the same behavior as the above paragraph with
;; one difference:
;;
;; (setq org-ctags-open-link-functions
;; '(org-ctags-find-tag
;; org-ctags-ask-rebuild-tags-file-then-find-tag
;; org-ctags-ask-append-topic
;; org-ctags-fail-silently)) ; <-- prevents org default behavior
;;
;;
;; Usage
;; =====
;;
;; When you click on a link "[[foo]]" and org cannot find a matching "<>"
;; in the current buffer, the tags facility will take over. The file TAGS in
;; the active directory is examined to see if the tags facility knows about
;; "<>" in any other files. If it does, the matching file will be opened
;; and the cursor will jump to the position of "<>" in that file.
;;
;; User-visible functions:
;; - `org-ctags-find-tag-interactive': type a tag (plain link) name and visit
;; it. With autocompletion. Bound to ctrl-O in the above setup.
;; - All the etags functions should work. These include:
;;
;; M-. `find-tag' -- finds the tag at point
;;
;; C-M-. find-tag based on regular expression
;;
;; M-x tags-search RET -- like C-M-. but searches through ENTIRE TEXT
;; of ALL the files referenced in the TAGS file. A quick way to
;; search through an entire 'project'.
;;
;; M-* "go back" from a tag jump. Like `org-mark-ring-goto'.
;; You may need to bind this key yourself with (eg)
;; (global-set-key (kbd "") 'pop-tag-mark)
;;
;; (see etags chapter in Emacs manual for more)
;;
;;
;; 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 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
;; your `org-open-link-functions' list, as is done in the setup
;; above. This will cause the TAGS file to be rebuilt whenever a link
;; cannot be found. This may be slow with large file collections however.
;; 3. You run the following from the command line (all 1 line):
;;
;; ctags --langdef=orgmode --langmap=orgmode:.org
;; --regex-orgmode="/<<([^>]+)>>/\1/d,definition/"
;; -f /your/path/TAGS -e -R /your/path/*.org
;;
;; If you are paranoid, you might want to run (org-ctags-create-tags
;; "/path/to/org/files") at startup, by including the following toplevel form
;; in .emacs. However this can cause a pause of several seconds if ctags has
;; to scan lots of files.
;;
;; (progn
;; (message "-- rebuilding tags tables...")
;; (mapc 'org-ctags-create-tags tags-table-list))
;;; Code:
(require 'org-macs)
(org-assert-version)
(eval-when-compile (require 'cl-lib))
(require 'org)
(defgroup org-ctags nil
"Options concerning use of ctags within org mode."
:tag "Org-Ctags"
:group 'org-link)
(defvar org-ctags-enabled-p t
"Activate ctags support in org mode?")
(defvar org-ctags-tag-regexp "/<<([^<>]+)>>/\\1/d,definition/"
"Regexp expression used by ctags external program.
The regexp matches tag destinations in Org files.
Format is: /REGEXP/TAGNAME/FLAGS,TAGTYPE/
See the ctags documentation for more information.")
(defcustom org-ctags-path-to-ctags
(cond ((executable-find "ctags-exuberant")
"ctags-exuberant")
((boundp 'ctags-program-name)
ctags-program-name)
(t "ctags")) ; Emacs < 30
"Name of the ctags executable file."
:version "24.1"
:type 'file)
(defconst org-ctags--open-link-functions-list
(list
#'org-ctags-find-tag
#'org-ctags-ask-rebuild-tags-file-then-find-tag
#'org-ctags-rebuild-tags-file-then-find-tag
#'org-ctags-ask-append-topic
#'org-ctags-append-topic
#'org-ctags-ask-visit-buffer-or-file
#'org-ctags-visit-buffer-or-file
#'org-ctags-fail-silently)
"Options for `org-open-link-functions'.
Ensure that the user option and `unload-feature'
use the same set of functions.")
(defcustom org-ctags-open-link-functions
'(org-ctags-find-tag
org-ctags-ask-rebuild-tags-file-then-find-tag
org-ctags-ask-append-topic)
"List of functions to be prepended to ORG-OPEN-LINK-FUNCTIONS by ORG-CTAGS."
:version "24.1"
:type 'hook
:options org-ctags--open-link-functions-list)
(defvar org-ctags-tag-list nil
"List of all tags in the active TAGS file.
Created as a local variable in each buffer.")
(defcustom org-ctags-new-topic-template
"* <<%t>>\n\n\n\n\n\n"
"Text to insert when creating a new org file via opening a hyperlink.
The following patterns are replaced in the string:
`%t' - replaced with the capitalized title of the hyperlink"
:version "24.1"
:type 'string)
(defun org-ctags--visit-tags-table ()
"Load tags for current file.
A function for `org-mode-hook."
(when (and org-ctags-enabled-p
(buffer-file-name))
;; Make sure this file's directory is added to default
;; directories in which to search for tags.
(let ((tags-filename
(expand-file-name
(concat (file-name-directory (buffer-file-name))
"/TAGS"))))
(when (file-exists-p tags-filename)
(visit-tags-table tags-filename)))))
(defun org--ctags-load-tag-list (&rest _)
(when (and org-ctags-enabled-p tags-file-name)
(setq-local org-ctags-tag-list
(org-ctags-all-tags-in-current-tags-table))))
(defun org-ctags-enable ()
(add-hook 'org-mode-hook #'org-ctags--visit-tags-table)
(advice-add 'visit-tags-table :after #'org--ctags-load-tag-list)
(advice-add 'xref-find-definitions :before
#'org--ctags-set-org-mark-before-finding-tag)
(put 'org-mode 'find-tag-default-function 'org-ctags-find-tag-at-point)
(setq org-ctags-enabled-p t)
(dolist (fn org-ctags-open-link-functions)
(add-hook 'org-open-link-functions fn t)))
(defun org-ctags-unload-function ()
"Disable `org-ctags' library.
Called by `unload-feature'."
(put 'org-mode 'find-tag-default-function nil)
(advice-remove 'visit-tags-table #'org--ctags-load-tag-list)
(advice-remove 'xref-find-definitions
#'org--ctags-set-org-mark-before-finding-tag)
(dolist (fn org-ctags--open-link-functions-list)
(remove-hook 'org-open-link-functions fn nil)))
;;; General utility functions. ===============================================
;; These work outside org-ctags mode.
(defun org-ctags-get-filename-for-tag (tag)
"TAG is a string. Search the active TAGS file for a matching tag.
If the tag is found, return a list containing the filename, line number, and
buffer position where the tag is found."
(interactive "sTag: ")
(unless tags-file-name
(call-interactively #'visit-tags-table))
(save-excursion
(visit-tags-table-buffer 'same)
(when tags-file-name
(with-current-buffer (get-file-buffer tags-file-name)
(goto-char (point-min))
(cond
((re-search-forward (format "^.*\^?%s\^A\\([0-9]+\\),\\([0-9]+\\)$"
(regexp-quote tag)) nil t)
(let ((line (string-to-number (match-string 1)))
(pos (string-to-number (match-string 2))))
(cond
((re-search-backward " \n\\(.*\\),[0-9]+\n")
(list (match-string 1) line pos))
(t ; can't find a file name preceding the matched
; tag??
(error "Malformed TAGS file: %s" (buffer-name))))))
(t ; tag not found
nil))))))
(defun org-ctags-all-tags-in-current-tags-table ()
"Read all tags defined in the active TAGS file, into a list of strings.
Return the list."
(interactive)
(let ((taglist nil))
(unless tags-file-name
(call-interactively #'visit-tags-table))
(save-excursion
(visit-tags-table-buffer 'same)
(with-current-buffer (get-file-buffer tags-file-name)
(goto-char (point-min))
(while (re-search-forward "^.*\^?\\(.*\\)\^A\\([0-9]+\\),\\([0-9]+\\)$"
nil t)
(push (substring-no-properties (match-string 1)) taglist)))
taglist)))
(defun org-ctags-string-search-and-replace (search replace string)
"Replace all instances of SEARCH with REPLACE in STRING."
(replace-regexp-in-string (regexp-quote search) replace string t t))
;;; Internal functions =======================================================
(defun org-ctags-open-file (name &optional title)
"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: ")
(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 =================================
(defun org--ctags-set-org-mark-before-finding-tag (&rest _)
"Before trying to find a tag, save our current position on org mark ring."
(save-excursion
(when (and (derived-mode-p 'org-mode) org-ctags-enabled-p)
(org-mark-ring-push))))
(defun org-ctags-find-tag-at-point ()
"Determine default tag to search for, based on text at point.
If there is no plausible default, return nil."
(let (from to bound)
(when (or (ignore-errors
;; Look for hyperlink around `point'.
(save-excursion
(search-backward "[[") (setq from (+ 2 (point))))
(save-excursion
(goto-char from)
(search-forward "]") (setq to (- (point) 1)))
(and (> to from) (>= (point) from) (<= (point) to)))
(progn
;; Look at text around `point'.
(save-excursion
(skip-syntax-backward "w_") (setq from (point)))
(save-excursion
(skip-syntax-forward "w_") (setq to (point)))
(> to from))
;; Look between `line-beginning-position' and `point'.
(save-excursion
(and (setq bound (line-beginning-position))
(skip-syntax-backward "^w_" bound)
(> (setq to (point)) bound)
(skip-syntax-backward "w_")
(setq from (point))))
;; Look between `point' and `line-end-position'.
(save-excursion
(and (setq bound (line-end-position))
(skip-syntax-forward "^w_" bound)
(< (setq from (point)) bound)
(skip-syntax-forward "w_")
(setq to (point)))))
(buffer-substring-no-properties from to))))
;;; Functions for use with 'org-open-link-functions' hook =================
(defun org-ctags-find-tag (name)
"This function is intended to be used in ORG-OPEN-LINK-FUNCTIONS.
Look for a tag called `NAME' in the current TAGS table. If it is found,
visit the file and location where the tag is found."
(interactive "sTag: ")
(let ((old-buf (current-buffer))
(old-pnt (point-marker))
(old-mark (copy-marker (mark-marker))))
(condition-case nil
(progn (xref-find-definitions name)
t)
(error
;; only restore old location if find-tag raises error
(set-buffer old-buf)
(goto-char old-pnt)
(set-marker (mark-marker) old-mark)
nil))))
(defun org-ctags-visit-buffer-or-file (name &optional create)
"This function is intended to be used in ORG-OPEN-LINK-FUNCTIONS.
Visit buffer named `NAME.org'. If there is no such buffer, visit the file
with the same name if it exists. If the file does not exist, then behavior
depends on the value of CREATE.
If CREATE is nil (default), then return nil. Do not create a new file.
If CREATE is t, create the new file and visit it.
If CREATE is the symbol `ask', then ask the user if they wish to create
the new file."
(interactive)
(let ((filename (concat (substitute-in-file-name
(expand-file-name name))
".org")))
(cond
((get-buffer (concat name ".org"))
;; Buffer is already open
(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'..."
filename)
(org-open-file filename t))
((or (eql create t)
(and (eql create 'ask)
(y-or-n-p (format-message
"File `%s.org' not found; create?" name))))
(org-ctags-open-file filename name))
(t ;; File does not exist, and we don't want to create it.
nil))))
(defun org-ctags-ask-visit-buffer-or-file (name)
"This function is intended to be used in ORG-OPEN-LINK-FUNCTIONS.
Wrapper for org-ctags-visit-buffer-or-file, which ensures the user is
asked before creating a new file."
(org-ctags-visit-buffer-or-file name 'ask))
(defun org-ctags-append-topic (name &optional narrowp)
"This function is intended to be used in ORG-OPEN-LINK-FUNCTIONS.
Append a new toplevel heading to the end of the current buffer. The
heading contains NAME surrounded by <>, thus making
the heading a destination for the tag `NAME'."
(interactive "sTopic: ")
(widen)
(goto-char (point-max))
(newline 2)
(message "Adding topic in buffer %s" (buffer-name))
(insert (org-ctags-string-search-and-replace
"%t" (capitalize name) org-ctags-new-topic-template))
(backward-char 4)
(end-of-line)
(forward-line 2)
(when narrowp
;;(org-tree-to-indirect-buffer 1) ;; opens new frame
(org-narrow-to-subtree))
t)
(defun org-ctags-ask-append-topic (name &optional narrowp)
"This function is intended to be used in ORG-OPEN-LINK-FUNCTIONS.
Wrapper for org-ctags-append-topic, which first asks the user if they want
to append a new topic."
(if (y-or-n-p (format-message
"Topic `%s' not found; append to end of buffer?" name))
(org-ctags-append-topic name narrowp)
nil))
(defun org-ctags-rebuild-tags-file-then-find-tag (name)
"This function is intended to be used in ORG-OPEN-LINK-FUNCTIONS.
Like ORG-CTAGS-FIND-TAG, but calls the external ctags program first,
to rebuild (update) the TAGS file."
(unless tags-file-name
(call-interactively #'visit-tags-table))
(when (buffer-file-name)
(org-ctags-create-tags))
(org-ctags-find-tag name))
(defun org-ctags-ask-rebuild-tags-file-then-find-tag (name)
"This function is intended to be used in ORG-OPEN-LINK-FUNCTIONS.
Wrapper for org-ctags-rebuild-tags-file-then-find-tag."
(if (and (buffer-file-name)
(y-or-n-p
(format-message
"Tag `%s' not found. Rebuild table `%s/TAGS' and look again?"
name
(file-name-directory (buffer-file-name)))))
(org-ctags-rebuild-tags-file-then-find-tag name)
nil))
(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."
t)
;;; User-visible functions ===================================================
(defun org-ctags-create-tags (&optional directory-name)
"(Re)create tags file in the directory of the active buffer.
The file will contain tag definitions for all the files in the
directory and its subdirectories which are recognized by ctags.
This will include files ending in `.org' as well as most other
source files (.C, .H, .EL, .LISP, etc). All the resulting tags
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)
(cl-assert (buffer-file-name))
(let ((dir-name (shell-quote-argument
(expand-file-name
(if directory-name
(file-name-as-directory directory-name)
(file-name-directory (buffer-file-name))))))
(exitcode nil))
(save-excursion
(setq exitcode
(shell-command
(format (concat "%s --langdef=orgmode --langmap=orgmode:.org "
"--regex-orgmode=%s -f %sTAGS -e -R %s*")
org-ctags-path-to-ctags
(shell-quote-argument org-ctags-tag-regexp)
dir-name
dir-name)))
(cond
((eql 0 exitcode)
(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
;;(error "Calling ctags executable resulted in error code: %s"
;; exitcode)
nil)))))
(defvar org-ctags-find-tag-history nil
"History of tags visited by org-ctags-find-tag-interactive.")
(defun org-ctags-find-tag-interactive ()
"Prompt for the name of a tag, with autocompletion, then visit the named tag.
If the user enters a string that does not match an existing tag, create
a new topic."
(interactive)
(let* ((tag (completing-read "Topic: " org-ctags-tag-list
nil 'confirm nil 'org-ctags-find-tag-history)))
(when tag
(cond
((member tag org-ctags-tag-list)
;; Existing tag
(push tag org-ctags-find-tag-history)
(xref-find-definitions tag))
(t
;; New tag
(run-hook-with-args-until-success
'org-open-link-functions tag))))))
(provide 'org-ctags)
;;; org-ctags.el ends here
org-mode-9.7.29+dfsg/lisp/org-cycle.el 0000664 0000000 0000000 00000104036 15004304337 0017432 0 ustar 00root root 0000000 0000000 ;;; org-cycle.el --- Visibility cycling of Org entries -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2020-2025 Free Software Foundation, Inc.
;;
;; Maintainer: Ihor Radchenko
;; Keywords: folding, visibility cycling, invisible text
;; URL: https://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 \
Use `\\[org-edit-special]' to edit table.el tables"))
(org-table-justify-field-maybe)
(call-interactively #'org-table-next-field)))
((run-hook-with-args-until-success
'org-tab-after-check-for-table-hook))
;; At an item/headline: delegate to `org-cycle-internal-local'.
((and (or (and org-cycle-include-plain-lists
(let ((item (org-element-lineage element
'(item plain-list)
t)))
(and item
(= (line-beginning-position)
(org-element-post-affiliated
item)))))
(org-match-line org-outline-regexp))
(or (bolp) (not (eq org-cycle-emulate-tab 'exc-hl-bol))))
(org-cycle-internal-local))
;; From there: TAB emulation and template completion.
(buffer-read-only (org-back-to-heading))
((run-hook-with-args-until-success
'org-tab-after-check-for-cycling-hook))
((run-hook-with-args-until-success
'org-tab-before-tab-emulation-hook))
((and (eq org-cycle-emulate-tab 'exc-hl-bol)
(or (not (bolp))
(not (looking-at org-outline-regexp))))
(call-interactively (global-key-binding (kbd "TAB"))))
((or (eq org-cycle-emulate-tab t)
(and (memq org-cycle-emulate-tab '(white whitestart))
(save-excursion (forward-line 0) (looking-at "[ \t]*"))
(or (and (eq org-cycle-emulate-tab 'white)
(= (match-end 0) (line-end-position)))
(and (eq org-cycle-emulate-tab 'whitestart)
(>= (match-end 0) pos)))))
(call-interactively (global-key-binding (kbd "TAB"))))
(t
(save-excursion
(org-back-to-heading)
(org-cycle))))))))))
(defun org-cycle-force-archived ()
"Cycle subtree even if it is archived."
(interactive)
(setq this-command 'org-cycle)
(let ((org-cycle-open-archived-trees t))
(call-interactively 'org-cycle)))
(defun org-cycle-internal-global ()
"Do the global cycling action."
;; Hack to avoid display of messages for .org attachments in Gnus
(let ((ga (string-match-p "\\*fontification" (buffer-name))))
(cond
((and (eq last-command this-command)
(eq org-cycle-global-status 'overview))
;; We just created the overview - now do table of contents
;; This can be slow in very large buffers, so indicate action
(run-hook-with-args 'org-cycle-pre-hook 'contents)
(unless ga (org-unlogged-message "CONTENTS..."))
(org-cycle-content)
(unless ga (org-unlogged-message "CONTENTS...done"))
(setq org-cycle-global-status 'contents)
(run-hook-with-args 'org-cycle-hook 'contents))
((and (eq last-command this-command)
(eq org-cycle-global-status 'contents))
;; We just showed the table of contents - now show everything
(run-hook-with-args 'org-cycle-pre-hook 'all)
(org-fold-show-all '(headings blocks))
(unless ga (org-unlogged-message "SHOW ALL"))
(setq org-cycle-global-status 'all)
(run-hook-with-args 'org-cycle-hook 'all))
(t
;; Default action: go to overview
(run-hook-with-args 'org-cycle-pre-hook 'overview)
(org-cycle-overview)
(unless ga (org-unlogged-message "OVERVIEW"))
(setq org-cycle-global-status 'overview)
(run-hook-with-args 'org-cycle-hook 'overview)))))
(defun org-cycle-internal-local ()
"Do the local cycling action."
(let ((goal-column 0) eoh eol eos has-children children-skipped struct)
;; First, determine end of headline (EOH), end of subtree or item
;; (EOS), and if item or heading has children (HAS-CHILDREN).
(save-excursion
(if (org-at-item-p)
(progn
(forward-line 0)
(setq struct (org-list-struct))
(setq eoh (line-end-position))
(setq eos (org-list-get-item-end-before-blank (point) struct))
(setq has-children (org-list-has-child-p (point) struct)))
(org-back-to-heading)
(setq eoh (save-excursion (outline-end-of-heading) (point)))
(setq eos (save-excursion
(org-end-of-subtree t t)
(unless (eobp) (forward-char -1))
(point)))
(setq has-children
(or
(save-excursion
(let ((level (funcall outline-level)))
(outline-next-heading)
(and (org-at-heading-p)
(> (funcall outline-level) level))))
(and (eq org-cycle-include-plain-lists 'integrate)
(save-excursion
(org-list-search-forward (org-item-beginning-re) eos t))))))
;; Determine end invisible part of buffer (EOL)
(forward-line 1)
(if (eq org-fold-core-style 'text-properties)
(while (and (not (eobp)) ;this is like `next-line'
(org-fold-folded-p (1- (point))))
(goto-char (org-fold-next-visibility-change nil nil t))
(and (eolp) (forward-line 1)))
(while (and (not (eobp)) ;this is like `next-line'
(get-char-property (1- (point)) 'invisible))
(goto-char (next-single-char-property-change (point) 'invisible))
(and (eolp) (forward-line 1))))
(setq eol (point)))
;; Find out what to do next and set `this-command'
(cond
((= eos eoh)
;; Nothing is hidden behind this heading
(unless (org-before-first-heading-p)
(run-hook-with-args 'org-cycle-pre-hook 'empty))
(org-unlogged-message "EMPTY ENTRY")
(setq org-cycle-subtree-status nil)
(save-excursion
(goto-char eos)
(org-with-limited-levels
(outline-next-heading))
(when (org-invisible-p) (org-fold-heading nil))))
((and (or (>= eol eos)
(save-excursion (goto-char eol) (skip-chars-forward "[:space:]" eos) (= (point) eos)))
(or has-children
(not (setq children-skipped
org-cycle-skip-children-state-if-no-children))))
;; Entire subtree is hidden in one line: children view
(unless (org-before-first-heading-p)
(org-with-limited-levels
(run-hook-with-args 'org-cycle-pre-hook 'children)))
(if (org-at-item-p)
(org-list-set-item-visibility (line-beginning-position) struct 'children)
(org-fold-show-entry)
(org-with-limited-levels (org-fold-show-children))
(org-fold-show-set-visibility 'tree)
;; Fold every list in subtree to top-level items.
(when (eq org-cycle-include-plain-lists 'integrate)
(save-excursion
(org-back-to-heading)
(while (org-list-search-forward (org-item-beginning-re) eos t)
(forward-line 0)
(let* ((struct (org-list-struct))
(prevs (org-list-prevs-alist struct))
(end (org-list-get-bottom-point struct)))
(dolist (e (org-list-get-all-items (point) struct prevs))
(org-list-set-item-visibility e struct 'folded))
(goto-char (if (< end eos) end eos)))))))
(org-unlogged-message "CHILDREN")
(save-excursion
(goto-char eos)
(org-with-limited-levels
(outline-next-heading))
(when (and
;; Subtree does not end at the end of visible section of the
;; buffer.
(< (point) (point-max))
(org-invisible-p))
;; Reveal the following heading line.
(org-fold-heading nil)))
(setq org-cycle-subtree-status 'children)
(unless (org-before-first-heading-p)
(run-hook-with-args 'org-cycle-hook 'children)))
((or children-skipped
(and (eq last-command this-command)
(eq org-cycle-subtree-status 'children)))
;; We just showed the children, or no children are there,
;; now show everything.
(unless (org-before-first-heading-p)
(run-hook-with-args 'org-pre-cycle-hook 'subtree))
(org-fold-region eoh eos nil 'outline)
(org-unlogged-message
(if children-skipped "SUBTREE (NO CHILDREN)" "SUBTREE"))
(setq org-cycle-subtree-status 'subtree)
(unless (org-before-first-heading-p)
(run-hook-with-args 'org-cycle-hook 'subtree)))
(t
;; Default action: hide the subtree.
(run-hook-with-args 'org-cycle-pre-hook 'folded)
(org-fold-region eoh eos t 'outline)
(org-unlogged-message "FOLDED")
(setq org-cycle-subtree-status 'folded)
(unless (org-before-first-heading-p)
(run-hook-with-args 'org-cycle-hook 'folded))))))
;;;###autoload
(defun org-cycle-global (&optional arg)
"Cycle the global visibility. For details see `org-cycle'.
With `\\[universal-argument]' prefix ARG, switch to startup visibility.
With a numeric prefix, show all headlines up to that level."
(interactive "P")
(cond
((integerp arg)
(org-cycle-content arg)
(setq org-cycle-global-status 'contents))
((equal arg '(4))
(org-cycle-set-startup-visibility)
(org-unlogged-message "Startup visibility, plus VISIBILITY properties."))
(t
(org-cycle '(4)))))
(defun org-cycle-set-startup-visibility ()
"Set the visibility required by startup options and properties."
(cond
;; `fold' is technically not allowed value, but it is often
;; intuitively tried by users by analogy with #+STARTUP: fold.
((memq org-startup-folded '(t fold overview))
(org-cycle-overview))
((eq org-startup-folded 'content)
(org-cycle-content))
((eq org-startup-folded 'show2levels)
(org-cycle-content 2))
((eq org-startup-folded 'show3levels)
(org-cycle-content 3))
((eq org-startup-folded 'show4levels)
(org-cycle-content 4))
((eq org-startup-folded 'show5levels)
(org-cycle-content 5))
;; `nofold' and `showall' are technically not allowed values, but
;; they are often intuitively tried by users by analogy with
;; #+STARTUP: nofold or #STARTUP: showall.
((memq org-startup-folded '(showeverything nil nofold showall))
(org-fold-show-all)))
(unless (eq org-startup-folded 'showeverything)
(when org-cycle-hide-block-startup (org-fold-hide-block-all))
(org-cycle-set-visibility-according-to-property)
(org-cycle-hide-archived-subtrees 'all)
(when org-cycle-hide-drawer-startup (org-cycle-hide-drawers 'all))
(org-cycle-show-empty-lines t)))
(defun org-cycle-set-visibility-according-to-property ()
"Switch subtree visibility according to VISIBILITY property."
(interactive)
(let ((regexp (org-re-property "VISIBILITY")))
(save-excursion
(goto-char (point-min))
(while (re-search-forward regexp nil t)
(let ((state (match-string 3)))
(if (not (org-at-property-p)) (outline-next-heading)
(save-excursion
(org-back-to-heading t)
(org-fold-subtree t)
(pcase state
("folded"
(org-fold-subtree t))
("children"
(org-fold-show-hidden-entry)
(org-fold-show-children))
("content"
;; Newline before heading will be outside the
;; narrowing. Make sure that it is revealed.
(org-fold-heading nil)
(save-excursion
(save-restriction
(org-narrow-to-subtree)
(org-cycle-content))))
((or "all" "showall")
(org-fold-show-subtree))
(_ nil)))))))))
(defun org-cycle-overview ()
"Switch to overview mode, showing only top-level headlines."
(interactive)
(save-excursion
(goto-char (point-min))
;; Hide top-level drawer.
(save-restriction
(narrow-to-region (point-min) (or (re-search-forward org-outline-regexp-bol nil t) (point-max)))
(org-fold-hide-drawer-all))
(goto-char (point-min))
(when (re-search-forward org-outline-regexp-bol nil t)
(let* ((last (line-end-position))
(level (- (match-end 0) (match-beginning 0) 1))
(regexp (format "^\\*\\{1,%d\\} " level)))
(while (re-search-forward regexp nil :move)
(org-fold-region last (line-end-position 0) t 'outline)
(setq last (line-end-position))
(setq level (- (match-end 0) (match-beginning 0) 1))
(setq regexp (format "^\\*\\{1,%d\\} " level)))
(org-fold-region last (point) t 'outline)))))
(defun org-cycle-content (&optional arg)
"Show all headlines in the buffer, like a table of contents.
With numerical argument ARG, show content up to level ARG."
(interactive "p")
(org-fold-show-all '(headings))
(save-excursion
(goto-char (point-min))
;; Hide top-level drawer.
(save-restriction
(narrow-to-region (point-min) (or (re-search-forward org-outline-regexp-bol nil t) (point-max)))
(org-fold-hide-drawer-all))
(goto-char (point-max))
(let ((regexp (if (and (wholenump arg) (> arg 0))
(format "^\\*\\{1,%d\\} " arg)
"^\\*+ "))
(last (point)))
(while (re-search-backward regexp nil t)
(org-fold-region (line-end-position) last t 'outline)
(setq last (line-end-position 0))))))
(defvar org-cycle-scroll-position-to-restore nil
"Temporarily store scroll position to restore.")
(defun org-cycle-optimize-window-after-visibility-change (state)
"Adjust the window after a change in outline visibility.
This function is the default value of the hook `org-cycle-hook'.
STATE is the current outline visibility state. It should be one of
symbols `content', `all', `folded', `children', or `subtree'."
(when (get-buffer-window (current-buffer))
(let ((repeat (eq last-command this-command)))
(unless repeat
(setq org-cycle-scroll-position-to-restore nil))
(cond
((eq state 'content) nil)
((eq state 'all) nil)
((and org-cycle-scroll-position-to-restore repeat
(eq state 'folded))
(set-window-start nil org-cycle-scroll-position-to-restore))
((eq state 'folded) nil)
((eq state 'children)
(setq org-cycle-scroll-position-to-restore (window-start))
(or (org-subtree-end-visible-p) (recenter 1)))
((eq state 'subtree)
(unless repeat
(setq org-cycle-scroll-position-to-restore (window-start)))
(or (org-subtree-end-visible-p) (recenter 1)))))))
(defun org-cycle-show-empty-lines (state)
"Show empty lines above all visible headlines.
The region to be covered depends on STATE when called through
`org-cycle-hook'. Lisp program can use t for STATE to get the
entire buffer covered. Note that an empty line is only shown if there
are at least `org-cycle-separator-lines' empty lines before the headline."
(when (/= org-cycle-separator-lines 0)
(save-excursion
(let* ((n (abs org-cycle-separator-lines))
(re (cond
((= n 1) "\\(\n[ \t]*\n\\*+\\) ")
((= n 2) "^[ \t]*\\(\n[ \t]*\n\\*+\\) ")
(t (let ((ns (number-to-string (- n 2))))
(concat "^\\(?:[ \t]*\n\\)\\{" ns "," ns "\\}"
"[ \t]*\\(\n[ \t]*\n\\*+\\) ")))))
beg end)
(cond
((memq state '(overview contents t))
(setq beg (point-min) end (point-max)))
((memq state '(children folded))
(setq beg (point)
end (progn (org-end-of-subtree t t)
(line-beginning-position 2)))))
(when beg
(goto-char beg)
(while (re-search-forward re end t)
(unless (org-invisible-p (match-end 1))
(let ((e (match-end 1))
(b (if (>= org-cycle-separator-lines 0)
(match-beginning 1)
(save-excursion
(goto-char (match-beginning 0))
(skip-chars-backward " \t\n")
(line-end-position)))))
(org-fold-region b e nil 'outline))))))))
;; Never hide empty lines at the end of the file.
(save-excursion
(goto-char (point-max))
(outline-previous-heading)
(outline-end-of-heading)
(when (and (looking-at "[ \t\n]+")
(= (match-end 0) (point-max)))
(org-fold-region (point) (match-end 0) nil 'outline))))
(defun org-cycle-hide-archived-subtrees (state)
"Re-hide all archived subtrees after a visibility state change.
STATE should be one of the symbols listed in the docstring of
`org-cycle-hook'."
(when (and (not org-cycle-open-archived-trees)
(not (memq state '(overview folded))))
(let ((globalp (memq state '(contents all))))
(if globalp
(org-fold-hide-archived-subtrees (point-min) (point-max))
(org-fold-hide-archived-subtrees
(point)
(save-excursion
(org-end-of-subtree t))))
(when (and (not globalp)
(member org-archive-tag
(org-get-tags nil 'local)))
(message "%s" (substitute-command-keys
"Subtree is archived and stays closed. Use \
`\\[org-cycle-force-archived]' to cycle it anyway."))))))
(defun org-cycle-display-inline-images (state)
"Auto display inline images under subtree when cycling.
It works when `org-cycle-inline-images-display' is non-nil.
STATE is the current outline visibility state. It should be one of
symbols `content', `all', `folded', `children', or `subtree'."
(when org-cycle-inline-images-display
(pcase state
('children
(org-with-wide-buffer
(org-narrow-to-subtree)
;; If has nested headlines, beg,end only from parent headline
;; to first child headline which reference to upper
;; let-binding `org-next-visible-heading'.
(org-display-inline-images
nil nil
(point-min) (progn (org-next-visible-heading 1) (point)))))
('subtree
(org-with-wide-buffer
(org-narrow-to-subtree)
;; If has nested headlines, also inline display images under all sub-headlines.
(org-display-inline-images nil nil (point-min) (point-max))))
('folded
(org-with-wide-buffer
(org-narrow-to-subtree)
(if (numberp (point-max))
(org-remove-inline-images (point-min) (point-max))
(ignore)))))))
(provide 'org-cycle)
;;; org-cycle.el ends here
org-mode-9.7.29+dfsg/lisp/org-datetree.el 0000664 0000000 0000000 00000025423 15004304337 0020132 0 ustar 00root root 0000000 0000000 ;;; org-datetree.el --- Create date entries in a tree -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2025 Free Software Foundation, Inc.
;; Author: Carsten Dominik
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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
;; Keywords: outlines, hypermedia, calendar, text
;; 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
;; Maintainer: Ihor Radchenko
;; Keywords: data, lisp
;; 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
;; Maintainer: Ihor Radchenko
;; Keywords: outlines, hypermedia, calendar, text
;; 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 for details about
;; Org syntax.
;;
;; Lisp-wise, a syntax object can be represented as a list.
;; It follows the pattern (TYPE PROPERTIES CONTENTS), where:
;; TYPE is a symbol describing the object.
;; PROPERTIES is the property list attached to it. See docstring of
;; appropriate parsing function to get an exhaustive list.
;; CONTENTS is a list of syntax objects or raw strings contained
;; in the current object, when applicable.
;;
;; For the whole document, TYPE is `org-data' and PROPERTIES is nil.
;;
;; The first part of this file defines constants for the Org syntax,
;; while the second one provide accessors and setters functions.
;;
;; The next part implements a parser and an interpreter for each
;; element and object type in Org syntax.
;;
;; The following part creates a fully recursive buffer parser. It
;; also provides a tool to map a function to elements or objects
;; matching some criteria in the parse tree. Functions of interest
;; are `org-element-parse-buffer', `org-element-map' and, to a lesser
;; extent, `org-element-parse-secondary-string'.
;;
;; The penultimate part is the cradle of an interpreter for the
;; obtained parse tree: `org-element-interpret-data'.
;;
;; The library ends by furnishing `org-element-at-point' function, and
;; a way to give information about document structure around point
;; with `org-element-context'. A cache mechanism is also provided for
;; these functions.
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'avl-tree)
(require 'ring)
(require 'cl-lib)
(require 'ol)
(require 'org)
(require 'org-persist)
(require 'org-compat)
(require 'org-entities)
(require 'org-footnote)
(require 'org-list)
(require 'org-macs)
(require 'org-table)
(require 'org-fold-core)
(declare-function org-at-heading-p "org" (&optional _))
(declare-function org-escape-code-in-string "org-src" (s))
(declare-function org-src-preserve-indentation-p "org-src" (&optional node))
(declare-function org-macro-escape-arguments "org-macro" (&rest args))
(declare-function org-macro-extract-arguments "org-macro" (s))
(declare-function org-reduced-level "org" (l))
(declare-function org-unescape-code-in-string "org-src" (s))
(declare-function org-inlinetask-outline-regexp "org-inlinetask" ())
(declare-function outline-next-heading "outline" ())
(declare-function outline-previous-heading "outline" ())
(defvar org-complex-heading-regexp)
(defvar org-done-keywords)
(defvar org-edit-src-content-indentation)
(defvar org-match-substring-regexp)
(defvar org-odd-levels-only)
(defvar org-property-drawer-re)
(defvar org-property-format)
(defvar org-property-re)
(defvar org-tags-column)
(defvar org-todo-regexp)
(defvar org-ts-regexp-both)
;;; Definitions And Rules
;;
;; Define elements, greater elements and specify recursive objects,
;; along with the affiliated keywords recognized. Also set up
;; restrictions on recursive objects combinations.
;;
;; `org-element-update-syntax' builds proper syntax regexps according
;; to current setup.
(defconst org-element-archive-tag "ARCHIVE"
"Tag marking a subtree as archived.")
(defconst org-element-citation-key-re
(rx "@" (group (one-or-more (any word "-.:?!`'/*@+|(){}<>&_^$#%~"))))
"Regexp matching a citation key.
Key is located in match group 1.")
(defconst org-element-citation-prefix-re
(rx "[cite"
(opt "/" (group (one-or-more (any "/_-" alnum)))) ;style
":"
(zero-or-more (any "\t\n ")))
"Regexp matching a citation prefix.
Style, if any, is located in match group 1.")
(defconst org-element-clock-line-re
(let ((duration ; "=> 212:12"
'(seq
(1+ (or ?\t ?\s)) "=>" (1+ (or ?\t ?\s))
(1+ digit) ":" digit digit)))
(rx-to-string
`(seq
line-start (0+ (or ?\t ?\s))
"CLOCK:"
(or
(seq
(1+ (or ?\t ?\s))
(regexp ,org-ts-regexp-inactive)
(opt "--"
(regexp ,org-ts-regexp-inactive)
,duration))
,duration)
(0+ (or ?\t ?\s))
line-end)))
"Regexp matching a clock line.")
(defconst org-element-comment-string "COMMENT"
"String marker for commented headlines.")
(defconst org-element-closed-keyword "CLOSED:"
"Keyword used to close TODO entries.")
(defconst org-element-deadline-keyword "DEADLINE:"
"Keyword used to mark deadline entries.")
(defconst org-element-scheduled-keyword "SCHEDULED:"
"Keyword used to mark scheduled entries.")
(defconst org-element-planning-keywords-re
(regexp-opt (list org-element-closed-keyword
org-element-deadline-keyword
org-element-scheduled-keyword))
"Regexp matching any planning line keyword.")
(defconst org-element-planning-line-re
(rx-to-string
`(seq line-start (0+ (any ?\s ?\t))
(group (regexp ,org-element-planning-keywords-re))))
"Regexp matching a planning line.")
(defconst org-element-drawer-re
(rx line-start (0+ (any ?\s ?\t))
":" (group (1+ (any ?- ?_ word))) ":"
(0+ (any ?\s ?\t)) line-end)
"Regexp matching opening or closing line of a drawer.
Drawer's name is located in match group 1.")
(defconst org-element-drawer-re-nogroup
(rx line-start (0+ (any ?\s ?\t))
":" (1+ (any ?- ?_ word)) ":"
(0+ (any ?\s ?\t)) line-end)
"Regexp matching opening or closing line of a drawer.")
(defconst org-element-dynamic-block-open-re
(rx line-start (0+ (any ?\s ?\t))
"#+BEGIN:" (0+ (any ?\s ?\t))
(group (1+ word))
(opt
(1+ (any ?\s ?\t))
(group (1+ nonl))))
"Regexp matching the opening line of a dynamic block.
Dynamic block's name is located in match group 1.
Parameters are in match group 2.")
(defconst org-element-dynamic-block-open-re-nogroup
(rx line-start (0+ (any ?\s ?\t))
"#+BEGIN:" (0+ (any ?\s ?\t)) word)
"Regexp matching the opening line of a dynamic block.")
(defconst org-element-headline-re
(rx line-start (1+ "*") " ")
"Regexp matching a headline.")
(defvar org-element-paragraph-separate nil
"Regexp to separate paragraphs in an Org buffer.
In the case of lines starting with \"#\" and \":\", this regexp
is not sufficient to know if point is at a paragraph ending. See
`org-element-paragraph-parser' for more information.")
(defvar org-element--object-regexp nil
"Regexp possibly matching the beginning of an object.
This regexp allows false positives. Dedicated parser (e.g.,
`org-element-bold-parser') will take care of further filtering.
Radio links are not matched by this regexp, as they are treated
specially in `org-element--object-lex'.")
(defun org-element--set-regexps ()
"Build variable syntax regexps."
(setq org-element-paragraph-separate
(concat "^\\(?:"
;; Headlines, inlinetasks.
"\\*+ " "\\|"
;; Footnote definitions.
"\\[fn:[-_[:word:]]+\\]" "\\|"
;; Diary sexps.
"%%(" "\\|"
"[ \t]*\\(?:"
;; Empty lines.
"$" "\\|"
;; Tables (any type).
"|" "\\|"
"\\+\\(?:-+\\+\\)+[ \t]*$" "\\|"
;; Comments, keyword-like or block-like constructs.
;; Blocks and keywords with dual values need to be
;; double-checked.
"#\\(?: \\|$\\|\\+\\(?:"
"BEGIN_\\S-+" "\\|"
"\\S-+\\(?:\\[.*\\]\\)?:[ \t]*\\)\\)"
"\\|"
;; Drawers (any type) and fixed-width areas. Drawers
;; need to be double-checked.
":\\(?: \\|$\\|[-_[:word:]]+:[ \t]*$\\)" "\\|"
;; Horizontal rules.
"-\\{5,\\}[ \t]*$" "\\|"
;; LaTeX environments.
"\\\\begin{\\([A-Za-z0-9*]+\\)}" "\\|"
;; Clock lines.
org-element-clock-line-re "\\|"
;; Lists.
(let ((term (pcase org-plain-list-ordered-item-terminator
(?\) ")") (?. "\\.") (_ "[.)]")))
(alpha (and org-list-allow-alphabetical "\\|[A-Za-z]")))
(concat "\\(?:[-+*]\\|\\(?:[0-9]+" alpha "\\)" term "\\)"
"\\(?:[ \t]\\|$\\)"))
"\\)\\)")
org-element--object-regexp
(mapconcat #'identity
(let ((link-types (regexp-opt (org-link-types))))
(list
;; Sub/superscript.
"\\(?:[_^][-{(*+.,[:alnum:]]\\)"
;; Bold, code, italic, strike-through, underline
;; and verbatim.
(rx (or "*" "~" "=" "+" "_" "/") (not space))
;; Plain links.
(concat "\\<" link-types ":")
;; Objects starting with "[": citations,
;; footnote reference, statistics cookie,
;; timestamp (inactive) and regular link.
(format "\\[\\(?:%s\\)"
(mapconcat
#'identity
(list "cite[:/]"
"fn:"
"\\(?:[0-9]\\|\\(?:%\\|/[0-9]*\\)\\]\\)"
"\\[")
"\\|"))
;; Objects starting with "@": export snippets.
"@@"
;; Objects starting with "{": macro.
"{{{"
;; Objects starting with "<" : timestamp
;; (active, diary), target, radio target and
;; angular links.
(concat "<\\(?:%%\\|<\\|[0-9]\\|" link-types "\\)")
;; Objects starting with "$": latex fragment.
"\\$"
;; Objects starting with "\": line break,
;; entity, latex fragment.
"\\\\\\(?:[a-zA-Z[(]\\|\\\\[ \t]*$\\|_ +\\)"
;; Objects starting with raw text: inline Babel
;; source block, inline Babel call.
"\\(?:call\\|src\\)_"))
"\\|")))
(org-element--set-regexps)
;;;###autoload
(defun org-element-update-syntax ()
"Update parser internals."
(interactive)
(org-element--set-regexps)
(org-element-cache-reset 'all))
(defconst org-element-all-elements
'(babel-call center-block clock comment comment-block diary-sexp drawer
dynamic-block example-block export-block fixed-width
footnote-definition headline horizontal-rule inlinetask item
keyword latex-environment node-property paragraph plain-list
planning property-drawer quote-block section
special-block src-block table table-row verse-block)
"Complete list of element types.")
(defconst org-element-greater-elements
'(center-block drawer dynamic-block footnote-definition headline inlinetask
item plain-list property-drawer quote-block section
special-block table org-data)
"List of recursive element types aka Greater Elements.")
(defconst org-element-all-objects
'(bold citation citation-reference code entity export-snippet
footnote-reference inline-babel-call inline-src-block italic line-break
latex-fragment link macro radio-target statistics-cookie strike-through
subscript superscript table-cell target timestamp underline verbatim)
"Complete list of object types.")
(defconst org-element-recursive-objects
'(bold citation footnote-reference italic link subscript radio-target
strike-through superscript table-cell underline)
"List of recursive object types.")
(defconst org-element-object-containers
(append org-element-recursive-objects '(paragraph table-row verse-block))
"List of object or element types that can directly contain objects.")
(defconst org-element-affiliated-keywords
'("CAPTION" "DATA" "HEADER" "HEADERS" "LABEL" "NAME" "PLOT" "RESNAME" "RESULT"
"RESULTS" "SOURCE" "SRCNAME" "TBLNAME")
"List of affiliated keywords as strings.
By default, all keywords setting attributes (e.g., \"ATTR_LATEX\")
are affiliated keywords and need not to be in this list.")
(defconst org-element-keyword-translation-alist
'(("DATA" . "NAME") ("LABEL" . "NAME") ("RESNAME" . "NAME")
("SOURCE" . "NAME") ("SRCNAME" . "NAME") ("TBLNAME" . "NAME")
("RESULT" . "RESULTS") ("HEADERS" . "HEADER"))
"Alist of usual translations for keywords.
The key is the old name and the value the new one. The property
holding their value will be named after the translated name.")
(defconst org-element-multiple-keywords '("CAPTION" "HEADER")
"List of affiliated keywords that can occur more than once in an element.
Their value will be consed into a list of strings, which will be
returned as the value of the property.
This list is checked after translations have been applied. See
`org-element-keyword-translation-alist'.
By default, all keywords setting attributes (e.g., \"ATTR_LATEX\")
allow multiple occurrences and need not to be in this list.")
(defconst org-element-parsed-keywords '("CAPTION")
"List of affiliated keywords whose value can be parsed.
Their value will be stored as a secondary string: a list of
strings and objects.
This list is checked after translations have been applied. See
`org-element-keyword-translation-alist'.")
(defconst org-element--parsed-properties-alist
(mapcar (lambda (k) (cons k (intern (concat ":" (downcase k)))))
org-element-parsed-keywords)
"Alist of parsed keywords and associated properties.
This is generated from `org-element-parsed-keywords', which
see.")
(defconst org-element-dual-keywords '("CAPTION" "RESULTS")
"List of affiliated keywords which can have a secondary value.
In Org syntax, they can be written with optional square brackets
before the colons. For example, RESULTS keyword can be
associated to a hash value with the following:
#+RESULTS[hash-string]: some-source
This list is checked after translations have been applied. See
`org-element-keyword-translation-alist'.")
(defconst org-element--affiliated-re
(format "[ \t]*#\\+\\(?:%s\\):[ \t]*"
(concat
;; Dual affiliated keywords.
(format "\\(?1:%s\\)\\(?:\\[\\(.*\\)\\]\\)?"
(regexp-opt org-element-dual-keywords))
"\\|"
;; Regular affiliated keywords.
(format "\\(?1:%s\\)"
(regexp-opt
(cl-remove-if
(lambda (k) (member k org-element-dual-keywords))
org-element-affiliated-keywords)))
"\\|"
;; Export attributes.
"\\(?1:ATTR_[-_A-Za-z0-9]+\\)"))
"Regexp matching any affiliated keyword.
Keyword name is put in match group 1. Moreover, if keyword
belongs to `org-element-dual-keywords', put the dual value in
match group 2.
Don't modify it, set `org-element-affiliated-keywords' instead.")
(defconst org-element-object-restrictions
(let* ((minimal-set '(bold code entity italic latex-fragment strike-through
subscript superscript underline verbatim))
(standard-set
(remq 'citation-reference (remq 'table-cell org-element-all-objects)))
(standard-set-no-line-break (remq 'line-break standard-set))
(standard-set-for-citations (seq-difference
standard-set-no-line-break
'( citation citation-reference
footnote-reference link))))
`((bold ,@standard-set)
(citation citation-reference)
(citation-reference ,@standard-set-for-citations)
(footnote-reference ,@standard-set)
(headline ,@standard-set-no-line-break)
(inlinetask ,@standard-set-no-line-break)
(italic ,@standard-set)
(item ,@standard-set-no-line-break)
(keyword ,@(remq 'footnote-reference standard-set))
;; Ignore all links in a link description. Also ignore
;; radio-targets and line breaks.
(link export-snippet inline-babel-call inline-src-block macro
statistics-cookie ,@minimal-set)
(paragraph ,@standard-set)
;; Remove any variable object from radio target as it would
;; prevent it from being properly recognized.
(radio-target ,@minimal-set)
(strike-through ,@standard-set)
(subscript ,@standard-set)
(superscript ,@standard-set)
;; Ignore inline babel call and inline source block as formulas
;; are possible. Also ignore line breaks and statistics
;; cookies.
(table-cell citation export-snippet footnote-reference link macro
radio-target target timestamp ,@minimal-set)
(table-row table-cell)
(underline ,@standard-set)
(verse-block ,@standard-set)))
"Alist of objects restrictions.
key is an element or object type containing objects and value is
a list of types that can be contained within an element or object
of such type.
This alist also applies to secondary string. For example, an
`headline' type element doesn't directly contain objects, but
still has an entry since one of its properties (`:title') does.")
(defconst org-element-secondary-value-alist
'((citation :prefix :suffix)
(headline :title)
(inlinetask :title)
(item :tag)
(citation-reference :prefix :suffix))
"Alist between element types and locations of secondary values.")
(defconst org-element--pair-round-table
(let ((table (make-char-table 'syntax-table '(2))))
(modify-syntax-entry ?\( "()" table)
(modify-syntax-entry ?\) ")(" table)
table)
"Table used internally to pair only round brackets.")
(defconst org-element--pair-square-table
(let ((table (make-char-table 'syntax-table '(2))))
(modify-syntax-entry ?\[ "(]" table)
(modify-syntax-entry ?\] ")[" table)
table)
"Table used internally to pair only square brackets.")
(defconst org-element--pair-curly-table
(let ((table (make-char-table 'syntax-table '(2))))
(modify-syntax-entry ?\{ "(}" table)
(modify-syntax-entry ?\} "){" table)
table)
"Table used internally to pair only curly brackets.")
(defun org-element--parse-paired-brackets (char)
"Parse paired brackets at point.
CHAR is the opening bracket to consider, as a character. Return
contents between brackets, as a string, or nil. Also move point
past the brackets."
(when (eq char (char-after))
(let ((syntax-table (pcase char
(?\{ org-element--pair-curly-table)
(?\[ org-element--pair-square-table)
(?\( org-element--pair-round-table)
(_ nil)))
(pos (point)))
(when syntax-table
(with-syntax-table syntax-table
(let ((end (ignore-errors (scan-lists pos 1 0))))
(when end
(goto-char end)
(buffer-substring-no-properties (1+ pos) (1- end)))))))))
(defconst org-element--cache-variables
'( org-element--cache org-element--cache-size
org-element--headline-cache org-element--headline-cache-size
org-element--cache-hash-left org-element--cache-hash-right
org-element--cache-sync-requests org-element--cache-sync-timer
org-element--cache-sync-keys-value org-element--cache-change-tic
org-element--cache-last-buffer-size
org-element--cache-diagnostics-ring
org-element--cache-diagnostics-ring-size
org-element--cache-gapless
org-element--cache-change-warning)
"List of variable symbols holding cache state.")
(defconst org-element-ignored-local-variables
`( org-font-lock-keywords
,@org-element--cache-variables)
"List of variables not copied through upon Org buffer duplication.
Export process and parsing in `org-element-parse-secondary-string'
takes place on a copy of the original buffer. When this copy is
created, all Org related local variables not in this list are copied
to the new buffer. Variables with an unreadable value are also
ignored.")
(cl-defun org-element--generate-copy-script (buffer
&key
copy-unreadable
drop-visibility
drop-narrowing
drop-contents
drop-locals)
"Generate a function duplicating BUFFER.
The copy will preserve local variables, visibility, contents and
narrowing of the original buffer. If a region was active in
BUFFER, contents will be narrowed to that region instead.
When optional key COPY-UNREADABLE is non-nil, do not ensure that all
the copied local variables will be readable in another Emacs session.
When optional keys DROP-VISIBILITY, DROP-NARROWING, DROP-CONTENTS, or
DROP-LOCALS are non-nil, do not preserve visibility, narrowing,
contents, or local variables correspondingly.
The resulting function can be evaluated at a later time, from
another buffer, effectively cloning the original buffer there.
The function assumes BUFFER's major mode is `org-mode'."
(declare-function org-fold-core--update-buffer-folds "org-fold-core" ())
(require 'org-fold-core)
(with-current-buffer buffer
(let ((str (unless drop-contents (org-with-wide-buffer (buffer-string))))
(narrowing
(unless drop-narrowing
(if (org-region-active-p)
(list (region-beginning) (region-end))
(list (point-min) (point-max)))))
(pos (point))
(varvals
(unless drop-locals
(let ((varvals nil))
(dolist (entry (buffer-local-variables (buffer-base-buffer)))
(when (consp entry)
(let ((var (car entry))
(val (cdr entry)))
(and (not (memq var org-element-ignored-local-variables))
(or (memq var
'(default-directory
;; Required to convert file
;; links in the #+INCLUDEd
;; files. See
;; `org-export--prepare-file-contents'.
buffer-file-name
buffer-file-coding-system
;; Needed to preserve folding state
char-property-alias-alist))
(string-match-p "^\\(org-\\|orgtbl-\\)"
(symbol-name var)))
;; Skip unreadable values, as they cannot be
;; sent to external process.
(or copy-unreadable (not val)
(ignore-errors (read (format "%S" val))))
(push (cons var val) varvals)))))
varvals)))
(ols
(unless drop-visibility
(let (ov-set)
(dolist (ov (overlays-in (point-min) (point-max)))
(let ((invis-prop (overlay-get ov 'invisible)))
(when invis-prop
(push (list (overlay-start ov) (overlay-end ov)
(overlay-properties ov))
ov-set))))
ov-set))))
(lambda ()
(let ((inhibit-modification-hooks t))
;; Set major mode. Ignore `org-mode-hook' and other hooks as
;; they have been run already in BUFFER.
(unless (eq major-mode 'org-mode)
(delay-mode-hooks
(let ((org-inhibit-startup t)) (org-mode))))
;; Copy specific buffer local variables.
(pcase-dolist (`(,var . ,val) varvals)
(set (make-local-variable var) val))
;; Whole buffer contents when requested.
(when str
(let ((inhibit-read-only t))
(erase-buffer) (insert str)))
;; Make org-element-cache not complain about changed buffer
;; state.
(org-element-cache-reset nil 'no-persistence)
;; Narrowing.
(when narrowing
(apply #'narrow-to-region narrowing))
;; Current position of point.
(goto-char pos)
;; Overlays with invisible property.
(pcase-dolist (`(,start ,end ,props) ols)
(let ((ov (make-overlay start end)))
(while props
(overlay-put ov (pop props) (pop props)))))
;; Text property folds.
(unless drop-visibility (org-fold-core--update-buffer-folds))
;; Never write the buffer copy to disk, despite
;; `buffer-file-name' not being nil.
(setq write-contents-functions (list (lambda (&rest _) t))))))))
(cl-defun org-element-copy-buffer (&key to-buffer drop-visibility
drop-narrowing drop-contents
drop-locals)
"Return a copy of the current buffer.
The copy preserves Org buffer-local variables, visibility and
narrowing.
IMPORTANT: The buffer copy may also have variable `buffer-file-name'
copied.
To prevent Emacs overwriting the original buffer file,
`write-contents-functions' is set to \\='(always). Do not alter this
variable and do not do anything that might alter it (like calling a
major mode) to prevent data corruption. Also, do note that Emacs may
jump into the created buffer if the original file buffer is closed and
then re-opened. Making edits in the buffer copy may also trigger
Emacs save dialog. Prefer using `org-element-with-buffer-copy' macro
when possible.
When optional key TO-BUFFER is non-nil, copy into BUFFER.
Optional keys DROP-VISIBILITY, DROP-NARROWING, DROP-CONTENTS, and
DROP-LOCALS are passed to `org-element--generate-copy-script'."
(let ((copy-buffer-fun (org-element--generate-copy-script
(current-buffer)
:copy-unreadable 'do-not-check
:drop-visibility drop-visibility
:drop-narrowing drop-narrowing
:drop-contents drop-contents
:drop-locals drop-locals))
(new-buf (or to-buffer (generate-new-buffer (buffer-name)))))
(with-current-buffer new-buf
(funcall copy-buffer-fun)
(set-buffer-modified-p nil))
new-buf))
(cl-defmacro org-element-with-buffer-copy ( &rest body
&key to-buffer drop-visibility
drop-narrowing drop-contents
drop-locals
&allow-other-keys)
"Apply BODY in a copy of the current buffer.
The copy preserves local variables, visibility and contents of
the original buffer. Point is at the beginning of the buffer
when BODY is applied.
Optional keys can modify what is being copied and the generated buffer
copy. TO-BUFFER, DROP-VISIBILITY, DROP-NARROWING, DROP-CONTENTS, and
DROP-LOCALS are passed as arguments to `org-element-copy-buffer'."
(declare (debug t))
;; Drop keyword arguments from BODY.
(while (keywordp (car body)) (pop body) (pop body))
(org-with-gensyms (buf-copy)
`(let ((,buf-copy (org-element-copy-buffer
:to-buffer ,to-buffer
:drop-visibility ,drop-visibility
:drop-narrowing ,drop-narrowing
:drop-contents ,drop-contents
:drop-locals ,drop-locals)))
(unwind-protect
(with-current-buffer ,buf-copy
(goto-char (point-min))
(prog1
(progn ,@body)
;; `org-element-copy-buffer' carried the value of
;; `buffer-file-name' from the original buffer. When not
;; killed, the new buffer copy may become a target of
;; `find-file'. Prevent this.
(setq buffer-file-name nil)))
(and (buffer-live-p ,buf-copy)
;; Kill copy without confirmation.
(progn (with-current-buffer ,buf-copy
(restore-buffer-modified-p nil))
(unless ,to-buffer
(kill-buffer ,buf-copy))))))))
;;; Accessors and Setters
;;
;; Provide four accessors: `org-element-type', `org-element-property'
;; `org-element-contents' and `org-element-restriction'.
;;
;; Setter functions allow modification of elements by side effect.
;; There is `org-element-put-property', `org-element-set-contents'.
;; These low-level functions are useful to build a parse tree.
;;
;; `org-element-adopt', `org-element-set', `org-element-extract' and
;; `org-element-insert-before' are high-level functions useful to
;; modify a parse tree.
;;
;; `org-element-secondary-p' is a predicate used to know if a given
;; object belongs to a secondary string. `org-element-class' tells if
;; some parsed data is an element or an object, handling pseudo
;; elements and objects. `org-element-copy' returns an element or
;; object, stripping its parent property and resolving deferred values
;; in the process.
(require 'org-element-ast)
(defsubst org-element-restriction (element)
"Return restriction associated to ELEMENT.
ELEMENT can be an element, an object or a symbol representing an
element or object type."
(cdr (assq (if (symbolp element) element (org-element-type element))
org-element-object-restrictions)))
(defsubst org-element-class (datum &optional parent)
"Return class for ELEMENT, as a symbol.
Class is either `element' or `object'. Optional argument PARENT
is the element or object containing DATUM. It defaults to the
value of DATUM `:parent' property."
(let ((type (org-element-type datum t))
(parent (or parent (org-element-parent datum))))
(cond
;; Trivial cases.
((memq type org-element-all-objects) 'object)
((memq type org-element-all-elements) 'element)
;; Special cases.
((eq type 'org-data) 'element)
((eq type 'plain-text) 'object)
((eq type 'anonymous) 'object)
((not type) nil)
;; Pseudo object or elements. Make a guess about its class.
;; Basically a pseudo object is contained within another object,
;; a secondary string or a container element.
((not parent) 'element)
(t
(let ((parent-type (org-element-type parent t)))
(cond ((eq 'anonymous parent-type) 'object)
((memq parent-type org-element-object-containers) 'object)
((org-element-secondary-p datum) 'object)
(t 'element)))))))
(defsubst org-element-parent-element (object)
"Return first element containing OBJECT or nil.
OBJECT is the object to consider."
(org-element-lineage object org-element-all-elements))
(defsubst org-element-begin (node)
"Get `:begin' property of NODE."
(org-element-property :begin node))
(gv-define-setter org-element-begin (value node)
`(org-element-put-property ,node :begin ,value))
(defsubst org-element-end (node)
"Get `:end' property of NODE."
(org-element-property :end node))
(gv-define-setter org-element-end (value node)
`(org-element-put-property ,node :end ,value))
(defsubst org-element-contents-begin (node)
"Get `:contents-begin' property of NODE."
(org-element-property :contents-begin node))
(gv-define-setter org-element-contents-begin (value node)
`(org-element-put-property ,node :contents-begin ,value))
(defsubst org-element-contents-end (node)
"Get `:contents-end' property of NODE."
(org-element-property :contents-end node))
(gv-define-setter org-element-contents-end (value node)
`(org-element-put-property ,node :contents-end ,value))
(defsubst org-element-post-affiliated (node)
"Get `:post-affiliated' property of NODE."
(org-element-property :post-affiliated node))
(gv-define-setter org-element-post-affiliated (value node)
`(org-element-put-property ,node :post-affiliated ,value))
(defsubst org-element-post-blank (node)
"Get `:post-blank' property of NODE."
(org-element-property :post-blank node))
(gv-define-setter org-element-post-blank (value node)
`(org-element-put-property ,node :post-blank ,value))
(defconst org-element--cache-element-properties
'(:cached
:org-element--cache-sync-key
:buffer)
"List of element properties used internally by cache.")
(defvar org-element--string-cache (make-hash-table :test #'equal)
"Hash table holding tag strings and todo keyword objects.
We use shared string storage to reduce memory footprint of the syntax
tree.")
(defsubst org-element--get-cached-string (string)
"Return cached object equal to STRING.
Return nil if STRING is nil."
(when string
(or (gethash string org-element--string-cache)
(puthash string string org-element--string-cache))))
(defun org-element--substring (element beg-offset end-offset)
"Get substring inside ELEMENT according to BEG-OFFSET and END-OFFSET."
(with-current-buffer (org-element-property :buffer element)
(org-with-wide-buffer
(let ((beg (org-element-begin element)))
(buffer-substring-no-properties
(+ beg beg-offset) (+ beg end-offset))))))
(defun org-element--unescape-substring (element beg-offset end-offset)
"Call `org-element--substring' and unescape the result.
See `org-element--substring' for the meaning of ELEMENT, BEG-OFFSET,
and END-OFFSET."
(org-unescape-code-in-string
(org-element--substring element beg-offset end-offset)))
;;; Greater elements
;;
;; For each greater element type, we define a parser and an
;; interpreter.
;;
;; A parser returns the element or object as the list described above.
;; Most of them accepts no argument. Though, exceptions exist. Hence
;; every element containing a secondary string (see
;; `org-element-secondary-value-alist') will accept an optional
;; argument to toggle parsing of these secondary strings. Moreover,
;; `item' parser requires current list's structure as its first
;; element.
;;
;; An interpreter accepts two arguments: the list representation of
;; the element or object, and its contents. The latter may be nil,
;; depending on the element or object considered. It returns the
;; appropriate Org syntax, as a string.
;;
;; Parsing functions must follow the naming convention:
;; org-element-TYPE-parser, where TYPE is greater element's type, as
;; defined in `org-element-greater-elements'.
;;
;; Similarly, interpreting functions must follow the naming
;; convention: org-element-TYPE-interpreter.
;;
;; With the exception of `headline' and `item' types, greater elements
;; cannot contain other greater elements of their own type.
;;
;; Beside implementing a parser and an interpreter, adding a new
;; greater element requires tweaking `org-element--current-element'.
;; Moreover, the newly defined type must be added to both
;; `org-element-all-elements' and `org-element-greater-elements'.
;;
;; When adding or modifying the parser, please keep in mind the
;; following rules. They are important to keep parser performance
;; optimal.
;;
;; 1. When you can use `looking-at-p' or `string-match-p' instead of
;; `looking-at' or `string-match' and keep match data unmodified,
;; do it.
;; 2. When regexps can be grouped together, avoiding multiple regexp
;; match calls, they should be grouped.
;; 3. When `save-match-data' can be avoided, avoid it.
;; 4. When simpler regexps can be used for analysis, use the simpler
;; regexps.
;; 5. When regexps can be calculated in advance, not dynamically, they
;; should be calculated in advance.
;; 6 Note that it is not an obligation of a given function to preserve
;; match data - `save-match-data' is costly and must be arranged by
;; the caller if necessary.
;;
;; See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=63225
;;;; Center Block
(defun org-element-center-block-parser (limit affiliated)
"Parse a center block.
LIMIT bounds the search. AFFILIATED is a list of which CAR is
the buffer position at the beginning of the first affiliated
keyword and CDR is a plist of affiliated keywords along with
their value.
Return a new syntax node of `center-block' type containing `:begin',
`:end', `:contents-begin', `:contents-end', `:post-blank' and
`:post-affiliated' properties.
Assume point is at the beginning of the block."
(let ((case-fold-search t))
(if (not (save-excursion
(re-search-forward "^[ \t]*#\\+END_CENTER[ \t]*$" limit t)))
;; Incomplete block: parse it as a paragraph.
(org-element-paragraph-parser limit affiliated)
(let ((block-end-line (match-beginning 0)))
(let* ((begin (car affiliated))
(post-affiliated (point))
;; Empty blocks have no contents.
(contents-begin (progn (forward-line)
(and (< (point) block-end-line)
(point))))
(contents-end (and contents-begin block-end-line))
(pos-before-blank (progn (goto-char block-end-line)
(forward-line)
(point)))
(end (save-excursion
(skip-chars-forward " \r\t\n" limit)
(if (eobp) (point) (line-beginning-position)))))
(org-element-create
'center-block
(nconc
(list :begin begin
:end end
:contents-begin contents-begin
:contents-end contents-end
:post-blank (count-lines pos-before-blank end)
:post-affiliated post-affiliated)
(cdr affiliated))))))))
(defun org-element-center-block-interpreter (_ contents)
"Interpret a center-block element as Org syntax.
CONTENTS is the contents of the element."
(format "#+begin_center\n%s#+end_center" contents))
;;;; Drawer
(defun org-element-drawer-parser (limit affiliated)
"Parse a drawer.
LIMIT bounds the search. AFFILIATED is a list of which CAR is
the buffer position at the beginning of the first affiliated
keyword and CDR is a plist of affiliated keywords along with
their value.
Return a new syntax node of `drawer' type containing `:drawer-name',
`:begin', `:end', `:contents-begin', `:contents-end', `:post-blank'
and `:post-affiliated' properties.
Assume point is at beginning of drawer."
(let ((case-fold-search t))
(if (not (save-excursion
(goto-char (min limit (line-end-position)))
(re-search-forward "^[ \t]*:END:[ \t]*$" limit t)))
;; Incomplete drawer: parse it as a paragraph.
(org-element-paragraph-parser limit affiliated)
(save-excursion
(let* ((drawer-end-line (match-beginning 0))
(name
(progn
(looking-at org-element-drawer-re)
(org-element--get-cached-string (match-string-no-properties 1))))
(begin (car affiliated))
(post-affiliated (point))
;; Empty drawers have no contents.
(contents-begin (progn (forward-line)
(and (< (point) drawer-end-line)
(point))))
(contents-end (and contents-begin drawer-end-line))
(pos-before-blank (progn (goto-char drawer-end-line)
(forward-line)
(point)))
(end (progn (skip-chars-forward " \r\t\n" limit)
(if (eobp) (point) (line-beginning-position)))))
(org-element-create
'drawer
(nconc
(list :begin begin
:end end
:drawer-name name
:contents-begin contents-begin
:contents-end contents-end
:post-blank (count-lines pos-before-blank end)
:post-affiliated post-affiliated)
(cdr affiliated))))))))
(defun org-element-drawer-interpreter (drawer contents)
"Interpret DRAWER element as Org syntax.
CONTENTS is the contents of the element."
(format ":%s:\n%s:END:"
(org-element-property :drawer-name drawer)
contents))
;;;; Dynamic Block
(defun org-element-dynamic-block-parser (limit affiliated)
"Parse a dynamic block.
LIMIT bounds the search. AFFILIATED is a list of which CAR is
the buffer position at the beginning of the first affiliated
keyword and CDR is a plist of affiliated keywords along with
their value.
Return a new syntax node of `dynamic-block' type containing
`:block-name', `:begin', `:end', `:contents-begin', `:contents-end',
`:arguments', `:post-blank' and `:post-affiliated' properties.
Assume point is at beginning of dynamic block."
(let ((case-fold-search t))
(if (not (save-excursion
(re-search-forward "^[ \t]*#\\+END:?[ \t]*$" limit t)))
;; Incomplete block: parse it as a paragraph.
(org-element-paragraph-parser limit affiliated)
(let ((block-end-line (match-beginning 0)))
(save-excursion
(let* ((name (progn
(looking-at org-element-dynamic-block-open-re)
(org-element--get-cached-string (match-string-no-properties 1))))
(arguments (match-string-no-properties 2))
(begin (car affiliated))
(post-affiliated (point))
;; Empty blocks have no contents.
(contents-begin (progn (forward-line)
(and (< (point) block-end-line)
(point))))
(contents-end (and contents-begin block-end-line))
(pos-before-blank (progn (goto-char block-end-line)
(forward-line)
(point)))
(end (progn (skip-chars-forward " \r\t\n" limit)
(if (eobp) (point) (line-beginning-position)))))
(org-element-create
'dynamic-block
(nconc
(list :begin begin
:end end
:block-name name
:arguments arguments
:contents-begin contents-begin
:contents-end contents-end
:post-blank (count-lines pos-before-blank end)
:post-affiliated post-affiliated)
(cdr affiliated)))))))))
(defun org-element-dynamic-block-interpreter (dynamic-block contents)
"Interpret DYNAMIC-BLOCK element as Org syntax.
CONTENTS is the contents of the element."
(format "#+begin: %s%s\n%s#+end:"
(org-element-property :block-name dynamic-block)
(let ((args (org-element-property :arguments dynamic-block)))
(if args (concat " " args) ""))
contents))
;;;; Footnote Definition
(defconst org-element--footnote-separator
(concat org-element-headline-re "\\|"
org-footnote-definition-re "\\|"
"^\\([ \t]*\n\\)\\{2,\\}")
"Regexp used as a footnote definition separator.")
(defun org-element-footnote-definition-parser (limit affiliated)
"Parse a footnote definition.
LIMIT bounds the search. AFFILIATED is a list of which CAR is
the buffer position at the beginning of the first affiliated
keyword and CDR is a plist of affiliated keywords along with
their value.
Return a new syntax node of `footnote-definition' type containing
`:label', `:begin' `:end', `:contents-begin', `:contents-end',
`:pre-blank',`:post-blank' and `:post-affiliated' properties.
Assume point is at the beginning of the footnote definition."
(save-excursion
(let* ((label (progn (looking-at org-footnote-definition-re)
(org-element--get-cached-string
(match-string-no-properties 1))))
(begin (car affiliated))
(post-affiliated (point))
(end
(save-excursion
(end-of-line)
(cond
((not
(re-search-forward org-element--footnote-separator limit t))
limit)
((eq ?\[ (char-after (match-beginning 0)))
;; At a new footnote definition, make sure we end
;; before any affiliated keyword above.
(forward-line -1)
(while (and (> (point) post-affiliated)
(looking-at-p org-element--affiliated-re))
(forward-line -1))
(line-beginning-position 2))
((eq ?* (char-after (match-beginning 0))) (match-beginning 0))
(t (skip-chars-forward " \r\t\n" limit)
(if (= limit (point)) limit (line-beginning-position))))))
(pre-blank 0)
(contents-begin
(progn (search-forward "]")
(skip-chars-forward " \r\t\n" end)
(cond ((= (point) end) nil)
((= (line-beginning-position) post-affiliated) (point))
(t
(setq pre-blank
(count-lines (line-beginning-position) begin))
(line-beginning-position)))))
(contents-end
(progn (goto-char end)
(skip-chars-backward " \r\t\n")
(line-beginning-position 2))))
(org-element-create
'footnote-definition
(nconc
(list :label label
:begin begin
:end end
:contents-begin contents-begin
:contents-end (and contents-begin contents-end)
:pre-blank pre-blank
:post-blank (count-lines contents-end end)
:post-affiliated post-affiliated)
(cdr affiliated))))))
(defun org-element-footnote-definition-interpreter (footnote-definition contents)
"Interpret FOOTNOTE-DEFINITION element as Org syntax.
CONTENTS is the contents of the footnote-definition."
(let ((pre-blank
(min (or (org-element-property :pre-blank footnote-definition)
;; 0 is specific to paragraphs at the beginning of
;; the footnote definition, so we use 1 as
;; a fall-back value, which is more universal.
1)
;; Footnote ends after more than two consecutive empty
;; lines: limit ourselves to 2 newline characters.
2)))
(concat (format "[fn:%s]" (org-element-property :label footnote-definition))
(if (= pre-blank 0) (concat " " (org-trim contents))
(concat (make-string pre-blank ?\n) contents)))))
;;;; Headline
(defun org-element--get-node-properties (&optional at-point-p? parent)
"Return node properties for headline or property drawer at point.
The property values a deferred relative to PARENT element.
Upcase property names. It avoids confusion between properties
obtained through property drawer and default properties from the
parser (e.g. `:end' and :END:). Return value is a plist.
When AT-POINT-P? is nil, assume that point as at a headline. Otherwise
parse properties for property drawer at point."
(save-excursion
(let ((begin (or (org-element-begin parent) (point))))
(unless at-point-p?
(forward-line)
(when (looking-at-p org-element-planning-line-re) (forward-line)))
(when (looking-at org-property-drawer-re)
(forward-line)
(let ((end (match-end 0)) properties)
(while (< (line-end-position) end)
(looking-at org-property-re)
(let* ((property-name (concat ":" (upcase (match-string 2))))
(property-name-symbol (intern property-name))
(property-value
(org-element-deferred-create
t #'org-element--substring
(- (match-beginning 3) begin)
(- (match-end 3) begin))))
(cond
((and (plist-member properties property-name-symbol)
(string-match-p "\\+$" property-name))
(let ((val (plist-get properties property-name-symbol)))
(if (listp val)
(setq properties
(plist-put properties
property-name-symbol
(append (plist-get properties property-name-symbol)
(list property-value))))
(plist-put properties property-name-symbol (list val property-value)))))
(t (setq properties (plist-put properties property-name-symbol property-value)))))
(forward-line))
;; Convert list of deferred properties into a single
;; deferred property.
(let ((plist properties) val)
(while plist
(setq val (cadr plist))
(when (and (car-safe val)
(org-element-deferred-p (car val)))
(setcar
(cdr plist)
(org-element-deferred-create-list (cadr plist))))
(setq plist (cddr plist))))
properties)))))
(defun org-element--get-time-properties ()
"Return time properties associated to headline at point.
Return value is a plist."
(save-excursion
(when (progn (forward-line) (looking-at-p org-element-planning-line-re))
(let ((end (line-end-position))
plist)
(while (re-search-forward org-element-planning-keywords-re end t)
(skip-chars-forward " \t")
(let ((keyword (match-string 0))
(time (org-element-timestamp-parser)))
(cond ((equal keyword org-element-scheduled-keyword)
(setq plist (plist-put plist :scheduled time)))
((equal keyword org-element-deadline-keyword)
(setq plist (plist-put plist :deadline time)))
(t (setq plist (plist-put plist :closed time))))))
plist))))
(defun org-element--headline-deferred (element)
"Parse and set extra properties for ELEMENT headline in BUFFER."
(with-current-buffer (org-element-property :buffer element)
(org-with-wide-buffer
;; Update robust boundaries to not
;; include property drawer and planning.
;; Changes there can now invalidate the
;; properties.
(org-element-put-property
element :robust-begin
(let ((contents-begin (org-element-contents-begin element))
(contents-end (org-element-contents-end element)))
(when contents-begin
(progn (goto-char contents-begin)
(when (looking-at-p org-element-planning-line-re)
(forward-line))
(when (looking-at org-property-drawer-re)
(goto-char (match-end 0)))
;; If there is :pre-blank, we
;; need to be careful about
;; robust beginning.
(max (if (< (+ 2 contents-begin) contents-end)
(+ 2 contents-begin)
0)
(point))))))
(org-element-put-property
element :robust-end
(let ((contents-end (org-element-contents-end element))
(robust-begin (org-element-property :robust-begin element)))
(when contents-end
(when (> (- contents-end 2) robust-begin)
(- contents-end 2)))))
(unless (org-element-property :robust-end element)
(org-element-put-property element :robust-begin nil))
(goto-char (org-element-begin element))
(setcar (cdr element)
(nconc
(nth 1 element)
(org-element--get-time-properties)))
(goto-char (org-element-begin element))
(setcar (cdr element)
(nconc
(nth 1 element)
(org-element--get-node-properties nil element)))))
;; Return nil.
nil)
(defun org-element--headline-raw-value (headline beg-offset end-offset)
"Retrieve :raw-value in HEADLINE according to BEG-OFFSET and END-OFFSET."
(org-trim (org-element--substring headline beg-offset end-offset)))
(defun org-element--headline-archivedp (headline)
"Return t when HEADLINE is archived and nil otherwise."
(if (member org-element-archive-tag
(org-element-property :tags headline))
t nil))
(defun org-element--headline-footnote-section-p (headline)
"Return t when HEADLINE is a footnote section and nil otherwise."
(and org-footnote-section
(string= org-footnote-section
(org-element-property :raw-value headline))))
(defconst org-element--headline-comment-re
(concat org-element-comment-string "\\(?: \\|$\\)")
"Regexp matching comment string in a headline.")
(defconst org-element--headline-archivedp
(org-element-deferred-create
nil #'org-element--headline-archivedp)
"Constant holding deferred value for headline `:archivedp' property.")
(defconst org-element--headline-footnote-section-p
(org-element-deferred-create
nil #'org-element--headline-footnote-section-p)
"Constant holding deferred value for headline `:footnote-section-p' property.")
(defconst org-element--headline-raw-value
(org-element-deferred-create-alias :raw-value)
"Constant holding deferred value for headline `:raw-value' property.")
(defun org-element--headline-parse-title (headline raw-secondary-p)
"Resolve title properties of HEADLINE for side effect.
When RAW-SECONDARY-P is non-nil, headline's title will not be
parsed as a secondary string, but as a plain string instead.
Throw `:org-element-deferred-retry' signal at the end."
(with-current-buffer (org-element-property :buffer headline)
(org-with-point-at (org-element-begin headline)
(let* ((begin (point))
(true-level (prog1 (skip-chars-forward "*")
(skip-chars-forward " \t")))
(level (org-reduced-level true-level))
(todo (and org-todo-regexp
(let (case-fold-search) (looking-at (concat org-todo-regexp "\\(?: \\|$\\)")))
(progn (goto-char (match-end 0))
(skip-chars-forward " \t")
(org-element--get-cached-string (match-string-no-properties 1)))))
(todo-type
(and todo (if (member todo org-done-keywords) 'done 'todo)))
(priority (and (looking-at "\\[#.\\][ \t]*")
(progn (goto-char (match-end 0))
(aref (match-string 0) 2))))
(commentedp
(and (let ((case-fold-search nil))
(looking-at org-element--headline-comment-re))
(prog1 t
(goto-char (match-end 0))
(skip-chars-forward " \t"))))
(title-start (point))
(tags (when (re-search-forward
"\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$"
(line-end-position)
'move)
(goto-char (match-beginning 0))
(mapcar #'org-element--get-cached-string
(org-split-string (match-string-no-properties 1) ":"))))
(title-end (point))
(raw-value
(org-element-deferred-create
t #'org-element--headline-raw-value
(- title-start begin) (- title-end begin))))
(org-element-put-property headline :raw-value raw-value)
(org-element-put-property headline :level level)
(org-element-put-property headline :priority priority)
(org-element-put-property headline :tags tags)
(org-element-put-property headline :todo-keyword todo)
(org-element-put-property headline :todo-type todo-type)
(org-element-put-property
headline :footnote-section-p org-element--headline-footnote-section-p)
(org-element-put-property headline :archivedp org-element--headline-archivedp)
(org-element-put-property headline :commentedp commentedp)
(org-element-put-property
headline :title
(if raw-secondary-p
org-element--headline-raw-value
(org-element--parse-objects
(progn (goto-char title-start)
(skip-chars-forward " \t")
(point))
(progn (goto-char title-end)
(skip-chars-backward " \t")
(point))
nil
(org-element-restriction
(org-element-type headline))
headline))))))
(throw :org-element-deferred-retry nil))
(defconst org-element--headline-parse-title-raw
(org-element-deferred-create
t #'org-element--headline-parse-title t)
"Constant holding deferred value for raw headline `:title' property.")
(defconst org-element--headline-parse-title-parse
(org-element-deferred-create
t #'org-element--headline-parse-title nil)
"Constant holding deferred value for parsed headline `:title' property.")
(defconst org-element--headline-deferred
(org-element-deferred-create
t #'org-element--headline-deferred)
"Constant holding deferred value for headline `:deferred' property.")
(defun org-element-headline-parser (&optional _ raw-secondary-p)
"Parse a headline.
Return a new syntax node of `headline' type containing `:raw-value',
`:title', `:begin', `:end', `:pre-blank', `:contents-begin' and
`:contents-end', `:level', `:priority', `:tags', `:todo-keyword',
`:todo-type', `:scheduled', `:deadline', `:closed', `:archivedp',
`:commentedp' `:footnote-section-p', `:post-blank' and
`:post-affiliated' properties.
The plist also contains any property set in the property drawer,
with its name in upper cases and colons added at the
beginning (e.g., `:CUSTOM_ID').
When RAW-SECONDARY-P is non-nil, headline's title will not be
parsed as a secondary string, but as a plain string instead.
Assume point is at beginning of the headline."
(save-excursion
(let* ((deferred-title-prop
(if raw-secondary-p
org-element--headline-parse-title-raw
org-element--headline-parse-title-parse))
(begin (point))
(true-level (skip-chars-forward "*"))
(end
(save-excursion
(if (re-search-forward (org-headline-re true-level) nil t)
(line-beginning-position)
(point-max))))
(contents-begin (save-excursion
(forward-line)
(skip-chars-forward " \r\t\n" end)
(and (/= (point) end) (line-beginning-position))))
(contents-end (and contents-begin end))
(robust-begin
;; If there is :pre-blank, we
;; need to be careful about
;; robust beginning.
(when contents-begin
(when (< (+ 2 contents-begin) contents-end)
(+ 2 contents-begin))))
(robust-end (and robust-begin end)))
(org-element-create
'headline
(list
:begin begin
:end end
:pre-blank
(if (not contents-begin) 0
(1- (count-lines begin contents-begin)))
:contents-begin contents-begin
:contents-end contents-end
:robust-begin robust-begin
:robust-end robust-end
:true-level true-level
:buffer (current-buffer)
:raw-value deferred-title-prop
:title deferred-title-prop
:level deferred-title-prop
:priority deferred-title-prop
:tags deferred-title-prop
:todo-keyword deferred-title-prop
:todo-type deferred-title-prop
:post-blank
(if contents-end
;; Trailing blank lines in org-data, headlines, and
;; sections belong to the containing elements.
0
(1- (count-lines begin end)))
:footnote-section-p deferred-title-prop
:archivedp deferred-title-prop
:commentedp deferred-title-prop
:post-affiliated begin
:secondary (alist-get
'headline
org-element-secondary-value-alist)
:deferred org-element--headline-deferred)))))
(defun org-element-headline-interpreter (headline contents)
"Interpret HEADLINE element as Org syntax.
CONTENTS is the contents of the element."
(let* ((level (org-element-property :level headline))
(todo (org-element-property :todo-keyword headline))
(priority (org-element-property :priority headline))
(title (org-element-interpret-data
(org-element-property :title headline)))
(tags (let ((tag-list (org-element-property :tags headline)))
(and tag-list
(format ":%s:" (mapconcat #'identity tag-list ":")))))
(commentedp (org-element-property :commentedp headline))
(pre-blank (or (org-element-property :pre-blank headline) 0))
(heading
(concat (make-string (if org-odd-levels-only (1- (* level 2)) level)
?*)
(and todo (concat " " todo))
(and commentedp (concat " " org-element-comment-string))
(and priority (format " [#%c]" priority))
" "
(if (and org-footnote-section
(org-element-property :footnote-section-p headline))
org-footnote-section
title))))
(concat
heading
;; Align tags.
(when tags
(cond
((zerop org-tags-column) (format " %s" tags))
((< org-tags-column 0)
(concat
(make-string
(max (- (+ org-tags-column (length heading) (length tags))) 1)
?\s)
tags))
(t
(concat
(make-string (max (- org-tags-column (length heading)) 1) ?\s)
tags))))
(make-string (1+ pre-blank) ?\n)
contents)))
;;;; org-data
(defun org-element--get-category ()
"Return category in current buffer."
(let ((default-category
(cond ((null org-category)
(when (org-with-base-buffer nil
buffer-file-name)
(file-name-sans-extension
(file-name-nondirectory
(org-with-base-buffer nil
buffer-file-name)))))
((symbolp org-category) (symbol-name org-category))
(t org-category)))
category)
;; Search for #+CATEGORY keywords.
(org-with-point-at (point-max)
(while (and (not category)
(re-search-backward "^[ \t]*#\\+CATEGORY:" (point-min) t))
(let ((element (org-element-at-point-no-context)))
(when (org-element-type-p element 'keyword)
(setq category (org-element-property :value element))))))
;; Return.
(or category default-category)))
(defun org-element--get-global-node-properties (data)
"Set node properties associated with the whole Org buffer.
Upcase property names. It avoids confusion between properties
obtained through property drawer and default properties from the
parser (e.g. `:end' and :END:).
Alter DATA by side effect."
(with-current-buffer (org-element-property :buffer data)
(org-with-wide-buffer
(goto-char (point-min))
(org-skip-whitespace)
(forward-line 0)
(while (and (org-at-comment-p) (bolp)) (forward-line))
(let ((props (org-element--get-node-properties t data))
(has-category? nil))
(while props
(org-element-put-property data (car props) (cadr props))
(when (eq (car props) :CATEGORY) (setq has-category? t))
(setq props (cddr props)))
;; CATEGORY not set in top-level property drawer. Go the long way.
(unless has-category?
(org-element-put-property data :CATEGORY (org-element--get-category)))))
;; Return nil.
nil))
(defconst org-element--get-global-node-properties
(org-element-deferred-create
t #'org-element--get-global-node-properties)
"Constant holding `:deferred' property for org-data.")
(defvar org-element-org-data-parser--recurse nil)
(defun org-element-org-data-parser (&optional _)
"Parse org-data.
Return a new syntax node of `org-data' type containing `:begin',
`:contents-begin', `:contents-end', `:end', `:post-blank',
`:post-affiliated', and `:path' properties."
(org-with-wide-buffer
(let* ((begin 1)
(contents-begin (progn
(goto-char 1)
(org-skip-whitespace)
(forward-line 0)
(point)))
(end (point-max))
(contents-end end)
(robust-end contents-end)
(robust-begin (when (and robust-end
(< (+ 2 contents-begin) end))
(or
(org-with-wide-buffer
(goto-char (point-min))
(org-skip-whitespace)
(forward-line 0)
(while (and (org-at-comment-p) (bolp)) (forward-line))
(when (looking-at org-property-drawer-re)
(goto-char (match-end 0))
(min robust-end (point))))
(+ 2 contents-begin)))))
(org-element-create
'org-data
(list :begin begin
:contents-begin contents-begin
:contents-end contents-end
:end end
:robust-begin robust-begin
:robust-end robust-end
;; Trailing blank lines in org-data, headlines, and
;; sections belong to the containing elements.
:post-blank 0
:post-affiliated begin
:path (buffer-file-name)
:mode 'org-data
:buffer (current-buffer)
:deferred org-element--get-global-node-properties)))))
(defun org-element-org-data-interpreter (_ contents)
"Interpret ORG-DATA element as Org syntax.
CONTENTS is the contents of the element."
contents)
;;;; Inlinetask
(defun org-element-inlinetask-parser (limit &optional raw-secondary-p)
"Parse an inline task.
Do not search past LIMIT.
Return a new syntax node of `inlinetask' type containing `:title',
`:begin', `:end', `:pre-blank', `:contents-begin' and `:contents-end',
`:level', `:priority', `:raw-value', `:tags', `:todo-keyword',
`:todo-type', `:scheduled', `:deadline', `:closed', `:post-blank' and
`:post-affiliated' properties.
The plist also contains any property set in the property drawer,
with its name in upper cases and colons added at the
beginning (e.g., `:CUSTOM_ID').
When optional argument RAW-SECONDARY-P is non-nil, inline-task's
title will not be parsed as a secondary string, but as a plain
string instead.
Assume point is at beginning of the inline task."
(save-excursion
(let* ((deferred-title-prop
(if raw-secondary-p
org-element--headline-parse-title-raw
org-element--headline-parse-title-parse))
(begin (point))
(task-end (save-excursion
(forward-line 1)
(and (re-search-forward org-element-headline-re limit t)
(looking-at-p "[ \t]*END[ \t]*$")
(line-beginning-position))))
(contents-begin (and task-end
(< (point) task-end)
(progn
(forward-line)
(skip-chars-forward " \t\n")
(line-beginning-position))))
(contents-end (and contents-begin task-end))
(end (progn (when task-end (goto-char task-end))
(forward-line)
(skip-chars-forward " \r\t\n" limit)
(if (eobp) (point) (line-beginning-position)))))
(org-element-create
'inlinetask
(list
:begin begin
:end end
:pre-blank
(if (not contents-begin) 0
(1- (count-lines begin contents-begin)))
:contents-begin contents-begin
:contents-end contents-end
:buffer (current-buffer)
:raw-value deferred-title-prop
:title deferred-title-prop
:level deferred-title-prop
:priority deferred-title-prop
:tags deferred-title-prop
:todo-keyword deferred-title-prop
:todo-type deferred-title-prop
:archivedp deferred-title-prop
:commentedp deferred-title-prop
:post-blank (1- (count-lines (or task-end begin) end))
:post-affiliated begin
:secondary (alist-get
'inlinetask
org-element-secondary-value-alist)
:deferred
(and task-end org-element--headline-deferred))))))
(defun org-element-inlinetask-interpreter (inlinetask contents)
"Interpret INLINETASK element as Org syntax.
CONTENTS is the contents of inlinetask."
(let* ((level (org-element-property :level inlinetask))
(todo (org-element-property :todo-keyword inlinetask))
(priority (org-element-property :priority inlinetask))
(title (org-element-interpret-data
(org-element-property :title inlinetask)))
(tags (let ((tag-list (org-element-property :tags inlinetask)))
(and tag-list
(format ":%s:" (mapconcat 'identity tag-list ":")))))
(task (concat (make-string level ?*)
(and todo (concat " " todo))
(and priority (format " [#%c]" priority))
(and title (concat " " title)))))
(concat task
;; Align tags.
(when tags
(cond
((zerop org-tags-column) (format " %s" tags))
((< org-tags-column 0)
(concat
(make-string
(max (- (+ org-tags-column (length task) (length tags))) 1)
?\s)
tags))
(t
(concat
(make-string (max (- org-tags-column (length task)) 1) ?\s)
tags))))
;; Prefer degenerate inlinetasks when there are no
;; contents.
(when contents
(concat "\n"
contents
(make-string level ?*) " end")))))
;;;; Item
(defun org-element-item-parser (limit struct &optional raw-secondary-p)
"Parse an item up to LIMIT.
STRUCT is the structure of the plain list.
Return a new syntax node of `item' type containing `:bullet',
`:begin', `:end', `:contents-begin', `:contents-end', `:checkbox',
`:counter', `:tag', `:structure', `:pre-blank', `:post-blank' and
`:post-affiliated' properties.
When optional argument RAW-SECONDARY-P is non-nil, item's tag, if
any, will not be parsed as a secondary string, but as a plain
string instead.
Assume point is at the beginning of the item."
(save-excursion
(forward-line 0)
(looking-at org-list-full-item-re)
(let* ((begin (point))
(bullet (org-element--get-cached-string (match-string-no-properties 1)))
(tag-begin (match-beginning 4))
(tag-end (match-end 4))
(checkbox (let ((box (match-string 3)))
(cond ((equal "[ ]" box) 'off)
((equal "[X]" box) 'on)
((equal "[-]" box) 'trans))))
(end (progn (goto-char (nth 6 (assq (point) struct)))
(min limit
(if (bolp) (point) (line-beginning-position 2)))))
(pre-blank 0)
(contents-begin
(progn
(goto-char
;; Ignore tags in un-ordered lists: they are just
;; a part of item's body.
(if (and (match-beginning 4)
(string-match-p "[.)]" bullet))
(match-beginning 4)
(match-end 0)))
(skip-chars-forward " \r\t\n" end)
(cond ((= (point) end) nil)
;; If first line isn't empty, contents really
;; start at the text after item's meta-data.
((= (line-beginning-position) begin) (point))
(t
(setq pre-blank
(count-lines (line-beginning-position) begin))
(line-beginning-position)))))
(contents-end (and contents-begin
(progn (goto-char end)
(skip-chars-backward " \r\t\n")
(line-beginning-position 2))))
(counter (let ((c (match-string 2)))
(cond
((not c) nil)
((string-match "[A-Za-z]" c)
(- (string-to-char (upcase (match-string-no-properties 0 c)))
64))
((string-match "[0-9]+" c)
(string-to-number (match-string-no-properties 0 c))))))
(item
(org-element-create
'item
(list :bullet bullet
:begin begin
:end end
:contents-begin contents-begin
:contents-end contents-end
:checkbox checkbox
:counter counter
:structure struct
:pre-blank pre-blank
:post-blank (count-lines (or contents-end begin) end)
:post-affiliated begin
:secondary (alist-get
'item
org-element-secondary-value-alist)))))
(org-element-put-property
item :tag
(let ((raw (org-list-get-tag begin struct)))
(when raw
(if raw-secondary-p raw
(org-element--parse-objects
tag-begin tag-end nil
(org-element-restriction 'item)
item))))))))
(defun org-element-item-interpreter (item contents)
"Interpret ITEM element as Org syntax.
CONTENTS is the contents of the element."
(let ((tag (pcase (org-element-property :tag item)
(`nil nil)
(tag (format "%s :: " (org-element-interpret-data tag)))))
(bullet
(org-list-bullet-string
(cond
((not (string-match-p "[0-9a-zA-Z]"
(org-element-property :bullet item))) "- ")
((eq org-plain-list-ordered-item-terminator ?\)) "1)")
(t "1.")))))
(concat
bullet
(pcase (org-element-property :counter item)
(`nil nil)
(counter (format "[@%d] " counter)))
(pcase (org-element-property :checkbox item)
(`on "[X] ")
(`off "[ ] ")
(`trans "[-] ")
(_ nil))
tag
(when contents
(let* ((ind (make-string (if tag 5 (length bullet)) ?\s))
(pre-blank
(min (or (org-element-property :pre-blank item)
;; 0 is specific to paragraphs at the
;; beginning of the item, so we use 1 as
;; a fall-back value, which is more universal.
1)
;; Lists ends after more than two consecutive
;; empty lines: limit ourselves to 2 newline
;; characters.
2))
(contents (replace-regexp-in-string
"\\(^\\)[ \t]*\\S-" ind contents nil nil 1)))
(if (= pre-blank 0) (org-trim contents)
(concat (make-string pre-blank ?\n) contents)))))))
;;;; Plain List
(defun org-element--list-struct (limit)
"Return structure of list at point.
Do not parse past LIMIT.
Internal function. See `org-list-struct' for details."
(let ((case-fold-search t)
(top-ind limit)
(item-re (org-item-re))
(inlinetask-re (and (featurep 'org-inlinetask)
(boundp 'org-inlinetask-min-level)
(boundp 'org-inlinetask-max-level)
(format "^\\*\\{%d,%d\\}+ "
org-inlinetask-min-level
org-inlinetask-max-level)))
items struct)
(save-excursion
(catch :exit
(while t
(cond
;; At limit: end all items.
((>= (point) limit)
(let ((end (progn (skip-chars-backward " \r\t\n")
(line-beginning-position 2))))
(dolist (item items) (setcar (nthcdr 6 item) end)))
(throw :exit (sort (nconc items struct) #'car-less-than-car)))
;; At list end: end all items.
((looking-at-p org-list-end-re)
(dolist (item items) (setcar (nthcdr 6 item) (point)))
(throw :exit (sort (nconc items struct) #'car-less-than-car)))
;; At a new item: end previous sibling.
((looking-at-p item-re)
(let ((ind (save-excursion (skip-chars-forward " \t")
(org-current-text-column))))
(setq top-ind (min top-ind ind))
(while (and items (<= ind (nth 1 (car items))))
(let ((item (pop items)))
(setcar (nthcdr 6 item) (point))
(push item struct)))
(push (progn (looking-at org-list-full-item-re)
(let ((bullet (match-string-no-properties 1)))
(list (point)
ind
bullet
(match-string-no-properties 2) ; counter
(match-string-no-properties 3) ; checkbox
;; Description tag.
(and
(string-match-p "[-+*]" bullet)
(match-string-no-properties 4))
;; Ending position, unknown so far.
nil)))
items))
(forward-line))
;; Skip empty lines.
((looking-at-p "^[ \t]*$") (forward-line))
;; Skip inline tasks and blank lines along the way.
((and inlinetask-re (looking-at-p inlinetask-re))
(forward-line)
(let ((origin (point)))
(when (re-search-forward inlinetask-re limit t)
(if (looking-at-p "END[ \t]*$") (forward-line)
(goto-char origin)))))
;; At some text line. Check if it ends any previous item.
(t
(let ((ind (save-excursion
(skip-chars-forward " \t")
(org-current-text-column)))
(end (save-excursion
(skip-chars-backward " \r\t\n")
(line-beginning-position 2))))
(while (<= ind (nth 1 (car items)))
(let ((item (pop items)))
(setcar (nthcdr 6 item) end)
(push item struct)
(unless items
(throw :exit (sort struct #'car-less-than-car))))))
;; Skip blocks (any type) and drawers contents.
(cond
((and (looking-at "[ \t]*#\\+BEGIN\\(:\\|_\\S-+\\)")
(re-search-forward
(format "^[ \t]*#\\+END%s[ \t]*$" (match-string 1))
limit t)))
((and (looking-at-p org-element-drawer-re)
(re-search-forward "^[ \t]*:END:[ \t]*$" limit t))))
(forward-line))))))))
(defun org-element-plain-list-parser (limit affiliated structure)
"Parse a plain list.
LIMIT bounds the search. AFFILIATED is a list of which CAR is
the buffer position at the beginning of the first affiliated
keyword and CDR is a plist of affiliated keywords along with
their value. STRUCTURE is the structure of the plain list being
parsed.
Return a new syntax node of `plain-list' type containing `:type',
`:begin', `:end', `:contents-begin' and `:contents-end', `:structure',
`:post-blank' and `:post-affiliated' properties.
Assume point is at the beginning of the list."
(save-excursion
(let* ((struct (or structure (org-element--list-struct limit)))
(type (cond ((looking-at-p "[ \t]*[A-Za-z0-9]") 'ordered)
((nth 5 (assq (point) struct)) 'descriptive)
(t 'unordered)))
(contents-begin (point))
(begin (car affiliated))
(contents-end (let* ((item (assq contents-begin struct))
(ind (nth 1 item))
(pos (nth 6 item)))
(while (and (setq item (assq pos struct))
(= (nth 1 item) ind))
(setq pos (nth 6 item)))
pos))
(contents-end (progn (goto-char contents-end)
(skip-chars-backward " \r\t\n")
(if (bolp) (point) (line-beginning-position 2))))
(end (progn (goto-char contents-end)
(skip-chars-forward " \r\t\n" limit)
(if (= (point) limit) limit (line-beginning-position)))))
;; Return value.
(org-element-create
'plain-list
(nconc
(list :type type
:begin begin
:end end
:contents-begin contents-begin
:contents-end contents-end
:structure struct
:post-blank (count-lines contents-end end)
:post-affiliated contents-begin)
(cdr affiliated))))))
(defun org-element-plain-list-interpreter (_ contents)
"Interpret plain-list element as Org syntax.
CONTENTS is the contents of the element."
(org-element-with-buffer-copy
:to-buffer (org-get-buffer-create " *Org parse*" t)
:drop-contents t
:drop-visibility t
:drop-narrowing t
:drop-locals nil
;; Transferring local variables may put the temporary buffer
;; into a read-only state. Make sure we can insert CONTENTS.
(let ((inhibit-read-only t)) (erase-buffer) (insert contents))
(goto-char (point-min))
(org-list-repair)
;; Prevent "Buffer *temp* modified; kill anyway?".
(restore-buffer-modified-p nil)
(buffer-string)))
;;;; Property Drawer
(defun org-element-property-drawer-parser (limit)
"Parse a property drawer.
LIMIT bounds the search.
Return a new syntax node of `property-drawer' type containing
`:begin', `:end', `:contents-begin', `:contents-end', `:post-blank'
and `:post-affiliated' properties.
Assume point is at the beginning of the property drawer."
(save-excursion
(let ((case-fold-search t)
(begin (point))
(contents-begin (line-beginning-position 2)))
(re-search-forward "^[ \t]*:END:[ \t]*$" limit t)
(let ((contents-end (and (> (match-beginning 0) contents-begin)
(match-beginning 0)))
(before-blank (progn (forward-line) (point)))
(end (progn (skip-chars-forward " \r\t\n" limit)
(if (eobp) (point) (line-beginning-position)))))
(org-element-create
'property-drawer
(list :begin begin
:end end
:contents-begin (and contents-end contents-begin)
:contents-end contents-end
:post-blank (count-lines before-blank end)
:post-affiliated begin))))))
(defun org-element-property-drawer-interpreter (_ contents)
"Interpret property-drawer element as Org syntax.
CONTENTS is the properties within the drawer."
(format ":PROPERTIES:\n%s:END:" contents))
;;;; Quote Block
(defun org-element-quote-block-parser (limit affiliated)
"Parse a quote block.
LIMIT bounds the search. AFFILIATED is a list of which CAR is
the buffer position at the beginning of the first affiliated
keyword and CDR is a plist of affiliated keywords along with
their value.
Return a new syntax node of `quote-block' type containing `:begin',
`:end', `:contents-begin', `:contents-end', `:post-blank' and
`:post-affiliated' properties.
Assume point is at the beginning of the block."
(let ((case-fold-search t))
(if (not (save-excursion
(re-search-forward "^[ \t]*#\\+END_QUOTE[ \t]*$" limit t)))
;; Incomplete block: parse it as a paragraph.
(org-element-paragraph-parser limit affiliated)
(let ((block-end-line (match-beginning 0)))
(save-excursion
(let* ((begin (car affiliated))
(post-affiliated (point))
;; Empty blocks have no contents.
(contents-begin (progn (forward-line)
(and (< (point) block-end-line)
(point))))
(contents-end (and contents-begin block-end-line))
(pos-before-blank (progn (goto-char block-end-line)
(forward-line)
(point)))
(end (progn (skip-chars-forward " \r\t\n" limit)
(if (eobp) (point) (line-beginning-position)))))
(org-element-create
'quote-block
(nconc
(list :begin begin
:end end
:contents-begin contents-begin
:contents-end contents-end
:post-blank (count-lines pos-before-blank end)
:post-affiliated post-affiliated)
(cdr affiliated)))))))))
(defun org-element-quote-block-interpreter (_ contents)
"Interpret quote-block element as Org syntax.
CONTENTS is the contents of the element."
(format "#+begin_quote\n%s#+end_quote" contents))
;;;; Section
(defun org-element-section-parser (_)
"Parse a section.
Return a new syntax node of `section' type containing `:begin',
`:end', `:contents-begin', `contents-end', `:post-blank' and
`:post-affiliated' properties."
(save-excursion
;; Beginning of section is the beginning of the first non-blank
;; line after previous headline.
(let* ((begin (point))
(end
(if (re-search-forward (org-get-limited-outline-regexp t) nil 'move)
(goto-char (match-beginning 0))
(point)))
(contents-end end)
(robust-end end)
(robust-begin begin))
(org-element-create
'section
(list :begin begin
:end end
:contents-begin begin
:contents-end contents-end
:robust-begin robust-begin
:robust-end robust-end
;; Trailing blank lines in org-data, headlines, and
;; sections belong to the containing elements.
:post-blank 0
:post-affiliated begin)))))
(defun org-element-section-interpreter (_ contents)
"Interpret section element as Org syntax.
CONTENTS is the contents of the element."
contents)
;;;; Special Block
(defun org-element-special-block-parser (limit affiliated)
"Parse a special block.
LIMIT bounds the search. AFFILIATED is a list of which CAR is
the buffer position at the beginning of the first affiliated
keyword and CDR is a plist of affiliated keywords along with
their value.
Return a new syntax node of `special-block' type containing `:type',
`:parameters', `:begin', `:end', `:contents-begin', `:contents-end',
`:post-blank' and `:post-affiliated' properties.
Assume point is at the beginning of the block."
(let* ((case-fold-search t)
(type (progn (looking-at "[ \t]*#\\+BEGIN_\\(\\S-+\\)[ \t]*\\(.*\\)[ \t]*$")
(org-element--get-cached-string
(match-string-no-properties 1))))
(parameters (match-string-no-properties 2)))
(if (not (save-excursion
(re-search-forward
(format "^[ \t]*#\\+END_%s[ \t]*$" (regexp-quote type))
limit t)))
;; Incomplete block: parse it as a paragraph.
(org-element-paragraph-parser limit affiliated)
(let ((block-end-line (match-beginning 0)))
(save-excursion
(let* ((begin (car affiliated))
(post-affiliated (point))
;; Empty blocks have no contents.
(contents-begin (progn (forward-line)
(and (< (point) block-end-line)
(point))))
(contents-end (and contents-begin block-end-line))
(pos-before-blank (progn (goto-char block-end-line)
(forward-line)
(point)))
(end (progn (skip-chars-forward " \r\t\n" limit)
(if (eobp) (point) (line-beginning-position)))))
(org-element-create
'special-block
(nconc
(list :type type
:parameters (and (org-string-nw-p parameters)
(org-trim parameters))
:begin begin
:end end
:contents-begin contents-begin
:contents-end contents-end
:post-blank (count-lines pos-before-blank end)
:post-affiliated post-affiliated)
(cdr affiliated)))))))))
(defun org-element-special-block-interpreter (special-block contents)
"Interpret SPECIAL-BLOCK element as Org syntax.
CONTENTS is the contents of the element."
(let ((block-type (org-element-property :type special-block))
(parameters (org-element-property :parameters special-block)))
(format "#+begin_%s%s\n%s#+end_%s" block-type
(if parameters (concat " " parameters) "")
(or contents "") block-type)))
;;; Elements
;;
;; For each element, a parser and an interpreter are also defined.
;; Both follow the same naming convention used for greater elements.
;;
;; Also, as for greater elements, adding a new element type is done
;; through the following steps: implement a parser and an interpreter,
;; tweak `org-element--current-element' so that it recognizes the new
;; type and add that new type to `org-element-all-elements'.
;;;; Babel Call
(defun org-element-babel-call-parser (limit affiliated)
"Parse a babel call.
LIMIT bounds the search. AFFILIATED is a list of which car is
the buffer position at the beginning of the first affiliated
keyword and cdr is a plist of affiliated keywords along with
their value.
Return a new syntax node of `babel-call' type containing `:call',
`:inside-header', `:arguments', `:end-header', `:begin', `:end',
`:value', `:post-blank' and `:post-affiliated' as properties."
(save-excursion
(let* ((begin (car affiliated))
(post-affiliated (point))
(before-blank (line-beginning-position 2))
(value (progn (search-forward ":" before-blank t)
(skip-chars-forward " \t")
(org-trim
(buffer-substring-no-properties
(point) (line-end-position)))))
(call
(or (org-string-nw-p
(buffer-substring-no-properties
(point) (progn (skip-chars-forward "^[]()" before-blank)
(point))))))
(inside-header (org-element--parse-paired-brackets ?\[))
(arguments (org-string-nw-p
(org-element--parse-paired-brackets ?\()))
(end-header
(org-string-nw-p
(org-trim
(buffer-substring-no-properties (point) (line-end-position)))))
(end (progn (forward-line)
(skip-chars-forward " \r\t\n" limit)
(if (eobp) (point) (line-beginning-position)))))
(org-element-create
'babel-call
(nconc
(list :call call
:inside-header inside-header
:arguments arguments
:end-header end-header
:begin begin
:end end
:value value
:post-blank (count-lines before-blank end)
:post-affiliated post-affiliated)
(cdr affiliated))))))
(defun org-element-babel-call-interpreter (babel-call _)
"Interpret BABEL-CALL element as Org syntax."
(concat "#+call: "
(org-element-property :call babel-call)
(let ((h (org-element-property :inside-header babel-call)))
(and h (format "[%s]" h)))
(concat "(" (org-element-property :arguments babel-call) ")")
(let ((h (org-element-property :end-header babel-call)))
(and h (concat " " h)))))
;;;; Clock
(defun org-element-clock-parser (limit)
"Parse a clock.
LIMIT bounds the search.
Return a new syntax node of `clock' type containing `:status',
`:value', `:time', `:begin', `:end', `:post-blank' and
`:post-affiliated' as properties."
(save-excursion
(let* ((begin (point))
(value (progn (search-forward "CLOCK:" (line-end-position))
(skip-chars-forward " \t")
(org-element-timestamp-parser)))
(duration (and (search-forward "=> " (line-end-position) t)
(progn (skip-chars-forward " \t")
(looking-at "\\(\\S-+\\)[ \t]*$"))
(match-string-no-properties 1)))
(status (if duration 'closed 'running))
(post-blank (let ((before-blank (progn (forward-line) (point))))
(skip-chars-forward " \r\t\n" limit)
(skip-chars-backward " \t")
(unless (bolp) (skip-chars-forward " \t"))
(count-lines before-blank (point))))
(end (point)))
(org-element-create
'clock
(list :status status
:value value
:duration duration
:begin begin
:end end
:post-blank post-blank
:post-affiliated begin)))))
(defun org-element-clock-interpreter (clock _)
"Interpret CLOCK element as Org syntax."
(concat "CLOCK: "
(org-element-timestamp-interpreter
(org-element-property :value clock) nil)
(let ((duration (org-element-property :duration clock)))
(and duration
(concat " => "
(apply 'format
"%2s:%02s"
(org-split-string duration ":")))))))
;;;; Comment
(defun org-element-comment-parser (limit)
"Parse a comment.
LIMIT bounds the search.
Return a new syntax node of `comment' type containing `:begin',
`:end', `:value', `:post-blank', `:post-affiliated' properties.
Assume point is at comment beginning."
(save-excursion
(let* ((begin (point))
(value (prog2 (looking-at org-comment-regexp)
(buffer-substring-no-properties
(match-end 0) (line-end-position))
(forward-line)))
(com-end
;; Get comments ending.
(progn
(while (and (< (point) limit) (looking-at org-comment-regexp))
;; Accumulate lines without leading hash and first
;; whitespace.
(setq value
(concat value
"\n"
(buffer-substring-no-properties
(match-end 0) (line-end-position))))
(forward-line))
(point)))
(end (progn (goto-char com-end)
(skip-chars-forward " \r\t\n" limit)
(if (eobp) (point) (line-beginning-position)))))
(org-element-create
'comment
(list :begin begin
:end end
:value value
:post-blank (count-lines com-end end)
:post-affiliated begin)))))
(defun org-element-comment-interpreter (comment _)
"Interpret COMMENT element as Org syntax.
CONTENTS is nil."
(replace-regexp-in-string "^" "# " (org-element-property :value comment)))
;;;; Comment Block
(defun org-element-comment-block-parser (limit affiliated)
"Parse an export block.
LIMIT bounds the search. AFFILIATED is a list of which CAR is
the buffer position at the beginning of the first affiliated
keyword and CDR is a plist of affiliated keywords along with
their value.
Return a new syntax node of `comment-block' type containing `:begin',
`:end', `:value', `:post-blank' and `:post-affiliated' properties.
Assume point is at comment block beginning."
(let ((case-fold-search t))
(if (not (save-excursion
(re-search-forward "^[ \t]*#\\+END_COMMENT[ \t]*$" limit t)))
;; Incomplete block: parse it as a paragraph.
(org-element-paragraph-parser limit affiliated)
(let ((contents-end (match-beginning 0)))
(save-excursion
(let* ((begin (car affiliated))
(post-affiliated (point))
(contents-begin (progn (forward-line) (point)))
(pos-before-blank (progn (goto-char contents-end)
(forward-line)
(point)))
(end (progn (skip-chars-forward " \r\t\n" limit)
(if (eobp) (point) (line-beginning-position))))
(value
(org-element-deferred-create
t #'org-element--substring
(- contents-begin begin)
(- contents-end begin))))
(org-element-create
'comment-block
(nconc
(list :begin begin
:end end
:value value
:post-blank (count-lines pos-before-blank end)
:post-affiliated post-affiliated)
(cdr affiliated)))))))))
(defun org-element-comment-block-interpreter (comment-block _)
"Interpret COMMENT-BLOCK element as Org syntax."
(format "#+begin_comment\n%s#+end_comment"
(org-element-normalize-string
(org-remove-indentation
(org-element-property :value comment-block)))))
;;;; Diary Sexp
(defun org-element-diary-sexp-parser (limit affiliated)
"Parse a diary sexp.
LIMIT bounds the search. AFFILIATED is a list of which CAR is
the buffer position at the beginning of the first affiliated
keyword and CDR is a plist of affiliated keywords along with
their value.
Return a new syntax node of `diary-sexp' type containing `:begin',
`:end', `:value', `:post-blank' and `:post-affiliated' properties."
(save-excursion
(let ((begin (car affiliated))
(post-affiliated (point))
(value (progn (looking-at "\\(%%(.*\\)[ \t]*$")
(match-string-no-properties 1)))
(pos-before-blank (progn (forward-line) (point)))
(end (progn (skip-chars-forward " \r\t\n" limit)
(if (eobp) (point) (line-beginning-position)))))
(org-element-create
'diary-sexp
(nconc
(list :value value
:begin begin
:end end
:post-blank (count-lines pos-before-blank end)
:post-affiliated post-affiliated)
(cdr affiliated))))))
(defun org-element-diary-sexp-interpreter (diary-sexp _)
"Interpret DIARY-SEXP as Org syntax."
(org-element-property :value diary-sexp))
;;;; Example Block
(defun org-element-example-block-parser (limit affiliated)
"Parse an example block.
LIMIT bounds the search. AFFILIATED is a list of which CAR is
the buffer position at the beginning of the first affiliated
keyword and CDR is a plist of affiliated keywords along with
their value.
Return a new syntax node of `example-block' type containing `:begin',
`:end', `:number-lines', `:preserve-indent', `:retain-labels',
`:use-labels', `:label-fmt', `:switches', `:value', `:post-blank' and
`:post-affiliated' properties."
(let ((case-fold-search t))
(if (not (save-excursion
(re-search-forward "^[ \t]*#\\+END_EXAMPLE[ \t]*$" limit t)))
;; Incomplete block: parse it as a paragraph.
(org-element-paragraph-parser limit affiliated)
(let ((contents-end (match-beginning 0)))
(save-excursion
(let* ((switches
(progn
(looking-at "^[ \t]*#\\+BEGIN_EXAMPLE\\(?: +\\(.*\\)\\)?")
(match-string-no-properties 1)))
;; Switches analysis.
(number-lines
(and switches
(string-match "\\([-+]\\)n\\(?: *\\([0-9]+\\)\\)?\\>"
switches)
(cons
(if (equal (match-string 1 switches) "-")
'new
'continued)
(if (not (match-end 2)) 0
;; Subtract 1 to give number of lines before
;; first line.
(1- (string-to-number (match-string 2 switches)))))))
(preserve-indent
(and switches (string-match-p "-i\\>" switches)))
;; Should labels be retained in (or stripped from) example
;; blocks?
(retain-labels
(or (not switches)
(not (string-match-p "-r\\>" switches))
(and number-lines (string-match-p "-k\\>" switches))))
;; What should code-references use - labels or
;; line-numbers?
(use-labels
(or (not switches)
(and retain-labels
(not (string-match-p "-k\\>" switches)))))
(label-fmt
(and switches
(string-match "-l +\"\\([^\"\n]+\\)\"" switches)
(match-string-no-properties 1 switches)))
;; Standard block parsing.
(begin (car affiliated))
(post-affiliated (point))
(contents-begin (line-beginning-position 2))
(value
(org-element-deferred-create
t #'org-element--unescape-substring
(- contents-begin begin)
(- contents-end begin)))
(pos-before-blank (progn (goto-char contents-end)
(forward-line)
(point)))
(end (progn (skip-chars-forward " \r\t\n" limit)
(if (eobp) (point) (line-beginning-position)))))
(org-element-create
'example-block
(nconc
(list :begin begin
:end end
:value value
:switches switches
:number-lines number-lines
:preserve-indent preserve-indent
:retain-labels retain-labels
:use-labels use-labels
:label-fmt label-fmt
:post-blank (count-lines pos-before-blank end)
:post-affiliated post-affiliated)
(cdr affiliated)))))))))
(defun org-element-example-block-interpreter (example-block _)
"Interpret EXAMPLE-BLOCK element as Org syntax."
(let ((switches (org-element-property :switches example-block))
(value
(let ((val (org-element-property :value example-block)))
(cond
((org-src-preserve-indentation-p example-block) val)
((= 0 org-edit-src-content-indentation)
(org-remove-indentation val))
(t
(let ((ind (make-string org-edit-src-content-indentation ?\s)))
(replace-regexp-in-string "^[ \t]*\\S-"
(concat ind "\\&")
(org-remove-indentation val))))))))
(concat "#+begin_example" (and switches (concat " " switches)) "\n"
(org-element-normalize-string (org-escape-code-in-string value))
"#+end_example")))
;;;; Export Block
(defun org-element-export-block-parser (limit affiliated)
"Parse an export block.
LIMIT bounds the search. AFFILIATED is a list of which CAR is
the buffer position at the beginning of the first affiliated
keyword and CDR is a plist of affiliated keywords along with
their value.
Return a new syntax node of `export-block' type containing `:begin',
`:end', `:type', `:value', `:post-blank' and `:post-affiliated'
properties.
Assume point is at export-block beginning."
(let* ((case-fold-search t))
(if (not (save-excursion
(re-search-forward "^[ \t]*#\\+END_EXPORT[ \t]*$" limit t)))
;; Incomplete block: parse it as a paragraph.
(org-element-paragraph-parser limit affiliated)
(save-excursion
(let* ((contents-end (match-beginning 0))
(backend
(progn
(looking-at
"[ \t]*#\\+BEGIN_EXPORT\\(?:[ \t]+\\(\\S-+\\)\\)?[ \t]*$")
(match-string-no-properties 1)))
(begin (car affiliated))
(post-affiliated (point))
(contents-begin (progn (forward-line) (point)))
(pos-before-blank (progn (goto-char contents-end)
(forward-line)
(point)))
(end (progn (skip-chars-forward " \r\t\n" limit)
(if (eobp) (point) (line-beginning-position))))
(value
(org-element-deferred-create
t #'org-element--unescape-substring
(- contents-begin begin)
(- contents-end begin))))
(org-element-create
'export-block
(nconc
(list :type (and backend (upcase backend))
:begin begin
:end end
:value value
:post-blank (count-lines pos-before-blank end)
:post-affiliated post-affiliated)
(cdr affiliated))))))))
(defun org-element-export-block-interpreter (export-block _)
"Interpret EXPORT-BLOCK element as Org syntax."
(format "#+begin_export %s\n%s#+end_export"
(org-element-property :type export-block)
(org-element-property :value export-block)))
;;;; Fixed-width
(defun org-element-fixed-width-parser (limit affiliated)
"Parse a fixed-width section.
LIMIT bounds the search. AFFILIATED is a list of which CAR is
the buffer position at the beginning of the first affiliated
keyword and CDR is a plist of affiliated keywords along with
their value.
Return a new syntax node of `fixed-width' type containing `:begin',
`:end', `:value', `:post-blank' and `:post-affiliated' properties.
Assume point is at the beginning of the fixed-width area."
(save-excursion
(let* ((begin (car affiliated))
(post-affiliated (point))
(end-area
(progn
(while (and (< (point) limit)
(looking-at-p "[ \t]*:\\( \\|$\\)"))
(forward-line))
(if (bolp) (line-end-position 0) (point))))
(end (progn (skip-chars-forward " \r\t\n" limit)
(if (eobp) (point) (line-beginning-position)))))
(org-element-create
'fixed-width
(nconc
(list :begin begin
:end end
:value (replace-regexp-in-string
"^[ \t]*: ?" ""
(buffer-substring-no-properties post-affiliated
end-area))
:post-blank (count-lines end-area end)
:post-affiliated post-affiliated)
(cdr affiliated))))))
(defun org-element-fixed-width-interpreter (fixed-width _)
"Interpret FIXED-WIDTH element as Org syntax."
(let ((value (org-element-property :value fixed-width)))
(and value
(if (string-empty-p value) ":\n"
(replace-regexp-in-string "^" ": " value)))))
;;;; Horizontal Rule
(defun org-element-horizontal-rule-parser (limit affiliated)
"Parse an horizontal rule.
LIMIT bounds the search. AFFILIATED is a list of which CAR is
the buffer position at the beginning of the first affiliated
keyword and CDR is a plist of affiliated keywords along with
their value.
Return a new syntax node of `horizontal-rule' type containing
`:begin', `:end', `:post-blank' and `:post-affiliated' properties."
(save-excursion
(let ((begin (car affiliated))
(post-affiliated (point))
(post-hr (progn (forward-line) (point)))
(end (progn (skip-chars-forward " \r\t\n" limit)
(if (eobp) (point) (line-beginning-position)))))
(org-element-create
'horizontal-rule
(nconc
(list :begin begin
:end end
:post-blank (count-lines post-hr end)
:post-affiliated post-affiliated)
(cdr affiliated))))))
(defun org-element-horizontal-rule-interpreter (&rest _)
"Interpret HORIZONTAL-RULE element as Org syntax."
"-----")
;;;; Keyword
(defun org-element-keyword-parser (limit affiliated)
"Parse a keyword at point.
LIMIT bounds the search. AFFILIATED is a list of which CAR is
the buffer position at the beginning of the first affiliated
keyword and CDR is a plist of affiliated keywords along with
their value.
Return a new syntax node of `keyword' type containing `:key',
`:value', `:begin', `:end', `:post-blank' and `:post-affiliated'
properties."
(save-excursion
;; An orphaned affiliated keyword is considered as a regular
;; keyword. In this case AFFILIATED is nil, so we take care of
;; this corner case.
(let ((begin (or (car affiliated) (point)))
(post-affiliated (point))
(key (progn (looking-at "[ \t]*#\\+\\(\\S-*\\):")
(org-element--get-cached-string
(upcase (match-string-no-properties 1)))))
(value (org-trim (buffer-substring-no-properties
(match-end 0) (line-end-position))))
(pos-before-blank (progn (forward-line) (point)))
(end (progn (skip-chars-forward " \r\t\n" limit)
(if (eobp) (point) (line-beginning-position)))))
(org-element-create
'keyword
(nconc
(list :key key
:value value
:begin begin
:end end
:post-blank (count-lines pos-before-blank end)
:post-affiliated post-affiliated)
(cdr affiliated))))))
(defun org-element-keyword-interpreter (keyword _)
"Interpret KEYWORD element as Org syntax."
(format "#+%s: %s"
(downcase (org-element-property :key keyword))
(org-element-property :value keyword)))
;;;; LaTeX Environment
(defconst org-element--latex-begin-environment
"^[ \t]*\\\\begin{\\([A-Za-z0-9*]+\\)}"
"Regexp matching the beginning of a LaTeX environment.
The environment is captured by the first group.
See also `org-element--latex-end-environment'.")
(defconst org-element--latex-begin-environment-nogroup
"^[ \t]*\\\\begin{[A-Za-z0-9*]+}"
"Regexp matching the beginning of a LaTeX environment.")
(defconst org-element--latex-end-environment
"\\\\end{%s}[ \t]*$"
"Format string matching the ending of a LaTeX environment.
See also `org-element--latex-begin-environment'.")
(defun org-element-latex-environment-parser (limit affiliated)
"Parse a LaTeX environment.
LIMIT bounds the search. AFFILIATED is a list of which CAR is
the buffer position at the beginning of the first affiliated
keyword and CDR is a plist of affiliated keywords along with
their value.
Return a new syntax node of `latex-environment' type containing
`:begin', `:end', `:value', `:post-blank' and `:post-affiliated'
properties.
Assume point is at the beginning of the latex environment."
(save-excursion
(let ((case-fold-search t)
(code-begin (point)))
(looking-at org-element--latex-begin-environment)
(if (not (re-search-forward (format org-element--latex-end-environment
(regexp-quote (match-string 1)))
limit t))
;; Incomplete latex environment: parse it as a paragraph.
(org-element-paragraph-parser limit affiliated)
(let* ((code-end (progn (forward-line) (point)))
(begin (car affiliated))
(value
(org-element-deferred-create
t #'org-element--substring
(- code-begin begin)
(- code-end begin)))
(end (progn (skip-chars-forward " \r\t\n" limit)
(if (eobp) (point) (line-beginning-position)))))
(org-element-create
'latex-environment
(nconc
(list :begin begin
:end end
:value value
:post-blank (count-lines code-end end)
:post-affiliated code-begin)
(cdr affiliated))))))))
(defun org-element-latex-environment-interpreter (latex-environment _)
"Interpret LATEX-ENVIRONMENT element as Org syntax."
(org-element-property :value latex-environment))
;;;; Node Property
(defun org-element-node-property-parser (_)
"Parse a node-property at point.
Return a new syntax node of `node-property' type containing `:key',
`:value', `:begin', `:end', `:post-blank' and `:post-affiliated'
properties."
(looking-at org-property-re)
(let ((begin (point))
(key (org-element--get-cached-string
(match-string-no-properties 2)))
(value (match-string-no-properties 3))
(end (min (point-max) (1+ (match-end 0)))))
(org-element-create
'node-property
(list :key key
:value value
:begin begin
:end end
:post-blank 0
:post-affiliated begin))))
(defun org-element-node-property-interpreter (node-property _)
"Interpret NODE-PROPERTY element as Org syntax."
(format org-property-format
(format ":%s:" (org-element-property :key node-property))
(or (org-element-property :value node-property) "")))
;;;; Paragraph
(defun org-element-paragraph-parser (limit affiliated)
"Parse a paragraph.
LIMIT bounds the search. AFFILIATED is a list of which CAR is
the buffer position at the beginning of the first affiliated
keyword and CDR is a plist of affiliated keywords along with
their value.
Return a new syntax node of `paragraph' type containing `:begin',
`:end', `:contents-begin' and `:contents-end', `:post-blank' and
`:post-affiliated' properties.
Assume point is at the beginning of the paragraph."
(save-excursion
(let* ((begin (car affiliated))
(contents-begin (point))
(before-blank
(let ((case-fold-search t))
(end-of-line)
;; A matching `org-element-paragraph-separate' is not
;; necessarily the end of the paragraph. In particular,
;; drawers, blocks or LaTeX environments opening lines
;; must be closed. Moreover keywords with a secondary
;; value must belong to "dual keywords".
(while (not
(cond
((not (and (re-search-forward
org-element-paragraph-separate limit 'move)
(progn (forward-line 0) t))))
((looking-at-p org-element-drawer-re)
(save-excursion
(forward-line 1)
(re-search-forward "^[ \t]*:END:[ \t]*$" limit t)))
((looking-at "[ \t]*#\\+BEGIN_\\(\\S-+\\)")
(save-excursion
(re-search-forward
(format "^[ \t]*#\\+END_%s[ \t]*$"
(regexp-quote (match-string 1)))
limit t)))
((looking-at org-element--latex-begin-environment)
(save-excursion
(re-search-forward
(format org-element--latex-end-environment
(regexp-quote (match-string 1)))
limit t)))
((looking-at "[ \t]*#\\+\\(\\S-+\\)\\[.*\\]:")
(member-ignore-case (match-string 1)
org-element-dual-keywords))
;; Everything else is unambiguous.
(t)))
(end-of-line))
(if (= (point) limit) limit
(goto-char (line-beginning-position)))))
(contents-end (save-excursion
(skip-chars-backward " \r\t\n" contents-begin)
(line-beginning-position 2)))
(end (progn (skip-chars-forward " \r\t\n" limit)
(if (eobp) (point) (line-beginning-position)))))
(org-element-create
'paragraph
(nconc
(list :begin begin
:end end
:contents-begin contents-begin
:contents-end contents-end
:post-blank (count-lines before-blank end)
:post-affiliated contents-begin)
(cdr affiliated))))))
(defun org-element-paragraph-interpreter (_ contents)
"Interpret paragraph element as Org syntax.
CONTENTS is the contents of the element."
contents)
;;;; Planning
(defun org-element-planning-parser (limit)
"Parse a planning.
LIMIT bounds the search.
Return a new syntax node of `planning' type containing `:closed',
`:deadline', `:scheduled', `:begin', `:end', `:post-blank' and
`:post-affiliated' properties."
(save-excursion
(let* ((case-fold-search nil)
(begin (point))
(post-blank (let ((before-blank (progn (forward-line) (point))))
(skip-chars-forward " \r\t\n" limit)
(skip-chars-backward " \t")
(unless (bolp) (skip-chars-forward " \t"))
(count-lines before-blank (point))))
(end (point))
closed deadline scheduled)
(goto-char begin)
(while (re-search-forward org-element-planning-keywords-re end t)
(skip-chars-forward " \t" end)
(let ((keyword (match-string 0))
(time (org-element-timestamp-parser)))
(cond
((equal keyword org-element-closed-keyword) (setq closed time))
((equal keyword org-element-deadline-keyword) (setq deadline time))
(t (setq scheduled time)))))
(org-element-create
'planning
(list :closed closed
:deadline deadline
:scheduled scheduled
:begin begin
:end end
:post-blank post-blank
:post-affiliated begin)))))
(defun org-element-planning-interpreter (planning _)
"Interpret PLANNING element as Org syntax."
(mapconcat
#'identity
(delq nil
(list (let ((deadline (org-element-property :deadline planning)))
(when deadline
(concat org-element-deadline-keyword " "
(org-element-timestamp-interpreter deadline nil))))
(let ((scheduled (org-element-property :scheduled planning)))
(when scheduled
(concat org-element-scheduled-keyword " "
(org-element-timestamp-interpreter scheduled nil))))
(let ((closed (org-element-property :closed planning)))
(when closed
(concat org-element-closed-keyword " "
(org-element-timestamp-interpreter closed nil))))))
" "))
;;;; Src Block
(defun org-element-src-block-parser (limit affiliated)
"Parse a source block.
LIMIT bounds the search. AFFILIATED is a list of which CAR is
the buffer position at the beginning of the first affiliated
keyword and CDR is a plist of affiliated keywords along with
their value.
Return a new syntax node of `src-block' type containing `:language',
`:switches', `:parameters', `:begin', `:end', `:number-lines',
`:retain-labels', `:use-labels', `:label-fmt', `:preserve-indent',
`:value', `:post-blank' and `:post-affiliated' properties.
Assume point is at the beginning of the block."
(let ((case-fold-search t))
(if (not (save-excursion (re-search-forward "^[ \t]*#\\+END_SRC[ \t]*$"
limit t)))
;; Incomplete block: parse it as a paragraph.
(org-element-paragraph-parser limit affiliated)
(let ((contents-end (match-beginning 0)))
(save-excursion
(let* ((begin (car affiliated))
(post-affiliated (point))
;; Get language as a string.
(language
(progn
(looking-at
"^[ \t]*#\\+BEGIN_SRC\
\\(?: +\\(\\S-+\\)\\)?\
\\(\\(?: +\\(?:-\\(?:l \".+\"\\|[ikr]\\)\\|[-+]n\\(?: *[0-9]+\\)?\\)\\)+\\)?\
\\(.*\\)[ \t]*$")
(org-element--get-cached-string
(match-string-no-properties 1))))
;; Get switches.
(switches (match-string-no-properties 2))
;; Get parameters.
(parameters (match-string-no-properties 3))
;; Switches analysis.
(number-lines
(and switches
(string-match "\\([-+]\\)n\\(?: *\\([0-9]+\\)\\)?\\>"
switches)
(cons
(if (equal (match-string 1 switches) "-")
'new
'continued)
(if (not (match-end 2)) 0
;; Subtract 1 to give number of lines before
;; first line.
(1- (string-to-number (match-string 2 switches)))))))
(preserve-indent (and switches
(string-match-p "-i\\>" switches)))
(label-fmt
(and switches
(string-match "-l +\"\\([^\"\n]+\\)\"" switches)
(match-string-no-properties 1 switches)))
;; Should labels be retained in (or stripped from)
;; source blocks?
(retain-labels
(or (not switches)
(not (string-match-p "-r\\>" switches))
(and number-lines (string-match-p "-k\\>" switches))))
;; What should code-references use - labels or
;; line-numbers?
(use-labels
(or (not switches)
(and retain-labels
(not (string-match-p "-k\\>" switches)))))
;; Retrieve code.
(value
(org-element-deferred-create
t #'org-element--unescape-substring
(- (line-beginning-position 2) begin)
(- contents-end begin)))
(pos-before-blank (progn (goto-char contents-end)
(forward-line)
(point)))
;; Get position after ending blank lines.
(end (progn (skip-chars-forward " \r\t\n" limit)
(if (eobp) (point) (line-beginning-position)))))
(org-element-create
'src-block
(nconc
(list :language language
:switches (and (org-string-nw-p switches)
(org-trim switches))
:parameters (and (org-string-nw-p parameters)
(org-trim parameters))
:begin begin
:end end
:number-lines number-lines
:preserve-indent preserve-indent
:retain-labels retain-labels
:use-labels use-labels
:label-fmt label-fmt
:value value
:post-blank (count-lines pos-before-blank end)
:post-affiliated post-affiliated)
(cdr affiliated)))))))))
(defun org-element-src-block-interpreter (src-block _)
"Interpret SRC-BLOCK element as Org syntax."
(let ((lang (org-element-property :language src-block))
(switches (org-element-property :switches src-block))
(params (org-element-property :parameters src-block))
(value
(let ((val (org-element-property :value src-block)))
(cond
((org-src-preserve-indentation-p src-block) val)
((zerop org-edit-src-content-indentation)
(org-remove-indentation val))
(t
(let ((ind (make-string org-edit-src-content-indentation ?\s)))
(replace-regexp-in-string "^[ \t]*\\S-"
(concat ind "\\&")
(org-remove-indentation val))))))))
(format "#+begin_src%s\n%s#+end_src"
(concat (and lang (concat " " lang))
(and switches (concat " " switches))
(and params (concat " " params)))
(org-element-normalize-string (org-escape-code-in-string value)))))
;;;; Table
(defun org-element-table-parser (limit affiliated)
"Parse a table at point.
LIMIT bounds the search. AFFILIATED is a list of which CAR is
the buffer position at the beginning of the first affiliated
keyword and CDR is a plist of affiliated keywords along with
their value.
Return a new syntax node of `table' type containing `:begin', `:end',
`:tblfm', `:type', `:contents-begin', `:contents-end', `:value',
`:post-blank' and `:post-affiliated' properties.
Assume point is at the beginning of the table."
(save-excursion
(let* ((case-fold-search t)
(table-begin (point))
(type (if (looking-at-p "[ \t]*|") 'org 'table.el))
(end-re (format "^[ \t]*\\($\\|[^| \t%s]\\)"
(if (eq type 'org) "" "+")))
(begin (car affiliated))
(table-end
(if (re-search-forward end-re limit 'move)
(goto-char (match-beginning 0))
(point)))
(tblfm (let (acc)
(while (looking-at "[ \t]*#\\+TBLFM: +\\(.*\\)[ \t]*$")
(push (match-string-no-properties 1) acc)
(forward-line))
acc))
(pos-before-blank (point))
(end (progn (skip-chars-forward " \r\t\n" limit)
(if (eobp) (point) (line-beginning-position)))))
(org-element-create
'table
(nconc
(list :begin begin
:end end
:type type
:tblfm tblfm
;; Only `org' tables have contents. `table.el' tables
;; use a `:value' property to store raw table as
;; a string.
:contents-begin (and (eq type 'org) table-begin)
:contents-end (and (eq type 'org) table-end)
:value (and (eq type 'table.el)
(org-element-deferred-create
t #'org-element--substring
(- table-begin begin)
(- table-end begin)))
:post-blank (count-lines pos-before-blank end)
:post-affiliated table-begin)
(cdr affiliated))))))
(defun org-element-table-interpreter (table contents)
"Interpret TABLE element as Org syntax.
CONTENTS is a string, if table's type is `org', or nil."
(if (eq (org-element-property :type table) 'table.el)
(org-remove-indentation (org-element-property :value table))
(concat (with-temp-buffer (insert contents)
(org-table-align)
(buffer-string))
(mapconcat (lambda (fm) (concat "#+TBLFM: " fm))
(reverse (org-element-property :tblfm table))
"\n"))))
;;;; Table Row
(defun org-element-table-row-parser (_)
"Parse table row at point.
Return a new syntax node of `table-row' type containing `:begin',
`:end', `:contents-begin', `:contents-end', `:type', `:post-blank' and
`:post-affiliated' properties."
(save-excursion
(let* ((type (if (looking-at-p "^[ \t]*|-") 'rule 'standard))
(begin (point))
;; A table rule has no contents. In that case, ensure
;; CONTENTS-BEGIN matches CONTENTS-END.
(contents-begin (and (eq type 'standard) (search-forward "|")))
(contents-end (and (eq type 'standard)
(progn
(end-of-line)
(skip-chars-backward " \t")
(point))))
(end (line-beginning-position 2)))
(org-element-create
'table-row
(list :type type
:begin begin
:end end
:contents-begin contents-begin
:contents-end contents-end
:post-blank 0
:post-affiliated begin)))))
(defun org-element-table-row-interpreter (table-row contents)
"Interpret TABLE-ROW element as Org syntax.
CONTENTS is the contents of the table row."
(if (eq (org-element-property :type table-row) 'rule) "|-"
(concat "|" contents)))
;;;; Verse Block
(defun org-element-verse-block-parser (limit affiliated)
"Parse a verse block.
LIMIT bounds the search. AFFILIATED is a list of which CAR is
the buffer position at the beginning of the first affiliated
keyword and CDR is a plist of affiliated keywords along with
their value.
Return a new syntax node of `verse-block' type containing `:begin',
`:end', `:contents-begin', `:contents-end', `:post-blank' and
`:post-affiliated' properties.
Assume point is at beginning of the block."
(let ((case-fold-search t))
(if (not (save-excursion
(re-search-forward "^[ \t]*#\\+END_VERSE[ \t]*$" limit t)))
;; Incomplete block: parse it as a paragraph.
(org-element-paragraph-parser limit affiliated)
(let ((contents-end (match-beginning 0)))
(save-excursion
(let* ((begin (car affiliated))
(post-affiliated (point))
(contents-begin (progn (forward-line) (point)))
(pos-before-blank (progn (goto-char contents-end)
(forward-line)
(point)))
(end (progn (skip-chars-forward " \r\t\n" limit)
(if (eobp) (point) (line-beginning-position)))))
(org-element-create
'verse-block
(nconc
(list :begin begin
:end end
:contents-begin contents-begin
:contents-end contents-end
:post-blank (count-lines pos-before-blank end)
:post-affiliated post-affiliated)
(cdr affiliated)))))))))
(defun org-element-verse-block-interpreter (_ contents)
"Interpret verse-block element as Org syntax.
CONTENTS is verse block contents."
(format "#+begin_verse\n%s#+end_verse" contents))
;;; Objects
;;
;; Unlike to elements, raw text can be found between objects. Hence,
;; `org-element--object-lex' is provided to find the next object in
;; buffer.
;;
;; Some object types (e.g., `italic') are recursive. Restrictions on
;; object types they can contain will be specified in
;; `org-element-object-restrictions'.
;;
;; Creating a new type of object requires altering
;; `org-element--object-regexp' and `org-element--object-lex', add the
;; new type in `org-element-all-objects', and possibly add
;; restrictions in `org-element-object-restrictions'.
;;;; Bold
(defun org-element--parse-generic-emphasis (mark type)
"Parse emphasis object at point, if any.
MARK is the delimiter string used. TYPE is a symbol among
`bold', `code', `italic', `strike-through', `underline', and
`verbatim'.
Assume point is at first MARK."
(save-excursion
(let ((origin (point)))
(unless (bolp) (forward-char -1))
(let ((opening-re
(rx-to-string
`(seq (or line-start (any space ?- ?\( ?' ?\" ?\{))
,mark
(not space)))))
(when (looking-at-p opening-re)
(goto-char (1+ origin))
(let ((closing-re
(rx-to-string
`(seq
(not space)
(group ,mark)
(or (any space ?- ?. ?, ?\; ?: ?! ?? ?' ?\" ?\) ?\} ?\\ ?\[)
line-end)))))
(when (re-search-forward closing-re nil t)
(let ((closing (match-end 1)))
(goto-char closing)
(let* ((post-blank (skip-chars-forward " \t"))
(contents-begin (1+ origin))
(contents-end (1- closing)))
(org-element-create
type
(append
(list :begin origin
:end (point)
:post-blank post-blank)
(if (memq type '(code verbatim))
(list :value
(and (memq type '(code verbatim))
(org-element-deferred-create
t #'org-element--substring
(- contents-begin origin)
(- contents-end origin))))
(list :contents-begin contents-begin
:contents-end contents-end)))))))))))))
(defun org-element-bold-parser ()
"Parse bold object at point, if any.
When at a bold object, return a new syntax node `bold' type containing
`:begin', `:end', `:contents-begin', `:contents-end', and
`:post-blank' properties. Otherwise, return nil.
Assume point is at the first star marker."
(org-element--parse-generic-emphasis "*" 'bold))
(defun org-element-bold-interpreter (_ contents)
"Interpret bold object as Org syntax.
CONTENTS is the contents of the object."
(format "*%s*" contents))
;;;; Citation
(defun org-element-citation-parser ()
"Parse citation object at point, if any.
When at a citation object, return a new syntax node of `citation' type
containing `:style', `:prefix', `:suffix', `:begin', `:end',
`:contents-begin', `:contents-end', and `:post-blank' properties.
Otherwise, return nil.
Assume point is at the beginning of the citation."
(when (looking-at org-element-citation-prefix-re)
(let* ((begin (point))
(style (and (match-end 1)
(org-element--get-cached-string
(match-string-no-properties 1))))
;; Ignore blanks between cite type and prefix or key.
(start (match-end 0))
(closing (with-syntax-table org-element--pair-square-table
(ignore-errors (scan-lists begin 1 0)))))
(save-excursion
(when (and closing
(re-search-forward org-element-citation-key-re closing t))
;; Find prefix, if any.
(let ((first-key-end (match-end 0))
(types (org-element-restriction 'citation-reference))
(cite
(org-element-create
'citation
(list :style style
:begin begin
:post-blank (progn
(goto-char closing)
(skip-chars-forward " \t"))
:end (point)
:secondary (alist-get
'citation
org-element-secondary-value-alist)))))
;; `:contents-begin' depends on the presence of
;; a non-empty common prefix.
(goto-char first-key-end)
(if (not (search-backward ";" start t))
(org-element-put-property cite :contents-begin start)
(when (< start (point))
(org-element-put-property
cite :prefix
(org-element--parse-objects start (point) nil types cite)))
(forward-char)
(org-element-put-property cite :contents-begin (point)))
;; `:contents-end' depends on the presence of a non-empty
;; common suffix.
(goto-char (1- closing))
(skip-chars-backward " \r\t\n")
(let ((end (point)))
(if (or (not (search-backward ";" first-key-end t))
(re-search-forward org-element-citation-key-re end t))
(org-element-put-property cite :contents-end end)
(forward-char)
(when (< (point) end)
(org-element-put-property
cite :suffix
(org-element--parse-objects (point) end nil types cite)))
(org-element-put-property cite :contents-end (point))))
cite))))))
(defun org-element-citation-interpreter (citation contents)
"Interpret CITATION object as Org syntax.
CONTENTS is the contents of the object, as a string."
(let ((prefix (org-element-property :prefix citation))
(suffix (org-element-property :suffix citation))
(style (org-element-property :style citation)))
(concat "[cite"
(and style (concat "/" style))
":"
(and prefix (concat (org-element-interpret-data prefix) ";"))
(if suffix
(concat contents (org-element-interpret-data suffix))
;; Remove spurious semicolon.
(substring contents nil -1))
"]")))
;;;; Citation Reference
(defun org-element-citation-reference-parser ()
"Parse citation reference object at point, if any.
When at a reference, return a new syntax node of `citation-reference'
type containing `:key', `:prefix', `:suffix', `:begin', `:end', and
`:post-blank' properties.
Assume point is at the beginning of the reference."
(save-excursion
(let ((begin (point)))
(when (re-search-forward org-element-citation-key-re nil t)
(let* ((key (org-element--get-cached-string
(match-string-no-properties 1)))
(key-start (match-beginning 0))
(key-end (match-end 0))
(separator (search-forward ";" nil t))
(end (or separator (point-max)))
(suffix-end (if separator (1- end) end))
(types (org-element-restriction 'citation-reference))
(reference
(org-element-create
'citation-reference
(list :key key
:begin begin
:end end
:post-blank 0
:secondary (alist-get
'citation-reference
org-element-secondary-value-alist)))))
(when (< begin key-start)
(org-element-put-property
reference :prefix
(org-element--parse-objects begin key-start nil types reference)))
(when (< key-end suffix-end)
(org-element-put-property
reference :suffix
(org-element--parse-objects key-end suffix-end nil types reference)))
reference)))))
(defun org-element-citation-reference-interpreter (citation-reference _)
"Interpret CITATION-REFERENCE object as Org syntax."
(concat (org-element-interpret-data
(org-element-property :prefix citation-reference))
"@" (org-element-property :key citation-reference)
(org-element-interpret-data
(org-element-property :suffix citation-reference))
";"))
;;;; Code
(defun org-element-code-parser ()
"Parse code object at point, if any.
When at a code object, return a new syntax node of `code' type
containing `:value', `:begin', `:end' and `:post-blank' properties.
Otherwise, return nil.
Assume point is at the first tilde marker."
(org-element--parse-generic-emphasis "~" 'code))
(defun org-element-code-interpreter (code _)
"Interpret CODE object as Org syntax."
(format "~%s~" (org-element-property :value code)))
;;;; Entity
(defun org-element-entity-parser ()
"Parse entity at point, if any.
When at an entity, return a new syntax node of `entity' type
containing `:begin', `:end', `:latex', `:latex-math-p', `:html',
`:latin1', `:utf-8', `:ascii', `:use-brackets-p' and `:post-blank' as
properties. Otherwise, return nil.
Assume point is at the beginning of the entity."
(catch 'no-object
(when (looking-at
(rx "\\"
(or
;; Special case: whitespace entities are matched by
;; name only.
(group-n 1 (seq "_" (1+ " ")))
(seq
(group-n 1
(or "there4"
(seq "sup" (in "123"))
(seq "frac" (in "13") (in "24"))
(1+ (in "a-zA-Z"))))
(group-n 2 (or eol "{}" (not letter)))))))
(save-excursion
(let* ((value (or (org-entity-get (match-string 1))
(throw 'no-object nil)))
(begin (match-beginning 0))
(bracketsp (string= (match-string 2) "{}"))
(post-blank (progn (goto-char (match-end 1))
(when bracketsp (forward-char 2))
(skip-chars-forward " \t")))
(end (point)))
(org-element-create
'entity
(list :name (car value)
:latex (nth 1 value)
:latex-math-p (nth 2 value)
:html (nth 3 value)
:ascii (nth 4 value)
:latin1 (nth 5 value)
:utf-8 (nth 6 value)
:begin begin
:end end
:use-brackets-p bracketsp
:post-blank post-blank)))))))
(defun org-element-entity-interpreter (entity _)
"Interpret ENTITY object as Org syntax."
(concat "\\"
(org-element-property :name entity)
(when (org-element-property :use-brackets-p entity) "{}")))
;;;; Export Snippet
(defun org-element-export-snippet-parser ()
"Parse export snippet at point.
When at an export snippet, return a new syntax node of
`export-snippet' type containing `:begin', `:end', `:back-end',
`:value' and `:post-blank' as properties. Otherwise, return nil.
Assume point is at the beginning of the snippet."
(save-excursion
(when (looking-at "@@\\([-A-Za-z0-9]+\\):")
(goto-char (match-end 0))
(let* ((begin (match-beginning 0))
(contents-begin (match-end 0))
(backend (org-element--get-cached-string
(match-string-no-properties 1)))
(contents-end
(when (re-search-forward "@@" nil t)
(match-beginning 0)))
(value
(when contents-end
(org-element-deferred-create
t #'org-element--substring
(- contents-begin begin)
(- contents-end begin))))
(post-blank (skip-chars-forward " \t"))
(end (point)))
(when contents-end ; No match when no trailing "@@".
(org-element-create
'export-snippet
(list :back-end backend
:value value
:begin begin
:end end
:post-blank post-blank)))))))
(defun org-element-export-snippet-interpreter (export-snippet _)
"Interpret EXPORT-SNIPPET object as Org syntax."
(format "@@%s:%s@@"
(org-element-property :back-end export-snippet)
(org-element-property :value export-snippet)))
;;;; Footnote Reference
(defun org-element-footnote-reference-parser ()
"Parse footnote reference at point, if any.
When at a footnote reference, return a new syntax node of
`footnote-reference' type containing `:label', `:type', `:begin',
`:end', `:contents-begin', `:contents-end' and `:post-blank' as
properties. Otherwise, return nil."
(when (looking-at org-footnote-re)
(let ((closing (with-syntax-table org-element--pair-square-table
(ignore-errors (scan-lists (point) 1 0)))))
(when closing
(save-excursion
(let* ((begin (point))
(label (org-element--get-cached-string
(match-string-no-properties 1)))
(inner-begin (match-end 0))
(inner-end (1- closing))
(type (if (match-end 2) 'inline 'standard))
(post-blank (progn (goto-char closing)
(skip-chars-forward " \t")))
(end (point)))
(org-element-create
'footnote-reference
(list :label label
:type type
:begin begin
:end end
:contents-begin (and (eq type 'inline) inner-begin)
:contents-end (and (eq type 'inline) inner-end)
:post-blank post-blank))))))))
(defun org-element-footnote-reference-interpreter (footnote-reference contents)
"Interpret FOOTNOTE-REFERENCE object as Org syntax.
CONTENTS is its definition, when inline, or nil."
(format "[fn:%s%s]"
(or (org-element-property :label footnote-reference) "")
(if contents (concat ":" contents) "")))
;;;; Inline Babel Call
(defun org-element-inline-babel-call-parser ()
"Parse inline babel call at point, if any.
When at an inline babel call, return a new syntax node of
`inline-babel-call' type containing `:call', `:inside-header',
`:arguments', `:end-header', `:begin', `:end', `:value' and
`:post-blank' as properties. Otherwise, return nil.
Assume point is at the beginning of the babel call."
(save-excursion
(catch :no-object
(when (let ((case-fold-search nil))
(looking-at "\\. Unlike to
;; bracket links, follow RFC 3986 and remove any extra
;; whitespace in URI.
((looking-at org-link-angle-re)
(setq format 'angle)
(setq type (match-string-no-properties 1))
(setq explicit-type-p t)
(setq link-end (match-end 0))
(setq raw-link
(buffer-substring-no-properties
(match-beginning 1) (match-end 2)))
(setq path (replace-regexp-in-string
"[ \t]*\n[ \t]*" "" (match-string-no-properties 2))))
(t (throw 'no-object nil)))
;; In any case, deduce end point after trailing white space from
;; LINK-END variable.
(save-excursion
(setq post-blank
(progn (goto-char link-end) (skip-chars-forward " \t")))
(setq end (point)))
;; Special "file"-type link processing. Extract opening
;; application and search option, if any. Also normalize URI.
(when (string-match "\\`file\\(?:\\+\\(.+\\)\\)?\\'" type)
(setq application (match-string-no-properties 1 type))
(setq type "file")
(when (string-match "::\\(.*\\)\\'" path)
(setq search-option (match-string-no-properties 1 path))
(setq path (replace-match "" nil nil path)))
(setq path (replace-regexp-in-string "\\`///*\\(.:\\)?/" "\\1/" path)))
;; Translate link, if `org-link-translation-function' is set.
(let ((trans (and (functionp org-link-translation-function)
(funcall org-link-translation-function type path))))
(when trans
(setq type (car trans))
(setq explicit-type-p t)
(setq path (cdr trans))))
(org-element-create
'link
(list :type (org-element--get-cached-string type)
:type-explicit-p explicit-type-p
:path path
:format format
:raw-link (or raw-link path)
:application application
:search-option search-option
:begin begin
:end end
:contents-begin contents-begin
:contents-end contents-end
:post-blank post-blank)))))
(defun org-element-link-interpreter (link contents)
"Interpret LINK object as Org syntax.
CONTENTS is the contents of the object, or nil."
(let ((type (org-element-property :type link))
(path (org-element-property :path link)))
(if (string= type "radio") path
(let ((fmt (pcase (org-element-property :format link)
;; Links with contents and internal links have to
;; use bracket syntax. Ignore `:format' in these
;; cases. This is also the default syntax when the
;; property is not defined, e.g., when the object
;; was crafted by the user.
((guard contents)
(format "[[%%s][%s]]"
;; Since this is going to be used as
;; a format string, escape percent signs
;; in description.
(replace-regexp-in-string "%" "%%" contents)))
((or `bracket
`nil
(guard (member type '("coderef" "custom-id" "fuzzy"))))
"[[%s]]")
;; Otherwise, just obey to `:format'.
(`angle "<%s>")
(`plain "%s")
(f (error "Wrong `:format' value: %s" f)))))
(format fmt
(pcase type
("coderef" (format "(%s)" path))
("custom-id" (concat "#" path))
("file"
(let ((app (org-element-property :application link))
(opt (org-element-property :search-option link))
(type-explicit-p (org-element-property :type-explicit-p link)))
(concat (and type-explicit-p type)
(and type-explicit-p app (concat "+" app))
(and type-explicit-p ":")
path
(and opt (concat "::" opt)))))
("fuzzy" path)
(_ (concat type ":" path))))))))
;;;; Macro
(defun org-element-macro-parser ()
"Parse macro at point, if any.
When at a macro, return a new syntax node of `macro' type containing
`:key', `:args', `:begin', `:end', `:value' and `:post-blank' as
properties. Otherwise, return nil.
Assume point is at the macro."
(save-excursion
(when (looking-at "{{{\\([a-zA-Z][-a-zA-Z0-9_]*\\)\\((\\(\\(?:.\\|\n\\)*?\\))\\)?}}}")
(let ((begin (point))
(key (org-element--get-cached-string
(downcase (match-string-no-properties 1))))
(value (match-string-no-properties 0))
(post-blank (progn (goto-char (match-end 0))
(skip-chars-forward " \t")))
(end (point))
(args (pcase (match-string-no-properties 3)
(`nil nil)
(a (org-macro-extract-arguments
(replace-regexp-in-string
"[ \t\r\n]+" " " (org-trim a)))))))
(org-element-create
'macro
(list :key key
:value value
:args args
:begin begin
:end end
:post-blank post-blank))))))
(defun org-element-macro-interpreter (macro _)
"Interpret MACRO object as Org syntax."
(format "{{{%s%s}}}"
(org-element-property :key macro)
(pcase (org-element-property :args macro)
(`nil "")
(args (format "(%s)" (apply #'org-macro-escape-arguments args))))))
;;;; Radio-target
(defun org-element-radio-target-parser ()
"Parse radio target at point, if any.
When at a radio target, return a new syntax node of `radio-target'
type containing `:begin', `:end', `:contents-begin', `:contents-end',
`:value' and `:post-blank' as properties. Otherwise, return nil.
Assume point is at the radio target."
(save-excursion
(when (looking-at org-radio-target-regexp)
(let ((begin (point))
(contents-begin (match-beginning 1))
(contents-end (match-end 1))
(value (match-string-no-properties 1))
(post-blank (progn (goto-char (match-end 0))
(skip-chars-forward " \t")))
(end (point)))
(org-element-create
'radio-target
(list :begin begin
:end end
:contents-begin contents-begin
:contents-end contents-end
:post-blank post-blank
:value value))))))
(defun org-element-radio-target-interpreter (_ contents)
"Interpret target object as Org syntax.
CONTENTS is the contents of the object."
(concat "<<<" contents ">>>"))
;;;; Statistics Cookie
(defun org-element-statistics-cookie-parser ()
"Parse statistics cookie at point, if any.
When at a statistics cookie, return a new syntax node of
`statistics-cookie' type containing `:begin', `:end', `:value' and
`:post-blank' properties. Otherwise, return nil.
Assume point is at the beginning of the statistics-cookie."
(save-excursion
(when (looking-at "\\[[0-9]*\\(%\\|/[0-9]*\\)\\]")
(let* ((begin (point))
(value (buffer-substring-no-properties
(match-beginning 0) (match-end 0)))
(post-blank (progn (goto-char (match-end 0))
(skip-chars-forward " \t")))
(end (point)))
(org-element-create
'statistics-cookie
(list :begin begin
:end end
:value value
:post-blank post-blank))))))
(defun org-element-statistics-cookie-interpreter (statistics-cookie _)
"Interpret STATISTICS-COOKIE object as Org syntax."
(org-element-property :value statistics-cookie))
;;;; Strike-Through
(defun org-element-strike-through-parser ()
"Parse strike-through object at point, if any.
When at a strike-through object, return a new syntax node of
`strike-through' type containing `:begin', `:end', `:contents-begin'
and `:contents-end' and `:post-blank' properties. Otherwise, return
nil.
Assume point is at the first plus sign marker."
(org-element--parse-generic-emphasis "+" 'strike-through))
(defun org-element-strike-through-interpreter (_ contents)
"Interpret strike-through object as Org syntax.
CONTENTS is the contents of the object."
(format "+%s+" contents))
;;;; Subscript
(defun org-element-subscript-parser ()
"Parse subscript at point, if any.
When at a subscript object, return a new syntax node of `subscript'
type containing `:begin', `:end', `:contents-begin', `:contents-end',
`:use-brackets-p' and `:post-blank' as properties. Otherwise, return
nil.
Assume point is at the underscore."
(save-excursion
(unless (bolp)
(backward-char)
(when (looking-at org-match-substring-regexp)
(let ((bracketsp (if (match-beginning 4) t nil))
(begin (match-beginning 2))
(contents-begin (or (match-beginning 4)
(match-beginning 3)))
(contents-end (or (match-end 4) (match-end 3)))
(post-blank (progn (goto-char (match-end 0))
(skip-chars-forward " \t")))
(end (point)))
(org-element-create
'subscript
(list :begin begin
:end end
:use-brackets-p bracketsp
:contents-begin contents-begin
:contents-end contents-end
:post-blank post-blank)))))))
(defun org-element-subscript-interpreter (subscript contents)
"Interpret SUBSCRIPT object as Org syntax.
CONTENTS is the contents of the object."
(format
(if (org-element-property :use-brackets-p subscript) "_{%s}" "_%s")
contents))
;;;; Superscript
(defun org-element-superscript-parser ()
"Parse superscript at point, if any.
When at a superscript object, return a new syntax node of
`superscript' type containing `:begin', `:end', `:contents-begin',
`:contents-end', `:use-brackets-p' and `:post-blank' as properties.
Otherwise, return nil.
Assume point is at the caret."
(save-excursion
(unless (bolp) (backward-char))
(when (looking-at org-match-substring-regexp)
(let ((bracketsp (if (match-beginning 4) t nil))
(begin (match-beginning 2))
(contents-begin (or (match-beginning 4)
(match-beginning 3)))
(contents-end (or (match-end 4) (match-end 3)))
(post-blank (progn (goto-char (match-end 0))
(skip-chars-forward " \t")))
(end (point)))
(org-element-create
'superscript
(list :begin begin
:end end
:use-brackets-p bracketsp
:contents-begin contents-begin
:contents-end contents-end
:post-blank post-blank))))))
(defun org-element-superscript-interpreter (superscript contents)
"Interpret SUPERSCRIPT object as Org syntax.
CONTENTS is the contents of the object."
(format
(if (org-element-property :use-brackets-p superscript) "^{%s}" "^%s")
contents))
;;;; Table Cell
(defun org-element-table-cell-parser ()
"Parse table cell at point.
Return a new syntax node of `table-cell' type containing `:begin',
`:end', `:contents-begin', `:contents-end' and `:post-blank'
properties."
(looking-at "[ \t]*\\(.*?\\)[ \t]*\\(?:|\\|$\\)")
(let* ((begin (match-beginning 0))
(end (match-end 0))
(contents-begin (match-beginning 1))
(contents-end (match-end 1)))
(org-element-create
'table-cell
(list :begin begin
:end end
:contents-begin contents-begin
:contents-end contents-end
:post-blank 0))))
(defun org-element-table-cell-interpreter (_ contents)
"Interpret table-cell element as Org syntax.
CONTENTS is the contents of the cell, or nil."
(concat " " contents " |"))
;;;; Target
(defun org-element-target-parser ()
"Parse target at point, if any.
When at a target, return a new syntax node of `target' type containing
`:begin', `:end', `:value' and `:post-blank' as properties.
Otherwise, return nil.
Assume point is at the target."
(save-excursion
(when (looking-at org-target-regexp)
(let ((begin (point))
(value (match-string-no-properties 1))
(post-blank (progn (goto-char (match-end 0))
(skip-chars-forward " \t")))
(end (point)))
(org-element-create
'target
(list :begin begin
:end end
:value value
:post-blank post-blank))))))
(defun org-element-target-interpreter (target _)
"Interpret TARGET object as Org syntax."
(format "<<%s>>" (org-element-property :value target)))
;;;; Timestamp
(defconst org-element--timestamp-regexp
(concat org-ts-regexp-both
"\\|"
"\\(?:<[0-9]+-[0-9]+-[0-9]+[^>\n]+?\\+[0-9]+[dwmy]>\\)"
"\\|"
"\\(?:<%%\\(?:([^>\n]+)\\)\\([^\n>]*\\)>\\)")
"Regexp matching any timestamp type object.")
(defconst org-element--timestamp-raw-value-regexp
(concat "\\([<[]\\(%%\\)?.*?\\)[]>]\\(?:--\\("
org-ts-regexp-both
"\\)\\)?")
"Regexp for matching raw value of a timestamp.")
(defun org-element-timestamp-parser ()
"Parse time stamp at point, if any.
When at a time stamp, return a new syntax node of `timestamp' type
containing `:type', `:range-type', `:raw-value', `:year-start',
`:month-start', `:day-start', `:hour-start', `:minute-start',
`:year-end', `:month-end', `:day-end', `:hour-end', `:minute-end',
`:repeater-type', `:repeater-value', `:repeater-unit',
`:repeater-deadline-value', `:repeater-deadline-unit', `:warning-type',
`:warning-value', `:warning-unit', `:diary-sexp', `:begin', `:end' and
`:post-blank' properties. Otherwise, return nil.
Assume point is at the beginning of the timestamp."
(when (looking-at-p org-element--timestamp-regexp)
(save-excursion
(let* ((begin (point))
(activep (eq (char-after) ?<))
(raw-value
(progn
(looking-at org-element--timestamp-raw-value-regexp)
(match-string-no-properties 0)))
(diaryp (match-beginning 2))
diary-sexp
(date-start (if diaryp
;; Only consider part after sexp for
;; diary timestamps.
(save-match-data
(looking-at org-element--timestamp-regexp)
(setq diary-sexp
(buffer-substring-no-properties
(+ 3 (match-beginning 0))
(match-beginning 2)))
(match-string 2))
(match-string-no-properties 1)))
(date-end (match-string-no-properties 3))
(post-blank (progn (goto-char (match-end 0))
(skip-chars-forward " \t")))
(end (point))
(time-range
(when (string-match
"[012]?[0-9]:[0-5][0-9]\\(-\\([012]?[0-9]\\):\\([0-5][0-9]\\)\\)"
date-start)
(cons (string-to-number (match-string 2 date-start))
(string-to-number (match-string 3 date-start)))))
(type (cond (diaryp 'diary)
((and activep (or date-end time-range)) 'active-range)
(activep 'active)
((or date-end time-range) 'inactive-range)
(t 'inactive)))
(range-type (cond
(date-end 'daterange)
(time-range 'timerange)
(t nil)))
(repeater-props
(and (not diaryp)
(string-match
(rx
(group-n 1 (or "+" "++" ".+"))
(group-n 2 (+ digit))
(group-n 3 (any "hdwmy"))
(optional
"/"
(group-n 4 (+ digit))
(group-n 5 (any "hdwmy"))))
raw-value)
(nconc
(list
:repeater-type
(let ((type (match-string 1 raw-value)))
(cond ((equal "++" type) 'catch-up)
((equal ".+" type) 'restart)
(t 'cumulate)))
:repeater-value (string-to-number (match-string 2 raw-value))
:repeater-unit
(pcase (string-to-char (match-string 3 raw-value))
(?h 'hour) (?d 'day) (?w 'week) (?m 'month) (_ 'year)))
(let ((repeater-deadline-value (match-string 4 raw-value))
(repeater-deadline-unit (match-string 5 raw-value)))
(when (and repeater-deadline-value repeater-deadline-unit)
(list
:repeater-deadline-value (string-to-number repeater-deadline-value)
:repeater-deadline-unit
(pcase (string-to-char repeater-deadline-unit)
(?h 'hour) (?d 'day) (?w 'week) (?m 'month) (_ 'year))))))))
(warning-props
(and (not diaryp)
(string-match "\\(-\\)?-\\([0-9]+\\)\\([hdwmy]\\)" raw-value)
(list
:warning-type (if (match-string 1 raw-value) 'first 'all)
:warning-value (string-to-number (match-string 2 raw-value))
:warning-unit
(pcase (string-to-char (match-string 3 raw-value))
(?h 'hour) (?d 'day) (?w 'week) (?m 'month) (_ 'year)))))
year-start month-start day-start hour-start minute-start year-end
month-end day-end hour-end minute-end)
;; Parse date-start.
(unless diaryp
(let ((date (org-parse-time-string date-start t)))
(setq year-start (nth 5 date)
month-start (nth 4 date)
day-start (nth 3 date)
hour-start (nth 2 date)
minute-start (nth 1 date))))
;; Compute date-end. It can be provided directly in timestamp,
;; or extracted from time range. Otherwise, it defaults to the
;; same values as date-start.
(unless diaryp
(let ((date (and date-end (org-parse-time-string date-end t))))
(setq year-end (or (nth 5 date) year-start)
month-end (or (nth 4 date) month-start)
day-end (or (nth 3 date) day-start)
hour-end (or (nth 2 date) (car time-range) hour-start)
minute-end (or (nth 1 date) (cdr time-range) minute-start))))
;; Diary timestamp with time.
(when (and diaryp
(string-match "\\([012]?[0-9]\\):\\([0-5][0-9]\\)\\(-\\([012]?[0-9]\\):\\([0-5][0-9]\\)\\)?" date-start))
(setq hour-start (match-string 1 date-start)
minute-start (match-string 2 date-start)
hour-end (match-string 4 date-start)
minute-end (match-string 5 date-start))
(when hour-start (setq hour-start (string-to-number hour-start)))
(when minute-start (setq minute-start (string-to-number minute-start)))
(when hour-end (setq hour-end (string-to-number hour-end)))
(when minute-end (setq minute-end (string-to-number minute-end))))
(org-element-create
'timestamp
(nconc (list :type type
:range-type range-type
:raw-value raw-value
:year-start year-start
:month-start month-start
:day-start day-start
:hour-start hour-start
:minute-start minute-start
:year-end year-end
:month-end month-end
:day-end day-end
:hour-end hour-end
:minute-end minute-end
:begin begin
:end end
:post-blank post-blank)
(and diary-sexp (list :diary-sexp diary-sexp))
repeater-props
warning-props))))))
(defun org-element-timestamp-interpreter (timestamp _)
"Interpret TIMESTAMP object as Org syntax."
(let((type (org-element-property :type timestamp)))
(let ((day-start (org-element-property :day-start timestamp))
(month-start (org-element-property :month-start timestamp))
(year-start (org-element-property :year-start timestamp)))
;; Return nil when start date is not available. Could also
;; throw an error, but the current behavior is historical.
(when (or (and day-start month-start year-start)
(eq type 'diary))
(let* ((repeat-string
(concat
(pcase (org-element-property :repeater-type timestamp)
(`cumulate "+") (`catch-up "++") (`restart ".+"))
(let ((val (org-element-property :repeater-value timestamp)))
(and val (number-to-string val)))
(pcase (org-element-property :repeater-unit timestamp)
(`hour "h") (`day "d") (`week "w") (`month "m") (`year "y"))
(when-let* ((repeater-deadline-value
(org-element-property :repeater-deadline-value timestamp))
(repeater-deadline-unit
(org-element-property :repeater-deadline-unit timestamp)))
(concat
"/"
(number-to-string repeater-deadline-value)
(pcase repeater-deadline-unit
(`hour "h") (`day "d") (`week "w") (`month "m") (`year "y"))))))
(range-type (org-element-property :range-type timestamp))
(warning-string
(concat
(pcase (org-element-property :warning-type timestamp)
(`first "--") (`all "-"))
(let ((val (org-element-property :warning-value timestamp)))
(and val (number-to-string val)))
(pcase (org-element-property :warning-unit timestamp)
(`hour "h") (`day "d") (`week "w") (`month "m") (`year "y"))))
(hour-start (org-element-property :hour-start timestamp))
(minute-start (org-element-property :minute-start timestamp))
(brackets
(if (member
type
'(inactive inactive-range))
(cons "[" "]")
;; diary as well
(cons "<" ">")))
(timestamp-end
(concat
(and (org-string-nw-p repeat-string) (concat " " repeat-string))
(and (org-string-nw-p warning-string) (concat " " warning-string))
(cdr brackets))))
(concat
;; Opening bracket: [ or <
(car brackets)
;; Starting date/time: YYYY-MM-DD DAY[ HH:MM]
(if (eq type 'diary)
(concat
"%%"
(org-element-property :diary-sexp timestamp)
(when (and minute-start hour-start)
(format " %02d:%02d" hour-start minute-start)))
(format-time-string
;; `org-time-stamp-formats'.
(org-time-stamp-format
;; Ignore time unless both HH:MM are available.
;; Ignore means (car org-timestamp-formats).
(and minute-start hour-start)
'no-brackets)
(org-encode-time
0 (or minute-start 0) (or hour-start 0)
day-start month-start year-start)))
;; Range: -HH:MM or TIMESTAMP-END--[YYYY-MM-DD DAY HH:MM]
(let ((hour-end (org-element-property :hour-end timestamp))
(minute-end (org-element-property :minute-end timestamp)))
(pcase type
((or `active `inactive)
;; `org-element-timestamp-parser' uses this type
;; when no time/date range is provided. So,
;; should normally return nil in this clause.
(pcase range-type
(`nil
;; `org-element-timestamp-parser' assigns end
;; times for `active'/`inactive' TYPE if start
;; time is not nil. But manually built
;; timestamps may not contain end times, so
;; check for end times anyway.
(when (and hour-start hour-end minute-start minute-end
(or (/= hour-start hour-end)
(/= minute-start minute-end)))
;; Could also throw an error. Return range
;; timestamp nevertheless to preserve
;; historical behavior.
(format "-%02d:%02d" hour-end minute-end)))
((or `timerange `daterange)
(error "`:range-type' must be `nil' for `active'/`inactive' type"))))
;; Range must be present.
((or `active-range `inactive-range
(and `diary (guard (eq 'timerange range-type))))
(pcase range-type
;; End time: -HH:MM.
;; Fall back to start time if end time is not defined (arbitrary historical choice).
;; Error will be thrown if both end and begin time is not defined.
(`timerange (format "-%02d:%02d" (or hour-end hour-start) (or minute-end minute-start)))
;; End date: TIMESTAMP-END--[YYYY-MM-DD DAY HH:MM
((or `daterange
;; Should never happen in the output of `org-element-timestamp-parser'.
;; Treat as an equivalent of `daterange' arbitrarily.
`nil)
(concat
;; repeater + warning + closing > or ]
;; This info is duplicated in date ranges.
timestamp-end
"--" (car brackets)
(format-time-string
;; `org-time-stamp-formats'.
(org-time-stamp-format
;; Ignore time unless both HH:MM are available.
;; Ignore means (car org-timestamp-formats).
(and minute-end hour-end)
'no-brackets)
(org-encode-time
;; Closing HH:MM missing is a valid scenario.
0 (or minute-end 0) (or hour-end 0)
;; YEAR/MONTH/DAY-END will always be present
;; for `daterange' range-type, as parsed by
;; `org-element-timestamp-parser'.
;; For manually constructed timestamp
;; object, arbitrarily fall back to starting
;; date.
(or (org-element-property :day-end timestamp) day-start)
(or (org-element-property :month-end timestamp) month-start)
(or (org-element-property :year-end timestamp) year-start)))))))))
;; repeater + warning + closing > or ]
;; This info is duplicated in date ranges.
timestamp-end))))))
;;;; Underline
(defun org-element-underline-parser ()
"Parse underline object at point, if any.
When at an underline object, return a new syntax node of `underline'
type containing `:begin', `:end', `:contents-begin' and
`:contents-end' and `:post-blank' properties. Otherwise, return nil.
Assume point is at the first underscore marker."
(org-element--parse-generic-emphasis "_" 'underline))
(defun org-element-underline-interpreter (_ contents)
"Interpret underline object as Org syntax.
CONTENTS is the contents of the object."
(format "_%s_" contents))
;;;; Verbatim
(defun org-element-verbatim-parser ()
"Parse verbatim object at point, if any.
When at a verbatim object, return a new syntax node of `verbatim' type
containing `:value', `:begin', `:end' and `:post-blank' properties.
Otherwise, return nil.
Assume point is at the first equal sign marker."
(org-element--parse-generic-emphasis "=" 'verbatim))
(defun org-element-verbatim-interpreter (verbatim _)
"Interpret VERBATIM object as Org syntax."
(format "=%s=" (org-element-property :value verbatim)))
;;; Parsing Element Starting At Point
;;
;; `org-element--current-element' is the core function of this section.
;; It returns the Lisp representation of the element starting at
;; point.
(defconst org-element--current-element-re
(rx-to-string
`(or
(group-n 1 (regexp ,org-element--latex-begin-environment-nogroup))
(group-n 2 (regexp ,org-element-drawer-re-nogroup))
(group-n 3 (regexp "[ \t]*:\\( \\|$\\)"))
(group-n 7 (regexp ,org-element-dynamic-block-open-re-nogroup))
(seq (group-n 4 (regexp "[ \t]*#\\+"))
(or
(seq "BEGIN_" (group-n 5 (1+ (not space))))
(group-n 6 "CALL:")
(group-n 8 (1+ (not space)) ":")))
(group-n 9 (regexp ,org-footnote-definition-re))
(group-n 10 (regexp "[ \t]*-----+[ \t]*$"))
(group-n 11 "%%(")))
"Bulk regexp matching multiple elements in a single regexp.
This is a bit more efficient compared to invoking regexp search
multiple times.")
(defvar org-inlinetask-min-level); Declared in org-inlinetask.el
(defvar org-element--cache-sync-requests); Declared later
(defsubst org-element--current-element (limit &optional granularity mode structure)
"Parse the element starting at point.
Return value is a list like (TYPE PROPS) where TYPE is the type
of the element and PROPS a plist of properties associated to the
element.
Possible types are defined in `org-element-all-elements'.
LIMIT bounds the search.
Optional argument GRANULARITY determines the depth of the
recursion. Allowed values are `headline', `greater-element',
`element', `object' or nil. When it is broader than `object' (or
nil), secondary values will not be parsed, since they only
contain objects.
Optional argument MODE, when non-nil, can be either
`first-section', `item', `node-property', `planning',
`property-drawer', `section', `table-row', or `top-comment'.
If STRUCTURE isn't provided but MODE is set to `item', it will be
computed.
This function assumes point is always at the beginning of the
element it has to parse."
(save-excursion
(let ((case-fold-search t)
;; Determine if parsing depth allows for secondary strings
;; parsing. It only applies to elements referenced in
;; `org-element-secondary-value-alist'.
(raw-secondary-p (and granularity (not (eq granularity 'object))))
result at-task?)
(setq
result
;; Regexp matches below should avoid modifying match data,
;; if possible. Doing it unnecessarily degrades regexp
;; matching performance an order of magnitude, which
;; becomes important when parsing large buffers with huge
;; amount of elements to be parsed.
;;
;; In general, the checks below should be as efficient as
;; possible, especially early in the `cond' form. (The
;; early checks will contribute to all subsequent parsers as
;; well).
(cond
;; Item.
((eq mode 'item) (org-element-item-parser limit structure raw-secondary-p))
;; Table Row.
((eq mode 'table-row) (org-element-table-row-parser limit))
;; Node Property.
((eq mode 'node-property) (org-element-node-property-parser limit))
;; Headline.
((and (looking-at-p "^\\*+ ")
(setq at-task? t)
(or (not (featurep 'org-inlinetask))
(save-excursion
(< (skip-chars-forward "*")
(if org-odd-levels-only
(1- (* org-inlinetask-min-level 2))
org-inlinetask-min-level)))))
(org-element-headline-parser limit raw-secondary-p))
;; Sections (must be checked after headline).
((memq mode '(section first-section)) (org-element-section-parser nil))
;; Comments.
((looking-at-p org-comment-regexp) (org-element-comment-parser limit))
;; Planning.
((and (eq mode 'planning)
(eq ?* (char-after (line-beginning-position 0)))
(looking-at-p org-element-planning-line-re))
(org-element-planning-parser limit))
;; Property drawer.
((and (pcase mode
(`planning (eq ?* (char-after (line-beginning-position 0))))
((or `property-drawer `top-comment)
;; See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=63225#80
(save-excursion
(forward-line -1) ; faster than beginning-of-line
(skip-chars-forward "[:blank:]") ; faster than looking-at-p
(or (not (eolp)) ; very cheap
;; Document-wide property drawer may be preceded by blank lines.
(progn (skip-chars-backward " \t\n\r") (bobp)))))
(_ nil))
(looking-at-p org-property-drawer-re))
(org-element-property-drawer-parser limit))
;; When not at bol, point is at the beginning of an item or
;; a footnote definition: next item is always a paragraph.
((not (bolp)) (org-element-paragraph-parser limit (list (point))))
;; Clock.
((looking-at-p org-element-clock-line-re) (org-element-clock-parser limit))
;; Inlinetask.
(at-task? (org-element-inlinetask-parser limit raw-secondary-p))
;; From there, elements can have affiliated keywords.
;; Note an edge case with a keyword followed by element that
;; cannot have affiliated keywords attached (the above).
;; `org-element--collect-affiliated-keywords' must have a
;; special check to fall back to parsing proper keyword.
(t (let ((affiliated (org-element--collect-affiliated-keywords
limit (memq granularity '(nil object)))))
(cond
;; Jumping over affiliated keywords put point off-limits.
;; Parse them as regular keywords.
((and (cdr affiliated) (>= (point) limit))
(goto-char (car affiliated))
(org-element-keyword-parser limit nil))
;; Do a single regexp match do reduce overheads for
;; multiple regexp search invocations.
((looking-at org-element--current-element-re)
(cond
;; LaTeX Environment.
((match-beginning 1)
(org-element-latex-environment-parser limit affiliated))
;; Drawer.
((match-beginning 2)
(org-element-drawer-parser limit affiliated))
;; Fixed Width
((match-beginning 3)
(org-element-fixed-width-parser limit affiliated))
;; Inline Comments, Blocks, Babel Calls, Dynamic Blocks and
;; Keywords.
((match-beginning 5)
(funcall (pcase (upcase (match-string 5))
("CENTER" #'org-element-center-block-parser)
("COMMENT" #'org-element-comment-block-parser)
("EXAMPLE" #'org-element-example-block-parser)
("EXPORT" #'org-element-export-block-parser)
("QUOTE" #'org-element-quote-block-parser)
("SRC" #'org-element-src-block-parser)
("VERSE" #'org-element-verse-block-parser)
(_ #'org-element-special-block-parser))
limit
affiliated))
((match-beginning 6)
(org-element-babel-call-parser limit affiliated))
((match-beginning 7)
(forward-line 0)
(org-element-dynamic-block-parser limit affiliated))
((match-beginning 8)
(org-element-keyword-parser limit affiliated))
((match-beginning 4) ;; #+, not matching a specific element.
(org-element-paragraph-parser limit affiliated))
;; Footnote Definition.
((match-beginning 9)
(org-element-footnote-definition-parser limit affiliated))
;; Horizontal Rule.
((match-beginning 10)
(org-element-horizontal-rule-parser limit affiliated))
;; Diary Sexp.
((match-beginning 11)
(org-element-diary-sexp-parser limit affiliated))))
;; Table.
((or (looking-at-p "[ \t]*|")
;; There is no strict definition of a table.el
;; table. Try to prevent false positive while being
;; quick.
(let ((rule-regexp
(rx (zero-or-more (any " \t"))
"+"
(one-or-more (one-or-more "-") "+")
(zero-or-more (any " \t"))
eol))
(non-table.el-line
(rx bol
(zero-or-more (any " \t"))
(or eol (not (any "+| \t")))))
(next (line-beginning-position 2)))
;; Start with a full rule.
(and
(looking-at-p rule-regexp)
(< next limit) ;no room for a table.el table
(save-excursion
(end-of-line)
(cond
;; Must end with a full rule.
((not (re-search-forward non-table.el-line limit 'move))
(if (bolp) (forward-line -1) (forward-line 0))
(looking-at-p rule-regexp))
;; Ignore pseudo-tables with a single
;; rule.
((= next (line-beginning-position))
nil)
;; Must end with a full rule.
(t
(forward-line -1)
(looking-at-p rule-regexp)))))))
(org-element-table-parser limit affiliated))
;; List.
((looking-at-p (org-item-re))
(org-element-plain-list-parser
limit affiliated
(or structure (org-element--list-struct limit))))
;; Default element: Paragraph.
(t (org-element-paragraph-parser limit affiliated)))))))
(when result
(org-element-put-property result :buffer (current-buffer))
(org-element-put-property result :mode mode)
(org-element-put-property result :granularity granularity))
result)))
;; Most elements can have affiliated keywords. When looking for an
;; element beginning, we want to move before them, as they belong to
;; that element, and, in the meantime, collect information they give
;; into appropriate properties. Hence the following function.
(defun org-element--collect-affiliated-keywords (limit parse)
"Collect affiliated keywords from point down to LIMIT.
Return a list whose CAR is the position at the first of them and
CDR a plist of keywords and values and move point to the
beginning of the first line after them.
As a special case, if element doesn't start at the beginning of
the line (e.g., a paragraph starting an item), CAR is current
position of point and CDR is nil.
When PARSE is non-nil, values from keywords belonging to
`org-element-parsed-keywords' are parsed as secondary strings."
(if (not (bolp)) (list (point))
(let ((case-fold-search t)
(origin (point))
;; RESTRICT is the list of objects allowed in parsed
;; keywords value. If PARSE is nil, no object is allowed.
(restrict (and parse (org-element-restriction 'keyword)))
output)
(while (and (< (point) limit) (looking-at org-element--affiliated-re))
(let* ((raw-kwd (upcase (match-string 1)))
;; Apply translation to RAW-KWD. From there, KWD is
;; the official keyword.
(kwd (or (cdr (assoc raw-kwd
org-element-keyword-translation-alist))
raw-kwd))
;; PARSED? is non-nil when keyword should have its
;; value parsed.
(parsed? (member kwd org-element-parsed-keywords))
;; Find main value for any keyword.
(value-begin (match-end 0))
(value-end
(save-excursion
(end-of-line)
(skip-chars-backward " \t")
(point)))
value
;; If KWD is a dual keyword, find its secondary value.
;; Maybe parse it.
(dual? (member kwd org-element-dual-keywords))
(dual-value
(and dual?
(let ((sec (match-string-no-properties 2)))
(cond
((and sec parsed?)
(org-element--parse-objects
(match-beginning 2) (match-end 2) nil restrict))
(sec sec)))))
;; Attribute a property name to KWD.
(kwd-sym (and kwd (intern (concat ":" (downcase kwd))))))
(setq value
(if parsed?
(org-element--parse-objects
value-begin value-end nil restrict)
(org-trim (buffer-substring-no-properties
value-begin value-end))))
;; Now set final shape for VALUE.
(when dual?
(setq value (and (or value dual-value) (cons value dual-value))))
(when (or (member kwd org-element-multiple-keywords)
;; Attributes can always appear on multiple lines.
(string-match-p "^ATTR_" kwd))
(setq value (nconc (plist-get output kwd-sym) (list value))))
;; Eventually store the new value in OUTPUT.
(setq output (plist-put output kwd-sym value))
;; Move to next keyword.
(forward-line)))
;; If affiliated keywords are orphaned: move back to first one.
;; They will be parsed as a paragraph.
(when (or (looking-at-p "[ \t]*$")
;; Affiliated keywords are not allowed before comments.
(looking-at-p org-comment-regexp)
;; Clock lines are also not allowed.
(looking-at-p org-clock-line-re)
;; Inlinetasks not allowed.
(looking-at-p "^\\*+ "))
(goto-char origin) (setq output nil))
;; Return value.
(cons origin output))))
;;; The Org Parser
;;
;; The two major functions here are `org-element-parse-buffer', which
;; parses Org syntax inside the current buffer, taking into account
;; region, narrowing, or even visibility if specified, and
;; `org-element-parse-secondary-string', which parses objects within
;; a given string.
;;
;; The (almost) almighty `org-element-map' allows applying a function
;; on elements or objects matching some type, and accumulating the
;; resulting values. In an export situation, it also skips unneeded
;; parts of the parse tree.
(defun org-element-parse-buffer (&optional granularity visible-only keep-deferred)
"Recursively parse the current Org mode buffer and return structure.
If narrowing is in effect, only parse the visible part of the
buffer.
This function assumes that current major mode is `org-mode'. When the
major mode is different, the behaviour is undefined.
Optional argument GRANULARITY determines the depth of the
recursion. It can be set to the following symbols:
`headline' Only parse headlines.
`greater-element' Don't recurse into greater elements except
headlines and sections. Thus, elements
parsed are the top-level ones.
`element' Parse everything but objects and plain text.
`object' Parse the complete buffer (default).
When VISIBLE-ONLY is non-nil, don't parse contents of hidden
elements.
When KEEP-DEFERRED is non-nil, do not resolve deferred properties.
An element or object is represented as a list with the
pattern (TYPE PROPERTIES CONTENTS), where :
TYPE is a symbol describing the element or object. See
`org-element-all-elements' and `org-element-all-objects' for an
exhaustive list of such symbols. One can retrieve it with
`org-element-type' function.
PROPERTIES is the list of properties attached to the element or
object, as a plist. Although most of them are specific to the
element or object type, all types share `:begin', `:end',
`:post-blank' and `:parent' properties, which respectively
refer to buffer position where the element or object starts,
ends, the number of white spaces or blank lines after it, and
the element or object containing it. Properties values can be
obtained by using `org-element-property' function.
CONTENTS is a list of elements, objects or raw strings
contained in the current element or object, when applicable.
One can access them with `org-element-contents' function.
The Org buffer has `org-data' as type and nil as properties.
`org-element-map' function can be used to find specific elements
or objects within the parse tree."
(save-excursion
(goto-char (point-min))
(let ((org-data (org-element-org-data-parser))
(gc-cons-threshold #x40000000))
(org-skip-whitespace)
(setq org-data
(org-element--parse-elements
(line-beginning-position) (point-max)
;; Start in `first-section' mode so text before the first
;; headline belongs to a section.
'first-section nil granularity visible-only org-data))
(unless keep-deferred
(org-element-map ; undefer
org-data t
(lambda (el) (org-element-properties-resolve el t))
nil nil nil t))
org-data)))
(defun org-element-parse-secondary-string (string restriction &optional parent)
"Recursively parse objects in STRING and return structure.
RESTRICTION is a symbol limiting the object types that will be
looked after.
Optional argument PARENT, when non-nil, is the element or object
containing the secondary string. It is used to set correctly
`:parent' property within the string.
If STRING is the empty string or nil, return nil."
(cond
((not string) nil)
((equal string "") nil)
(t (let (rtn)
(org-element-with-buffer-copy
:to-buffer (org-get-buffer-create " *Org parse*" t)
:drop-contents t
:drop-visibility t
:drop-narrowing t
:drop-locals nil
;; Transferring local variables may put the temporary buffer
;; into a read-only state. Make sure we can insert STRING.
(let ((inhibit-read-only t)) (erase-buffer) (insert string))
;; Prevent "Buffer *temp* modified; kill anyway?".
(restore-buffer-modified-p nil)
(setq rtn
(org-element--parse-objects
(point-min) (point-max) nil restriction parent))
;; Resolve deferred.
(org-element-map rtn t
(lambda (el) (org-element-properties-resolve el t)))
rtn)))))
(defun org-element-map
( data types fun
&optional
info first-match no-recursion
with-affiliated no-undefer)
"Map a function on selected elements or objects.
DATA is a parse tree (for example, returned by
`org-element-parse-buffer'), an element, an object, a string, or a
list of such constructs. TYPES is a symbol or list of symbols of
elements or object types (see `org-element-all-elements' and
`org-element-all-objects' for a complete list of types). FUN is the
function called on the matching element or object. It has to accept
one argument: the element or object itself.
When TYPES is t, call FUN for all the elements and objects.
FUN can also be a Lisp form. The form will be evaluated as function
with symbol `node' bound to the current node.
When optional argument INFO is non-nil, it should be a plist
holding export options. In that case, elements of the parse tree
\\(compared with `eq') not exportable according to `:ignore-list'
property in that property list will be skipped.
When optional argument FIRST-MATCH is non-nil, stop at the first
match for which FUN doesn't return nil, and return that value.
Optional argument NO-RECURSION is a symbol or a list of symbols
representing elements or objects types. `org-element-map' won't
enter any recursive element or object whose type belongs to that
list. Though, FUN can still be applied on them.
When optional argument WITH-AFFILIATED is non-nil, FUN will also
apply to matching objects within parsed affiliated keywords (see
`org-element-parsed-keywords').
When optional argument NO-UNDEFER is non-nil, do not resolve deferred
values.
FUN may throw `:org-element-skip' signal. Then, `org-element-map'
will not recurse into the current element.
Nil values returned from FUN do not appear in the results.
When buffer parse tree is used, elements and objects are generally
traversed in the same order they appear in text with a single
exception of dual keywords where secondary value is traversed after
the mail value.
Examples:
---------
Assuming TREE is a variable containing an Org buffer parse tree,
the following example will return a flat list of all `src-block'
and `example-block' elements in it:
(setq tree (org-element-parse-buffer))
(org-element-map tree \\='(example-block src-block) #\\='identity)
The following snippet will find the first headline with a level
of 1 and a \"phone\" tag, and will return its beginning position:
(org-element-map tree \\='headline
(lambda (hl)
(and (= (org-element-property :level hl) 1)
(member \"phone\" (org-element-property :tags hl))
(org-element-begin hl)))
nil t)
The next example will return a flat list of all `plain-list' type
elements in TREE that are not a sub-list themselves:
(org-element-map tree \\='plain-list #\\='identity nil nil \\='plain-list)
Eventually, this example will return a flat list of all `bold'
type objects containing a `latex-snippet' type object, even
looking into captions:
(org-element-map tree \\='bold
(lambda (b)
(and (org-element-map b \\='latex-snippet #\\='identity nil t) b))
nil nil nil t)"
(declare (indent 2))
;; Ensure TYPES and NO-RECURSION are a list, even of one element.
(when (and types data)
(let* ((ignore-list (plist-get info :ignore-list))
(objects?
(or (eq types t)
(cl-intersection
(cons 'plain-text org-element-all-objects)
(if (listp types) types (list types)))))
(no-recursion
(append
(if (listp no-recursion) no-recursion
(list no-recursion))
(unless objects?
org-element-all-objects)
(unless objects?
;; Do not recurse into elements that can only contain
;; objects.
(cl-set-difference
org-element-all-elements
org-element-greater-elements)))))
(org-element-ast-map
data types fun
ignore-list first-match
no-recursion
;; Affiliated keywords may only contain objects.
(when (and with-affiliated objects?)
(mapcar #'cdr org-element--parsed-properties-alist))
;; Secondary strings may only contain objects.
(not objects?)
no-undefer))))
;; The following functions are internal parts of the parser.
;;
;; The first one, `org-element--parse-elements' acts at the element's
;; level.
;;
;; The second one, `org-element--parse-objects' applies on all objects
;; of a paragraph or a secondary string. It calls
;; `org-element--object-lex' to find the next object in the current
;; container.
(defsubst org-element--next-mode (mode type parent?)
"Return next mode according to current one.
MODE is a symbol representing the expectation about the next
element or object. Meaningful values are `first-section',
`item', `node-property', `planning', `property-drawer',
`section', `table-row', `top-comment', and nil.
TYPE is the type of the current element or object.
If PARENT? is non-nil, assume the next element or object will be
located inside the current one."
(if parent?
(pcase type
(`headline 'section)
((and (guard (eq mode 'first-section)) `section) 'top-comment)
((and (guard (eq mode 'org-data)) `org-data) 'first-section)
((and (guard (not mode)) `org-data) 'first-section)
(`inlinetask 'planning)
(`plain-list 'item)
(`property-drawer 'node-property)
(`section 'planning)
(`table 'table-row))
(pcase mode
(`item 'item)
(`node-property 'node-property)
((and `planning (guard (eq type 'planning))) 'property-drawer)
(`table-row 'table-row)
((and `top-comment (guard (eq type 'comment))) 'property-drawer))))
(defun org-element--parse-elements
(beg end mode structure granularity visible-only acc)
"Parse elements between BEG and END positions.
MODE prioritizes some elements over the others. It can be set to
`first-section', `item', `node-property', `planning',
`property-drawer', `section', `table-row', `top-comment', or nil.
When value is `item', STRUCTURE will be used as the current list
structure.
GRANULARITY determines the depth of the recursion. See
`org-element-parse-buffer' for more information.
When VISIBLE-ONLY is non-nil, don't parse contents of hidden
elements.
Elements are accumulated into ACC."
(save-excursion
(goto-char beg)
;; When parsing only headlines, skip any text before first one.
(when (and (eq granularity 'headline) (not (org-at-heading-p)))
(org-with-limited-levels (outline-next-heading)))
(let (elements)
(while (< (point) end)
;; Visible only: skip invisible parts due to folding.
(if (and visible-only (org-invisible-p nil t))
(progn
(goto-char (org-find-visible))
(when (and (eolp) (not (eobp))) (forward-char)))
;; Find current element's type and parse it accordingly to
;; its category.
(let* ((element (org-element--current-element end granularity mode structure))
(type (org-element-type element))
(cbeg (org-element-contents-begin element)))
(goto-char (org-element-end element))
;; Fill ELEMENT contents by side-effect.
(cond
;; If element has no contents, don't modify it.
((not cbeg))
;; Greater element: parse it between `contents-begin' and
;; `contents-end'. Ensure GRANULARITY allows recursion,
;; or ELEMENT is a headline, in which case going inside
;; is mandatory, in order to get sub-level headings.
((and (memq type org-element-greater-elements)
(or (memq granularity '(element object nil))
(and (eq granularity 'greater-element)
(eq type 'section))
(eq type 'headline)))
(org-element--parse-elements
cbeg (org-element-contents-end element)
;; Possibly switch to a special mode.
(org-element--next-mode mode type t)
(and (memq type '(item plain-list))
(org-element-property :structure element))
granularity visible-only element))
;; ELEMENT has contents. Parse objects inside, if
;; GRANULARITY allows it.
((memq granularity '(object nil))
(org-element--parse-objects
cbeg (org-element-contents-end element) element
(org-element-restriction type))))
(push (org-element-put-property element :parent acc) elements)
;; Update mode.
(setq mode (org-element--next-mode mode type nil)))))
;; Return result.
(org-element-put-property acc :granularity granularity)
(apply #'org-element-set-contents acc (nreverse elements)))))
(defun org-element--object-lex (restriction)
"Return next object in current buffer or nil.
RESTRICTION is a list of object types, as symbols, that should be
looked after. This function assumes that the buffer is narrowed
to an appropriate container (e.g., a paragraph)."
(let (result)
(setq
result
(cond
((memq 'table-cell restriction) (org-element-table-cell-parser))
((memq 'citation-reference restriction)
(org-element-citation-reference-parser))
(t
(let* ((start (point))
(limit
;; Object regexp sometimes needs to have a peek at
;; a character ahead. Therefore, when there is a hard
;; limit, make it one more than the true beginning of the
;; radio target.
(save-excursion
(cond ((not org-target-link-regexp) nil)
((not (memq 'link restriction)) nil)
((progn
(unless (bolp) (forward-char -1))
(not
(if org-target-link-regexps
(org--re-list-search-forward org-target-link-regexps nil t)
(re-search-forward org-target-link-regexp nil t))))
nil)
;; Since we moved backward, we do not want to
;; match again an hypothetical 1-character long
;; radio link before us. Realizing that this can
;; only happen if such a radio link starts at
;; beginning of line, we prevent this here.
((and (= start (1+ (line-beginning-position)))
(= start (match-end 1)))
(and
(if org-target-link-regexps
(org--re-list-search-forward org-target-link-regexps nil t)
(re-search-forward org-target-link-regexp nil t))
(1+ (match-beginning 1))))
(t (1+ (match-beginning 1))))))
found)
(save-excursion
(while (and (not found)
(re-search-forward org-element--object-regexp limit 'move))
(goto-char (match-beginning 0))
(let ((result (match-string 0)))
(setq found
(cond
((string-prefix-p "call_" result t)
(and (memq 'inline-babel-call restriction)
(org-element-inline-babel-call-parser)))
((string-prefix-p "src_" result t)
(and (memq 'inline-src-block restriction)
(org-element-inline-src-block-parser)))
(t
(pcase (char-after)
(?^ (and (memq 'superscript restriction)
(org-element-superscript-parser)))
(?_ (or (and (memq 'underline restriction)
(org-element-underline-parser))
(and (memq 'subscript restriction)
(org-element-subscript-parser))))
(?* (and (memq 'bold restriction)
(org-element-bold-parser)))
(?/ (and (memq 'italic restriction)
(org-element-italic-parser)))
(?~ (and (memq 'code restriction)
(org-element-code-parser)))
(?= (and (memq 'verbatim restriction)
(org-element-verbatim-parser)))
(?+ (and (memq 'strike-through restriction)
(org-element-strike-through-parser)))
(?@ (and (memq 'export-snippet restriction)
(org-element-export-snippet-parser)))
(?{ (and (memq 'macro restriction)
(org-element-macro-parser)))
(?$ (and (memq 'latex-fragment restriction)
(org-element-latex-fragment-parser)))
(?<
(if (eq (aref result 1) ?<)
(or (and (memq 'radio-target restriction)
(org-element-radio-target-parser))
(and (memq 'target restriction)
(org-element-target-parser)))
(or (and (memq 'timestamp restriction)
(org-element-timestamp-parser))
(and (memq 'link restriction)
(org-element-link-parser)))))
(?\\
(if (eq (aref result 1) ?\\)
(and (memq 'line-break restriction)
(org-element-line-break-parser))
(or (and (memq 'entity restriction)
(org-element-entity-parser))
(and (memq 'latex-fragment restriction)
(org-element-latex-fragment-parser)))))
(?\[
(pcase (aref result 1)
((and ?\[
(guard (memq 'link restriction)))
(org-element-link-parser))
((and ?f
(guard (memq 'footnote-reference restriction)))
(org-element-footnote-reference-parser))
((and ?c
(guard (memq 'citation restriction)))
(org-element-citation-parser))
((and (or ?% ?/)
(guard (memq 'statistics-cookie restriction)))
(org-element-statistics-cookie-parser))
(_
(or (and (memq 'timestamp restriction)
(org-element-timestamp-parser))
(and (memq 'statistics-cookie restriction)
(org-element-statistics-cookie-parser))))))
;; This is probably a plain link.
(_ (and (memq 'link restriction)
(org-element-link-parser)))))))
(or (eobp) (forward-char))))
(cond (found)
(limit (forward-char -1)
(org-element-link-parser)) ;radio link
(t nil)))))))
(org-element-put-property result :buffer (current-buffer))))
(defun org-element--parse-objects (beg end acc restriction &optional parent)
"Parse objects between BEG and END and return recursive structure.
Objects are accumulated in ACC. RESTRICTION is a list of object
successors which are allowed in the current object.
ACC becomes the parent for all parsed objects. However, if ACC
is nil (i.e., a secondary string is being parsed) and optional
argument PARENT is non-nil, use it as the parent for all objects.
Eventually, if both ACC and PARENT are nil, the common parent is
the list of objects itself."
(save-excursion
(save-restriction
(narrow-to-region beg end)
(goto-char (point-min))
(let (next-object contents)
(while (and (not (eobp))
(setq next-object (org-element--object-lex restriction)))
;; Text before any object.
(let ((obj-beg (org-element-begin next-object)))
(unless (= (point) obj-beg)
(let ((text (buffer-substring-no-properties (point) obj-beg)))
(push (if acc (org-element-put-property text :parent acc) text)
contents))))
;; Object...
(let ((obj-end (org-element-end next-object))
(cont-beg (org-element-contents-begin next-object)))
(when acc (org-element-put-property next-object :parent acc))
(push (if cont-beg
;; Fill contents of NEXT-OBJECT if possible.
(org-element--parse-objects
cont-beg
(org-element-contents-end next-object)
next-object
(org-element-restriction next-object))
next-object)
contents)
(goto-char obj-end)))
;; Text after last object.
(unless (eobp)
(let ((text (buffer-substring-no-properties (point) end)))
(push (if acc (org-element-put-property text :parent acc) text)
contents)))
;; Result. Set appropriate parent.
(if acc (apply #'org-element-set-contents acc (nreverse contents))
(let* ((contents (nreverse contents))
(parent (or parent contents)))
(dolist (datum contents contents)
(org-element-put-property datum :parent parent))))))))
;;; Towards A Bijective Process
;;
;; The parse tree obtained with `org-element-parse-buffer' is really
;; a snapshot of the corresponding Org buffer. Therefore, it can be
;; interpreted and expanded into a string with canonical Org syntax.
;; Hence `org-element-interpret-data'.
;;
;; The function relies internally on
;; `org-element--interpret-affiliated-keywords'.
;;;###autoload
(defun org-element-interpret-data (data)
"Interpret DATA as Org syntax.
DATA is a parse tree, an element, an object or a secondary string
to interpret. Return Org syntax as a string."
(letrec ((fun
(lambda (data parent)
(let* ((type (org-element-type data))
;; Find interpreter for current object or
;; element. If it doesn't exist (e.g. this is
;; a pseudo object or element), return contents,
;; if any.
(interpret
(let ((fun (intern
(format "org-element-%s-interpreter" type))))
(if (fboundp fun) fun (lambda (_ contents) contents))))
(results
(cond
;; Secondary string.
((eq type 'anonymous)
(mapconcat (lambda (obj) (funcall fun obj parent))
data
""))
;; Full Org document.
((eq type 'org-data)
(mapconcat (lambda (obj) (funcall fun obj parent))
(org-element-contents data)
""))
;; Plain text: return it.
((stringp data) data)
;; Element or object without contents.
((not (org-element-contents data))
(funcall interpret data nil))
;; Element or object with contents.
(t
(funcall
interpret
data
;; Recursively interpret contents.
(mapconcat
(lambda (datum) (funcall fun datum data))
(org-element-contents
(if (not (memq type '(paragraph verse-block)))
data
;; Fix indentation of elements containing
;; objects. We ignore `table-row'
;; elements as they are one line long
;; anyway.
(org-element-normalize-contents
data
;; When normalizing first paragraph of
;; an item or a footnote-definition,
;; ignore first line's indentation.
(and (eq type 'paragraph)
(org-element-type-p
parent '(footnote-definition item))
(eq data (car (org-element-contents parent)))
(eq (org-element-property :pre-blank parent)
0)))))
""))))))
(if (memq type '(org-data anonymous)) results
;; Build white spaces. If no `:post-blank' property
;; is specified, assume its value is 0.
(let ((blank (or (org-element-post-blank data) 0)))
(if (eq (org-element-class data parent) 'object)
(concat results (make-string blank ?\s))
(concat (org-element--interpret-affiliated-keywords data)
(org-element-normalize-string results)
(make-string blank ?\n)))))))))
(funcall fun data nil)))
(defun org-element--interpret-affiliated-keywords (element)
"Return ELEMENT's affiliated keywords as Org syntax.
If there is no affiliated keyword, return the empty string."
(let ((keyword-to-org
(lambda (key value)
(let (dual)
(when (member key org-element-dual-keywords)
(setq dual (cdr value) value (car value)))
(concat "#+" (downcase key)
(and dual
(format "[%s]" (org-element-interpret-data dual)))
": "
(if (member key org-element-parsed-keywords)
(org-element-interpret-data value)
value)
"\n")))))
(mapconcat
(lambda (prop)
(let ((value (org-element-property prop element))
(keyword (upcase (substring (symbol-name prop) 1))))
(when value
(if (or (member keyword org-element-multiple-keywords)
;; All attribute keywords can have multiple lines.
(string-match-p "^ATTR_" keyword))
(mapconcat (lambda (line) (funcall keyword-to-org keyword line))
value "")
(funcall keyword-to-org keyword value)))))
;; List all ELEMENT's properties matching an attribute line or an
;; affiliated keyword, but ignore translated keywords since they
;; cannot belong to the property list.
(let (acc)
(org-element-properties-mapc
(lambda (prop _ __)
(let ((keyword (upcase (substring (symbol-name prop) 1))))
(when (or (string-match-p "^ATTR_" keyword)
(and
(member keyword org-element-affiliated-keywords)
(not (assoc keyword
org-element-keyword-translation-alist))))
(push prop acc))))
element t)
(nreverse acc))
"")))
;; Because interpretation of the parse tree must return the same
;; number of blank lines between elements and the same number of white
;; space after objects, some special care must be given to white
;; spaces.
;;
;; The first function, `org-element-normalize-string', ensures any
;; string different from the empty string will end with a single
;; newline character.
;;
;; The second function, `org-element-normalize-contents', removes
;; global indentation from the contents of the current element.
(defun org-element-normalize-string (s)
"Ensure string S ends with a single newline character.
If S isn't a string return it unchanged. If S is the empty
string, return it. Otherwise, return a new string with a single
newline character at its end."
(cond
((not (stringp s)) s)
((string= "" s) "")
(t (and (string-match "\\(\n[ \t]*\\)*\\'" s)
(replace-match "\n" nil nil s)))))
(defun org-element-normalize-contents (element &optional ignore-first)
"Normalize plain text in ELEMENT's contents.
ELEMENT must only contain plain text and objects.
If optional argument IGNORE-FIRST is non-nil, ignore first line's
indentation to compute maximal common indentation.
Return the normalized element that is element with global
indentation removed from its contents."
(letrec ((find-min-ind
;; Return minimal common indentation within BLOB. This is
;; done by walking recursively BLOB and updating MIN-IND
;; along the way. FIRST-FLAG is non-nil when the next
;; object is expected to be a string that doesn't start
;; with a newline character. It happens for strings at
;; the beginnings of the contents or right after a line
;; break.
(lambda (blob first-flag min-ind)
(dolist (datum (org-element-contents blob) min-ind)
(when first-flag
(setq first-flag nil)
(cond
;; Objects cannot start with spaces: in this
;; case, indentation is 0.
((not (stringp datum)) (throw :zero 0))
((not (string-match
"\\`\\([ \t]+\\)\\([^ \t\n]\\|\n\\|\\'\\)" datum))
(throw :zero 0))
((equal (match-string 2 datum) "\n")
(put-text-property
(match-beginning 1) (match-end 1) 'org-ind 'empty datum))
(t
(let ((i (string-width (match-string 1 datum))))
(put-text-property
(match-beginning 1) (match-end 1) 'org-ind i datum)
(setq min-ind (min i min-ind))))))
(cond
((stringp datum)
(let ((s 0))
(while (string-match
"\n\\([ \t]*\\)\\([^ \t\n]\\|\n\\|\\'\\)" datum s)
(setq s (match-end 1))
(cond
((equal (match-string 1 datum) "")
(unless (member (match-string 2 datum) '("" "\n"))
(throw :zero 0)))
((equal (match-string 2 datum) "\n")
(put-text-property (match-beginning 1) (match-end 1)
'org-ind 'empty datum))
(t
(let ((i (string-width (match-string 1 datum))))
(put-text-property (match-beginning 1) (match-end 1)
'org-ind i datum)
(setq min-ind (min i min-ind))))))))
((org-element-type-p datum 'line-break)
(setq first-flag t))
((org-element-type-p datum org-element-recursive-objects)
(setq min-ind
(funcall find-min-ind datum first-flag min-ind)))))))
(min-ind
(catch :zero
(funcall find-min-ind
element (not ignore-first) most-positive-fixnum))))
(if (or (zerop min-ind) (= min-ind most-positive-fixnum)) element
;; Build ELEMENT back, replacing each string with the same
;; string minus common indentation.
(letrec ((build
(lambda (datum)
;; Return DATUM with all its strings indentation
;; shortened from MIN-IND white spaces.
(apply
#'org-element-set-contents
datum
(mapcar
(lambda (object)
(cond
((stringp object)
(with-temp-buffer
(insert object)
(let ((s (point-min)))
(while (setq s (text-property-not-all
s (point-max) 'org-ind nil))
(goto-char s)
(let ((i (get-text-property s 'org-ind)))
(delete-region s (progn
(skip-chars-forward " \t")
(point)))
(when (integerp i) (indent-to (- i min-ind))))))
(buffer-string)))
((org-element-type-p object org-element-recursive-objects)
(funcall build object))
(t object)))
(org-element-contents datum)))
datum)))
(funcall build element)))))
;;; Cache
;;
;; Implement a caching mechanism for `org-element-at-point', `org-element-context', and for
;; fast mapping across Org elements in `org-element-cache-map', which see.
;;
;; When cache is enabled, the elements returned by `org-element-at-point' and
;; `org-element-context' are returned by reference. Altering these elements will
;; also alter their cache representation. The same is true for
;; elements passed to mapping function in `org-element-cache-map'.
;;
;; Public functions are: `org-element-cache-reset', `org-element-cache-refresh', and
;; `org-element-cache-map'.
;;
;; Cache can be controlled using `org-element-use-cache' and `org-element-cache-persistent'.
;; `org-element-cache-sync-idle-time', `org-element-cache-sync-duration' and
;; `org-element-cache-sync-break' can be tweaked to control caching behavior.
;;
;; Internally, parsed elements are stored in an AVL tree,
;; `org-element--cache'. This tree is updated lazily: whenever
;; a change happens to the buffer, a synchronization request is
;; registered in `org-element--cache-sync-requests' (see
;; `org-element--cache-submit-request'). During idle time, requests
;; are processed by `org-element--cache-sync'. Synchronization also
;; happens when an element is required from the cache. In this case,
;; the process stops as soon as the needed element is up-to-date.
;;
;; A synchronization request can only apply on a synchronized part of
;; the cache. Therefore, the cache is updated at least to the
;; location where the new request applies. Thus, requests are ordered
;; from left to right and all elements starting before the first
;; request are correct. This property is used by functions like
;; `org-element--cache-find' to retrieve elements in the part of the
;; cache that can be trusted.
;;
;; A request applies to every element, starting from its original
;; location (or key, see below). When a request is processed, it
;; moves forward and may collide the next one. In this case, both
;; requests are merged into a new one that starts from that element.
;; As a consequence, the whole synchronization complexity does not
;; depend on the number of pending requests, but on the number of
;; elements the very first request will be applied on.
;;
;; Elements cannot be accessed through their beginning position, which
;; may or may not be up-to-date. Instead, each element in the tree is
;; associated to a key, obtained with `org-element--cache-key'. This
;; mechanism is robust enough to preserve total order among elements
;; even when the tree is only partially synchronized.
;;
;; The cache code debugging is fairly complex because cache request
;; state is often hard to reproduce. An extensive diagnostics
;; functionality is built into the cache code to assist hunting bugs.
;; See `org-element--cache-self-verify', `org-element--cache-self-verify-frequency',
;; `org-element--cache-diagnostics', `org-element--cache-diagnostics-level',
;; `org-element--cache-diagnostics-ring-size', `org-element--cache-map-statistics',
;; `org-element--cache-map-statistics-threshold'.
;;;###autoload
(defvar org-element-use-cache t
"Non-nil when Org parser should cache its results.")
(defvar org-element-cache-persistent t
"Non-nil when cache should persist between Emacs sessions.")
(defconst org-element-cache-version "2.3"
"Version number for Org AST structure.
Used to avoid loading obsolete AST representation when using
`org-element-cache-persistent'.")
(defvar org-element-cache-sync-idle-time 0.6
"Length, in seconds, of idle time before syncing cache.")
(defvar org-element-cache-sync-duration 0.04
"Maximum duration, as a time value, for a cache synchronization.
If the synchronization is not over after this delay, the process
pauses and resumes after `org-element-cache-sync-break'
seconds.")
(defvar org-element-cache-sync-break 0.3
"Duration, as a time value, of the pause between synchronizations.
See `org-element-cache-sync-duration' for more information.")
(defvar org-element--cache-self-verify nil
"Activate extra consistency checks for the cache.
This may cause serious performance degradation depending on the value
of `org-element--cache-self-verify-frequency'.
When set to symbol `backtrace', record and display backtrace log if
any inconsistency is detected.")
(defvar org-element--cache-self-verify-before-persisting nil
"Perform consistency checks for the cache before writing to disk.
When non-nil, signal an error an show backtrace if cache contains
incorrect elements. `org-element--cache-self-verify' must be set to
symbol `backtrace' to have non-empty backtrace displayed.")
(defvar org-element--cache-self-verify-frequency 0.03
"Frequency of cache element verification.
This number is a probability to check an element requested from cache
to be correct. Setting this to a value less than 0.0001 is useless.")
(defvar org-element--cache-diagnostics nil
"Print detailed diagnostics of cache processing.")
(defvar org-element--cache-map-statistics nil
"Print statistics for `org-element-cache-map'.")
(defvar org-element--cache-map-statistics-threshold 0.1
"Time threshold in seconds to log statistics for `org-element-cache-map'.")
(defvar org-element--cache-diagnostics-level 2
"Detail level of the diagnostics.")
(defvar-local org-element--cache-diagnostics-ring nil
"Ring containing cache process log entries.
The ring size is `org-element--cache-diagnostics-ring-size'.")
(defvar org-element--cache-diagnostics-ring-size 5000
"Size of `org-element--cache-diagnostics-ring'.")
;;;; Data Structure
(defvar-local org-element--cache nil
"AVL tree used to cache elements.
Each node of the tree contains an element. Comparison is done
with `org-element--cache-compare'. This cache is used in
`org-element-at-point'.")
(defvar-local org-element--headline-cache nil
"AVL tree used to cache headline and inlinetask elements.
Each node of the tree contains an element. Comparison is done
with `org-element--cache-compare'. This cache is used in
`org-element-cache-map'.")
(defconst org-element--cache-hash-size 16
"Cache size for recent cached calls to `org-element--cache-find'.
This extra caching is based on the following paper:
Pugh [Information Processing Letters] (1990) Slow optimally balanced
search strategies vs. cached fast uniformly balanced search
strategies. http://dx.doi.org/10.1016/0020-0190(90)90130-P
Also, see `org-element--cache-hash-left' and `org-element--cache-hash-right'.")
(defvar-local org-element--cache-hash-left nil
"Cached elements from `org-element--cache' for fast O(1) lookup.
When non-nil, it should be a vector representing POS arguments of
`org-element--cache-find' called with nil SIDE argument.
Also, see `org-element--cache-hash-size'.")
(defvar-local org-element--cache-hash-right nil
"Cached elements from `org-element--cache' for fast O(1) lookup.
When non-nil, it should be a vector representing POS arguments of
`org-element--cache-find' called with non-nil, non-`both' SIDE argument.
Also, see `org-element--cache-hash-size'.")
(defvar-local org-element--cache-size 0
"Size of the `org-element--cache'.
Storing value is variable is faster because `avl-tree-size' is O(N).")
(defvar-local org-element--headline-cache-size 0
"Size of the `org-element--headline-cache'.
Storing value is variable is faster because `avl-tree-size' is O(N).")
(defvar-local org-element--cache-sync-requests nil
"List of pending synchronization requests.
A request is a vector with the following pattern:
[NEXT BEG END OFFSET PARENT PHASE]
Processing a synchronization request consists of three phases:
0. Delete modified elements,
1. Fill missing area in cache,
2. Shift positions and re-parent elements after the changes.
During phase 0, NEXT is the key of the first element to be
removed, BEG and END is buffer position delimiting the
modifications. Elements starting between them (inclusive) are
removed. So are elements whose parent is removed. PARENT, when
non-nil, is the common parent of all the elements between BEG and END.
It is guaranteed that only a single phase 0 request exists at any
moment of time. If it does, it must be the first request in the list.
During phase 1, NEXT is the key of the next known element in
cache and BEG its beginning position. Parse buffer between that
element and the one before it in order to determine the parent of
the next element. Set PARENT to the element containing NEXT.
During phase 2, NEXT is the key of the next element to shift in
the parse tree. All elements starting from this one have their
properties relative to buffer positions shifted by integer
OFFSET and, if they belong to element PARENT, are adopted by it.
PHASE specifies the phase number, as an integer.
For any synchronization request, all the later requests in the cache
must not start at or before END. See `org-element--cache-submit-request'.")
(defvar-local org-element--cache-sync-timer nil
"Timer used for cache synchronization.")
(defvar-local org-element--cache-sync-keys-value nil
"Id value used to identify keys during synchronization.
See `org-element--cache-key' for more information.")
(defvar-local org-element--cache-change-tic nil
"Last `buffer-chars-modified-tick' for registered changes.")
(defvar-local org-element--cache-last-buffer-size nil
"Last value of `buffer-size' for registered changes.")
(defvar org-element--cache-non-modifying-commands
'(org-agenda
org-agenda-redo
org-sparse-tree
org-occur
org-columns
org-columns-redo
org-columns-new
org-columns-delete
org-columns-compute
org-columns-insert-dblock
org-agenda-columns
org-ctrl-c-ctrl-c)
"List of commands that are not expected to change the cache state.
This variable is used to determine when re-parsing buffer is not going
to slow down the command.
If the commands end up modifying the cache, the worst case scenario is
performance drop. So, advising these commands is safe. Yet, it is
better to remove the commands advised in such a way from this list.")
(defmacro org-element--request-key (request)
"Get NEXT part of a `org-element--cache-sync-requests' REQUEST."
`(aref ,request 0))
(defmacro org-element--request-beg (request)
"Get BEG part of a `org-element--cache-sync-requests' REQUEST."
`(aref ,request 1))
(defmacro org-element--request-end (request)
"Get END part of a `org-element--cache-sync-requests' REQUEST."
`(aref ,request 2))
(defmacro org-element--request-offset (request)
"Get OFFSET part of a `org-element--cache-sync-requests' REQUEST."
`(aref ,request 3))
(defmacro org-element--request-parent (request)
"Get PARENT part of a `org-element--cache-sync-requests' REQUEST."
`(aref ,request 4))
(defmacro org-element--request-phase (request)
"Get PHASE part of a `org-element--cache-sync-requests' REQUEST."
`(aref ,request 5))
(defmacro org-element--format-element (element)
"Format ELEMENT for printing in diagnostics."
`(let ((print-length 50)
(print-level 5))
(prin1-to-string ,element)))
(defmacro org-element--cache-log-message (format-string &rest args)
"Add a new log message for org-element-cache.
FORMAT-STRING and ARGS are the same arguments as in `format'."
`(when (or org-element--cache-diagnostics
(eq org-element--cache-self-verify 'backtrace))
(let* ((format-string (concat (format "org-element-cache diagnostics(%s): "
(buffer-name (current-buffer)))
,format-string))
(format-string (funcall #'format format-string ,@args)))
(if org-element--cache-diagnostics
(display-warning '(org-element org-element-cache) format-string)
(unless org-element--cache-diagnostics-ring
(setq org-element--cache-diagnostics-ring
(make-ring org-element--cache-diagnostics-ring-size)))
(ring-insert org-element--cache-diagnostics-ring format-string)))))
(defmacro org-element--cache-warn (format-string &rest args)
"Raise warning for org-element-cache.
FORMAT-STRING and ARGS are the same arguments as in `format'."
`(let* ((format-string (funcall #'format ,format-string ,@args))
(format-string
(if (or (not org-element--cache-diagnostics-ring)
(not (eq 'backtrace org-element--cache-self-verify)))
format-string
(prog1
(concat (format "Warning(%s): "
(buffer-name (current-buffer)))
format-string
"\nBacktrace:\n "
(mapconcat #'identity
(ring-elements org-element--cache-diagnostics-ring)
"\n "))
(setq org-element--cache-diagnostics-ring nil)))))
(if (and (boundp 'org-batch-test) org-batch-test)
(error "%s" (concat "org-element--cache: " format-string))
(push (concat "org-element--cache: " format-string) org--warnings)
(display-warning '(org-element org-element-cache)
(concat "org-element--cache: " format-string)))))
(defsubst org-element--cache-key (element)
"Return a unique key for ELEMENT in cache tree.
Keys are used to keep a total order among elements in the cache.
Comparison is done with `org-element--cache-key-less-p'.
When no synchronization is taking place, a key is simply the
beginning position of the element, or that position plus one in
the case of an first item (respectively row) in
a list (respectively a table). They key of a section is its beginning
position minus one.
During a synchronization, the key is the one the element had when
the cache was synchronized for the last time. Elements added to
cache during the synchronization get a new key generated with
`org-element--cache-generate-key'.
Such keys are stored inside the element property
`:org-element--cache-sync-key'. The property is a cons containing
current `org-element--cache-sync-keys-value' and the element key."
(or (when-let* ((key-cons (org-element-property :org-element--cache-sync-key element)))
(when (eq org-element--cache-sync-keys-value (car key-cons))
(cdr key-cons)))
(let* ((begin (org-element-begin element))
(type (org-element-type element))
;; Increase beginning position of items (respectively
;; table rows) by one, so the first item can get
;; a different key from its parent list (respectively
;; table).
(key
(cond
((memq type '(item table-row)) (1+ begin))
;; Decrease beginning position of sections by one,
;; so that the first element of the section get
;; different key from the parent section.
((eq type 'section) (1- begin))
((eq type 'org-data) (- begin 2))
(t begin))))
(when org-element--cache-sync-requests
(org-element-put-property
element
:org-element--cache-sync-key
(cons org-element--cache-sync-keys-value key)))
key)))
(defun org-element--cache-generate-key (lower upper)
"Generate a key between LOWER and UPPER.
LOWER and UPPER are fixnums or lists of same, possibly empty.
If LOWER and UPPER are equals, return LOWER. Otherwise, return
a unique key, as an integer or a list of integers, according to
the following rules:
- LOWER and UPPER are compared level-wise until values differ.
- If, at a given level, LOWER and UPPER differ from more than
2, the new key shares all the levels above with LOWER and
gets a new level. Its value is the mean between LOWER and
UPPER:
(1 2) + (1 4) --> (1 3)
- If LOWER has no value to compare with, it is assumed that its
value is `most-negative-fixnum'. E.g.,
(1 1) + (1 1 2)
is equivalent to
(1 1 m) + (1 1 2)
where m is `most-negative-fixnum'. Likewise, if UPPER is
short of levels, the current value is `most-positive-fixnum'.
- If they differ from only one, the new key inherits from
current LOWER level and fork it at the next level. E.g.,
(2 1) + (3 3)
is equivalent to
(2 1) + (2 M)
where M is `most-positive-fixnum'.
- If the key is only one level long, it is returned as an
integer:
(1 2) + (3 2) --> 2
When they are not equals, the function assumes that LOWER is
lesser than UPPER, per `org-element--cache-key-less-p'."
(if (equal lower upper) lower
(let ((lower (if (integerp lower) (list lower) lower))
(upper (if (integerp upper) (list upper) upper))
skip-upper key)
(catch 'exit
(while t
(let ((min (or (car lower) most-negative-fixnum))
(max (cond (skip-upper most-positive-fixnum)
((car upper))
(t most-positive-fixnum))))
(if (< (1+ min) max)
(let ((mean (+ (ash min -1) (ash max -1) (logand min max 1))))
(throw 'exit (if key (nreverse (cons mean key)) mean)))
(when (and (< min max) (not skip-upper))
;; When at a given level, LOWER and UPPER differ from
;; 1, ignore UPPER altogether. Instead create a key
;; between LOWER and the greatest key with the same
;; prefix as LOWER so far.
(setq skip-upper t))
(push min key)
(setq lower (cdr lower) upper (cdr upper)))))))))
(defsubst org-element--cache-key-less-p (a b)
"Non-nil if key A is less than key B.
A and B are either integers or lists of integers, as returned by
`org-element--cache-key'.
Note that it is not reliable to compare buffer position with the cache
keys. They keys may be larger compared to actual element :begin
position."
(if (integerp a) (if (integerp b) (< a b) (<= a (car b)))
(if (integerp b) (< (car a) b)
(catch 'exit
(while (and a b)
(cond ((car-less-than-car a b) (throw 'exit t))
((car-less-than-car b a) (throw 'exit nil))
(t (setq a (cdr a) b (cdr b)))))
;; If A is empty, either keys are equal (B is also empty) and
;; we return nil, or A is lesser than B (B is longer) and we
;; return a non-nil value.
;;
;; If A is not empty, B is necessarily empty and A is greater
;; than B (A is longer). Therefore, return nil.
(and (null a) b)))))
(defsubst org-element--cache-compare (a b)
"Non-nil when element A is located before element B."
(org-element--cache-key-less-p (org-element--cache-key a) (org-element--cache-key b)))
(defsubst org-element--cache-root ()
"Return root value in `org-element--cache' .
This function assumes `org-element--cache' is a valid AVL tree."
(avl-tree--node-left (avl-tree--dummyroot org-element--cache)))
(defsubst org-element--headline-cache-root ()
"Return root value in `org-element--headline-cache' .
This function assumes `org-element--headline-cache' is a valid AVL tree."
(avl-tree--node-left (avl-tree--dummyroot org-element--headline-cache)))
;;;; Tools
;; FIXME: `org-fold-core-cycle-over-indirect-buffers' should better be
;; taken out of org-fold-core to track indirect buffers in general.
(defun org-element--cache-active-p (&optional called-from-cache-change-func-p)
"Non-nil when cache is active in current buffer.
When CALLED-FROM-CACHE-CHANGE-FUNC-P is non-nil, do not assert cache
consistency with buffer modifications."
(org-with-base-buffer nil
(and org-element-use-cache
(or org-element--cache
(when (derived-mode-p 'org-mode)
(org-element-cache-reset)
t))
(or called-from-cache-change-func-p
(eq org-element--cache-change-tic (buffer-chars-modified-tick))
(and
;; org-num-mode calls some Org structure analysis functions
;; that can trigger cache update in the middle of changes. See
;; `org-num--verify' calling `org-num--skip-value' calling
;; `org-entry-get' that uses cache.
;; Forcefully disable cache when called from inside a
;; modification hook, where `inhibit-modification-hooks' is set
;; to t.
(not inhibit-modification-hooks)
;; `combine-change-calls' sets `after-change-functions' to
;; nil. We need not to use cache inside
;; `combine-change-calls' because the buffer is potentially
;; changed without notice (the change will be registered
;; after exiting the `combine-change-calls' body though).
(catch :inhibited
(org-fold-core-cycle-over-indirect-buffers
(unless (memq #'org-element--cache-after-change after-change-functions)
(throw :inhibited nil)))
t))))))
(defun org-element--cache-find (pos &optional side)
"Find element in cache starting at POS or before.
POS refers to a buffer position.
When optional argument SIDE is non-nil, the function checks for
elements starting at or past POS instead. If SIDE is `both', the
function returns a cons cell where car is the first element
starting at or before POS and cdr the first element starting
after POS.
The function can only find elements in the synchronized part of
the cache."
(org-with-base-buffer nil
(let* ((limit (and org-element--cache-sync-requests
(org-element--request-key (car org-element--cache-sync-requests))))
(node (org-element--cache-root))
(hash-pos (unless (eq side 'both)
(mod (org-knuth-hash pos)
org-element--cache-hash-size)))
(hashed (if (not side)
(aref org-element--cache-hash-left hash-pos)
(unless (eq side 'both)
(aref org-element--cache-hash-right hash-pos))))
lower upper)
;; `org-element--cache-key-less-p' does not accept markers.
(when (markerp pos) (setq pos (marker-position pos)))
(if (and hashed (not (eq side 'both))
;; Ensure that HASHED is not within synchronized part
;; of the cache.
(org-element-property :cached hashed)
(or (not limit)
;; Limit can be a list key.
(org-element--cache-key-less-p
(org-element--cache-key hashed)
limit))
;; It is only safe to assume that element at POS is
;; exact. Extra elements starting before/after could
;; have been added to cache and HASHED may no longer be
;; valid.
(= pos (org-element-begin hashed))
;; We cannot rely on element :begin for elements with
;; children starting at the same pos.
(not (org-element-type-p hashed '(section org-data table))))
hashed
;; No appropriate HASHED. Search the cache.
(while node
(let* ((element (avl-tree--node-data node))
(begin (org-element-begin element)))
(cond
((and limit
(not (org-element--cache-key-less-p
(org-element--cache-key element) limit)))
(setq node (avl-tree--node-left node)))
((> begin pos)
(setq upper element
node (avl-tree--node-left node)))
((or (< begin pos)
;; If the element is section or org-data, we also need
;; to check the following element.
(org-element-type-p element '(section org-data)))
(setq lower element
node (avl-tree--node-right node)))
;; We found an element in cache starting at POS. If `side'
;; is `both' we also want the next one in order to generate
;; a key in-between.
;;
;; If the element is the first row or item in a table or
;; a plain list, we always return the table or the plain
;; list.
;;
;; In any other case, we return the element found.
((eq side 'both)
(setq lower element)
(setq node (avl-tree--node-right node)))
((and (org-element-type-p element '(item table-row))
;; Cached elements cannot have deferred `:parent'.
(let ((parent (org-element-property-raw :parent element)))
(and (= (org-element-begin element)
(org-element-contents-begin parent))
(setq node nil
lower parent
upper parent)))))
(t
(setq node nil
lower element
upper element)))))
(pcase side
(`both (cons lower upper))
(`nil
(aset org-element--cache-hash-left hash-pos lower))
(_
(aset org-element--cache-hash-right hash-pos upper)))))))
(defun org-element--cache-put (element)
"Store ELEMENT in current buffer's cache, if allowed."
(org-with-base-buffer nil
(when (org-element--cache-active-p)
(when org-element--cache-sync-requests
;; During synchronization, first build an appropriate key for
;; the new element so `avl-tree-enter' can insert it at the
;; right spot in the cache.
(let* ((keys (org-element--cache-find
(org-element-begin element) 'both))
(new-key (org-element--cache-generate-key
(and (car keys) (org-element--cache-key (car keys)))
(cond ((cdr keys) (org-element--cache-key (cdr keys)))
(org-element--cache-sync-requests
(org-element--request-key (car org-element--cache-sync-requests)))))))
(org-element-put-property
element
:org-element--cache-sync-key
(cons org-element--cache-sync-keys-value new-key))))
(when (>= org-element--cache-diagnostics-level 2)
(org-element--cache-log-message
"Added new element with %S key: %S"
(org-element-property :org-element--cache-sync-key element)
(org-element--format-element element)))
(org-element-put-property element :cached t)
(when (org-element-type-p element '(headline inlinetask))
(cl-incf org-element--headline-cache-size)
(avl-tree-enter org-element--headline-cache element))
(cl-incf org-element--cache-size)
(avl-tree-enter org-element--cache element))))
(defsubst org-element--cache-remove (element)
"Remove ELEMENT from cache.
Assume ELEMENT belongs to cache and that a cache is active."
(org-with-base-buffer nil
(org-element-put-property element :cached nil)
(cl-decf org-element--cache-size)
;; Invalidate contents of parent.
(when (org-element-contents
;; Cached elements cannot have deferred `:parent'.
(org-element-property-raw :parent element))
(org-element-set-contents
(org-element-property-raw :parent element) nil))
(when (org-element-type-p element '(headline inlinetask))
(cl-decf org-element--headline-cache-size)
(avl-tree-delete org-element--headline-cache element))
(org-element--cache-log-message
"Decreasing cache size to %S"
org-element--cache-size)
(when (< org-element--cache-size 0)
(org-element--cache-warn
"Cache grew to negative size in %S when deleting %S at %S. Cache key: %S.
If this warning appears regularly, please report the warning text to Org mode mailing list (M-x org-submit-bug-report)."
(org-element-type element)
(current-buffer)
(org-element-begin element)
(org-element-property :org-element--cache-sync-key element))
(org-element-cache-reset)
(throw 'org-element--cache-quit nil))
(or (avl-tree-delete org-element--cache element)
(progn
;; This should not happen, but if it is, would be better to know
;; where it happens.
(org-element--cache-warn
"Failed to delete %S element in %S at %S. The element cache key was %S.
If this warning appears regularly, please report the warning text to Org mode mailing list (M-x org-submit-bug-report)."
(org-element-type element)
(current-buffer)
(org-element-begin element)
(org-element-property :org-element--cache-sync-key element))
(org-element-cache-reset)
(throw 'org-element--cache-quit nil)))))
;;;; Synchronization
(defsubst org-element--cache-set-timer (buffer)
"Set idle timer for cache synchronization in BUFFER."
(when org-element--cache-sync-timer
(cancel-timer org-element--cache-sync-timer))
(setq org-element--cache-sync-timer
(run-with-idle-timer
(let ((idle (current-idle-time)))
(if idle (time-add idle org-element-cache-sync-break)
org-element-cache-sync-idle-time))
nil
#'org-element--cache-sync
buffer)))
(defsubst org-element--cache-interrupt-p (time-limit)
"Non-nil when synchronization process should be interrupted.
TIME-LIMIT is a time value or nil."
(and time-limit
(or (input-pending-p)
(time-less-p time-limit nil))))
(defsubst org-element--cache-shift-positions (element offset &optional props)
"Shift ELEMENT properties relative to buffer positions by OFFSET.
Properties containing buffer positions are `:begin', `:end',
`:contents-begin', `:contents-end' and `:structure'. When
optional argument PROPS is a list of keywords, only shift
properties provided in that list.
Properties are modified by side-effect."
;; Shift `:structure' property for the first plain list only: it
;; is the only one that really matters and it prevents from
;; shifting it more than once.
(when (and (not (zerop offset))
(or (not props) (memq :structure props))
(org-element-type-p element 'plain-list)
(not (org-element-type-p
;; Cached elements cannot have deferred `:parent'.
(org-element-property-raw :parent element)
'item)))
(let ((structure (org-element-property :structure element)))
(dolist (item structure)
(cl-incf (car item) offset)
(cl-incf (nth 6 item) offset))))
;; Clear :fragile cache when contents is changed.
(when props (org-element-put-property element :fragile-cache nil))
;; Do not use loop for inline expansion to work during compile time.
(unless (zerop offset)
(when (or (not props) (memq :begin props))
(cl-incf (org-element-begin element) offset))
(when (or (not props) (memq :end props))
(cl-incf (org-element-end element) offset))
(when (or (not props) (memq :post-affiliated props))
(cl-incf (org-element-post-affiliated element) offset))
(when (and (or (not props) (memq :contents-begin props))
(org-element-contents-begin element))
(cl-incf (org-element-contents-begin element) offset))
(when (and (or (not props) (memq :contents-end props))
(org-element-contents-end element))
(cl-incf (org-element-contents-end element) offset))
(when (and (or (not props) (memq :robust-begin props))
(org-element-property :robust-begin element))
(cl-incf (org-element-property :robust-begin element) offset))
(when (and (or (not props) (memq :robust-end props))
(org-element-property :robust-end element))
(cl-incf (org-element-property :robust-end element) offset))))
(defvar org-element--cache-interrupt-C-g t
"When non-nil, allow the user to abort `org-element--cache-sync'.
The execution is aborted upon pressing `\\[keyboard-quit]'
`org-element--cache-interrupt-C-g-max-count' times.")
(defvar org-element--cache-interrupt-C-g-max-count 5
"`\\[keyboard-quit]' count to interrupt `org-element--cache-sync'.
See `org-element--cache-interrupt-C-g'.")
(defvar org-element--cache-interrupt-C-g-count 0
"Current number of `org-element--cache-sync' calls.
See `org-element--cache-interrupt-C-g'.")
(defvar org-element--cache-change-warning nil
"Non-nil when a sensitive line is about to be changed.
It is a symbol among nil, t, or a number representing smallest level of
modified headline. The level considers headline levels both before
and after the modification.")
(defun org-element--cache-sync (buffer &optional threshold future-change offset force)
"Synchronize cache with recent modification in BUFFER.
When optional argument THRESHOLD is non-nil, do the
synchronization for all elements starting before or at threshold,
then exit. Otherwise, synchronize cache for as long as
`org-element-cache-sync-duration' or until Emacs leaves idle
state.
FUTURE-CHANGE, when non-nil, is a buffer position where changes
not registered yet in the cache are going to happen. OFFSET is the
change offset. It is used in `org-element--cache-submit-request',
where cache is partially updated before current modification are
actually submitted.
FORCE, when non-nil will force the synchronization even when
`org-element--cache-active-p' returns nil."
(when (buffer-live-p buffer)
(org-with-base-buffer buffer
;; Do not sync when, for example, in the middle of
;; `combine-change-calls'. See the commentary inside
;; `org-element--cache-active-p'. Such situation may occur when
;; sync timer triggers in the middle of `combine-change-calls'.
(when (and org-element--cache-sync-requests
(or force (org-element--cache-active-p)))
;; Check if the buffer have been changed outside visibility of
;; `org-element--cache-before-change' and `org-element--cache-after-change'.
(if (/= org-element--cache-last-buffer-size (buffer-size))
(progn
(org-element--cache-warn
"Unregistered buffer modifications detected (%S != %S). Resetting.
If this warning appears regularly, please report the warning text to Org mode mailing list (M-x org-submit-bug-report).
The buffer is: %s\n Current command: %S\n Backtrace:\n%S"
org-element--cache-last-buffer-size
(buffer-size)
(buffer-name (current-buffer))
this-command
(when (and (fboundp 'backtrace-get-frames)
(fboundp 'backtrace-to-string))
(backtrace-to-string (backtrace-get-frames 'backtrace))))
(org-element-cache-reset))
(let ((inhibit-quit t) request next)
(setq org-element--cache-interrupt-C-g-count 0)
(when org-element--cache-sync-timer
(cancel-timer org-element--cache-sync-timer))
(let ((time-limit (time-add nil org-element-cache-sync-duration)))
(catch 'org-element--cache-interrupt
(when org-element--cache-sync-requests
(org-element--cache-log-message "Syncing down to %S-%S" (or future-change threshold) threshold))
(while org-element--cache-sync-requests
(setq request (car org-element--cache-sync-requests)
next (nth 1 org-element--cache-sync-requests))
(org-element--cache-process-request
request
(when next (org-element--request-key next))
threshold
(unless threshold time-limit)
future-change
offset)
;; Re-assign current and next requests. It could have
;; been altered during phase 1.
(setq request (car org-element--cache-sync-requests)
next (nth 1 org-element--cache-sync-requests))
;; Request processed. Merge current and next offsets and
;; transfer ending position.
(when next
;; The following requests can only be either phase 1
;; or phase 2 requests. We need to let them know
;; that additional shifting happened ahead of them.
(cl-incf (org-element--request-offset next) (org-element--request-offset request))
(org-element--cache-log-message
"Updating next request offset to %S: %s"
(org-element--request-offset next)
(let ((print-length 10) (print-level 3)) (prin1-to-string next)))
;; FIXME: END part of the request only matters for
;; phase 0 requests. However, the only possible
;; phase 0 request must be the first request in the
;; list all the time. END position should be
;; unused.
(setf (org-element--request-end next) (org-element--request-end request)))
(setq org-element--cache-sync-requests
(cdr org-element--cache-sync-requests)))))
;; If more requests are awaiting, set idle timer accordingly.
;; Otherwise, reset keys.
(if org-element--cache-sync-requests
(org-element--cache-set-timer buffer)
;; NOTE: We cannot reset
;; `org-element--cache-change-warning' here as it might
;; still be needed when synchronization is called by
;; `org-element--cache-submit-request' before
;; `org-element--cache-for-removal'.
(setq org-element--cache-sync-keys-value (1+ org-element--cache-sync-keys-value)))))))))
(defun org-element--cache-process-request
(request next-request-key threshold time-limit future-change offset)
"Process synchronization REQUEST for all entries before NEXT.
REQUEST is a vector, built by `org-element--cache-submit-request'.
NEXT-REQUEST-KEY is a cache key of the next request, as returned by
`org-element--cache-key'.
When non-nil, THRESHOLD is a buffer position. Synchronization
stops as soon as a shifted element begins after it.
When non-nil, TIME-LIMIT is a time value. Synchronization stops
after this time or when Emacs exits idle state.
When non-nil, FUTURE-CHANGE is a buffer position where changes not
registered yet in the cache are going to happen. OFFSET is the
changed text length. See `org-element--cache-submit-request' for more
information.
Throw `org-element--cache-interrupt' if the process stops before
completing the request."
(org-with-base-buffer nil
(org-element--cache-log-message
"org-element-cache: Processing request %s up to %S-%S, next: %S"
(let ((print-length 10) (print-level 3)) (prin1-to-string request))
future-change
threshold
next-request-key)
(catch 'org-element--cache-quit
(when (= (org-element--request-phase request) 0)
;; Phase 0.
;;
;; Delete all elements starting after beginning of the element
;; with request key NEXT, but not after buffer position END.
;;
;; At each iteration, we start again at tree root since
;; a deletion modifies structure of the balanced tree.
(org-element--cache-log-message "Phase 0")
(catch 'org-element--cache-end-phase
(let ((deletion-count 0))
(while t
(when (org-element--cache-interrupt-p time-limit)
(org-element--cache-log-message "Interrupt: time limit")
(throw 'org-element--cache-interrupt nil))
(let ((request-key (org-element--request-key request))
(end (org-element--request-end request))
(node (org-element--cache-root))
data data-key)
;; Find first element in cache with key REQUEST-KEY or
;; after it.
(while node
(let* ((element (avl-tree--node-data node))
(key (org-element--cache-key element)))
(cond
((org-element--cache-key-less-p key request-key)
(setq node (avl-tree--node-right node)))
((org-element--cache-key-less-p request-key key)
(setq data element
data-key key
node (avl-tree--node-left node)))
(t (setq data element
data-key key
node nil)))))
(if data
;; We found first element in cache starting at or
;; after REQUEST-KEY.
(let ((pos (org-element-begin data)))
;; FIXME: Maybe simply (< pos end)?
(if (<= pos end)
(progn
(org-element--cache-log-message "removing %S::%S"
(org-element-property :org-element--cache-sync-key data)
(org-element--format-element data))
(cl-incf deletion-count)
(org-element--cache-remove data)
(when (and (> (log org-element--cache-size 2) 10)
(> deletion-count
(/ org-element--cache-size (log org-element--cache-size 2))))
(org-element--cache-log-message "Removed %S>N/LogN(=%S/%S) elements. Resetting cache to prevent performance degradation"
deletion-count
org-element--cache-size
(log org-element--cache-size 2))
(org-element-cache-reset)
(throw 'org-element--cache-quit t)))
;; Done deleting everything starting before END.
;; DATA-KEY is the first known element after END.
;; Move on to phase 1.
(org-element--cache-log-message
"found element after %S: %S::%S"
end
(org-element-property :org-element--cache-sync-key data)
(org-element--format-element data))
(setf (org-element--request-key request) data-key)
(setf (org-element--request-beg request) pos)
(setf (org-element--request-phase request) 1)
(throw 'org-element--cache-end-phase nil)))
;; No element starting after modifications left in
;; cache: further processing is futile.
(org-element--cache-log-message
"Phase 0 deleted all elements in cache after %S!"
request-key)
(throw 'org-element--cache-quit t)))))))
(when (= (org-element--request-phase request) 1)
;; Phase 1.
;;
;; Phase 0 left a hole in the cache. Some elements after it
;; could have parents within. For example, in the following
;; buffer:
;;
;; - item
;;
;;
;; Paragraph1
;;
;; Paragraph2
;;
;; if we remove a blank line between "item" and "Paragraph1",
;; everything down to "Paragraph2" is removed from cache. But
;; the paragraph now belongs to the list, and its `:parent'
;; property no longer is accurate.
;;
;; Therefore we need to parse again elements in the hole, or at
;; least in its last section, so that we can re-parent
;; subsequent elements, during phase 2.
;;
;; Note that we only need to get the parent from the first
;; element in cache after the hole.
;;
;; When next key is lesser or equal to the current one, current
;; request is inside a to-be-shifted part of the cache. It is
;; fine because the order of elements will not be altered by
;; shifting. However, we cannot know the real position of the
;; unshifted NEXT element in the current request. So, we need
;; to sort the request list according to keys and re-start
;; processing from the new leftmost request.
(org-element--cache-log-message "Phase 1")
(let ((key (org-element--request-key request)))
(when (and next-request-key (not (org-element--cache-key-less-p key next-request-key)))
;; In theory, the only case when requests are not
;; ordered is when key of the next request is either the
;; same with current key or it is a key for a removed
;; element. Either way, we can simply merge the two
;; requests.
(let ((next-request (nth 1 org-element--cache-sync-requests)))
(org-element--cache-log-message "Phase 1: Unorderered requests. Merging: %S\n%S\n"
(let ((print-length 10) (print-level 3)) (prin1-to-string request))
(let ((print-length 10) (print-level 3)) (prin1-to-string next-request)))
(setf (org-element--request-key next-request) key)
(setf (org-element--request-beg next-request) (org-element--request-beg request))
(setf (org-element--request-phase next-request) 1)
(throw 'org-element--cache-quit t))))
;; Next element will start at its beginning position plus
;; offset, since it hasn't been shifted yet. Therefore, LIMIT
;; contains the real beginning position of the first element to
;; shift and re-parent.
(let ((limit (+ (org-element--request-beg request) (org-element--request-offset request)))
cached-before)
(cond ((and threshold (> limit threshold))
(org-element--cache-log-message "Interrupt: position %S after threshold %S" limit threshold)
(throw 'org-element--cache-interrupt nil))
((and future-change (>= limit future-change))
;; Changes happened around this element and they will
;; trigger another phase 1 request. Skip re-parenting
;; and simply proceed with shifting (phase 2) to make
;; sure that followup phase 0 request for the recent
;; changes can operate on the correctly shifted cache.
(org-element--cache-log-message "position %S after future change %S" limit future-change)
(setf (org-element--request-parent request) nil)
(setf (org-element--request-phase request) 2))
(t
(when future-change
;; Changes happened, but not yet registered after
;; this element. However, we a not yet safe to look
;; at the buffer and parse elements in the cache gap.
;; Some of the parents to be added to cache may end
;; after the changes. Parsing this parents will
;; assign the :end correct value for cache state
;; after future-change. Then, when the future change
;; is going to be processed, such parent boundary
;; will be altered unnecessarily. To avoid this,
;; we alter the new parents by -OFFSET.
;; For now, just save last known cached element and
;; then check all the parents below.
(setq cached-before (org-element--cache-find (1- limit) nil)))
;; No relevant changes happened after submitting this
;; request. We are safe to look at the actual Org
;; buffer and calculate the new parent.
(let ((parent (org-element--parse-to (1- limit) nil time-limit)))
(when future-change
;; Check all the newly added parents to not
;; intersect with future change.
(let ((up parent))
(while (and up
(or (not cached-before)
(> (org-element-begin up)
(org-element-begin cached-before))))
(when (> (org-element-end up) future-change)
;; Offset future cache request.
(org-element--cache-shift-positions
up (- offset)
(if (and (org-element-property :robust-begin up)
(org-element-property :robust-end up))
'(:contents-end :end :robust-end)
'(:contents-end :end))))
;; Cached elements cannot have deferred `:parent'.
(setq up (org-element-property-raw :parent up)))))
(org-element--cache-log-message
"New parent at %S: %S::%S"
limit
(org-element-property :org-element--cache-sync-key parent)
(org-element--format-element parent))
(setf (org-element--request-parent request) parent)
(setf (org-element--request-phase request) 2))))))
;; Phase 2.
;;
;; Shift all elements starting from key START, but before NEXT, by
;; OFFSET, and re-parent them when appropriate.
;;
;; Elements are modified by side-effect so the tree structure
;; remains intact.
;;
;; Once THRESHOLD, if any, is reached, or once there is an input
;; pending, exit. Before leaving, the current synchronization
;; request is updated.
(org-element--cache-log-message "Phase 2")
(let ((start (org-element--request-key request))
(offset (org-element--request-offset request))
(parent (org-element--request-parent request))
(node (org-element--cache-root))
(stack (list nil))
(leftp t)
exit-flag continue-flag)
;; No re-parenting nor shifting planned: request is over.
(when (and (not parent) (zerop offset))
(org-element--cache-log-message "Empty offset. Request completed.")
(throw 'org-element--cache-quit t))
(while node
(let* ((data (avl-tree--node-data node))
(key (org-element--cache-key data)))
;; Traverse the cache tree. Ignore all the elements before
;; START. Note that `avl-tree-stack' would not bypass the
;; elements before START and thus would have been less
;; efficient.
(if (and leftp (avl-tree--node-left node)
(not (org-element--cache-key-less-p key start)))
(progn (push node stack)
(setq node (avl-tree--node-left node)))
;; Shift and re-parent when current node starts at or
;; after START, but before NEXT.
(unless (org-element--cache-key-less-p key start)
;; We reached NEXT. Request is complete.
(when (and next-request-key
(not (org-element--cache-key-less-p key next-request-key)))
(org-element--cache-log-message "Reached next request.")
(let ((next-request (nth 1 org-element--cache-sync-requests)))
(unless (and (org-element-property :cached (org-element--request-parent next-request))
(org-element-begin (org-element--request-parent next-request))
parent
(> (org-element-begin (org-element--request-parent next-request))
(org-element-begin parent)))
(setf (org-element--request-parent next-request) parent)))
(throw 'org-element--cache-quit t))
;; Handle interruption request. Update current request.
(when (or exit-flag (org-element--cache-interrupt-p time-limit))
(org-element--cache-log-message "Interrupt: %s" (if exit-flag "threshold" "time limit"))
(setf (org-element--request-key request) key)
(setf (org-element--request-parent request) parent)
(throw 'org-element--cache-interrupt nil))
;; Shift element.
(when (>= org-element--cache-diagnostics-level 3)
(org-element--cache-log-message "Shifting positions (𝝙%S) in %S::%S"
offset
(org-element-property :org-element--cache-sync-key data)
(org-element--format-element data)))
(org-element--cache-shift-positions data offset)
(let ((begin (org-element-begin data)))
;; Update PARENT and re-parent DATA, only when
;; necessary. Propagate new structures for lists.
(while (and parent (<= (org-element-end parent) begin))
(setq parent
;; Cached elements cannot have deferred `:parent'.
(org-element-property-raw :parent parent)))
(cond ((and (not parent) (zerop offset)) (throw 'org-element--cache-quit nil))
;; Consider scenario when DATA lays within
;; sensitive lines of PARENT that was found
;; during phase 2. For example:
;;
;; #+ begin_quote
;; Paragraph
;; #+end_quote
;;
;; In the above source block, remove space in
;; the first line will trigger re-parenting of
;; the paragraph and "#+end_quote" that is also
;; considered paragraph before the modification.
;; However, the paragraph element stored in
;; cache must be deleted instead.
((and parent
(or (not (org-element-type-p parent org-element-greater-elements))
(and (org-element-contents-begin parent)
(< (org-element-begin data) (org-element-contents-begin parent)))
(and (org-element-contents-end parent)
(>= (org-element-begin data) (org-element-contents-end parent)))
(> (org-element-end data) (org-element-end parent))
(and (org-element-contents-end data)
(> (org-element-contents-end data) (org-element-contents-end parent)))))
(org-element--cache-log-message "org-element-cache: Removing obsolete element with key %S::%S"
(org-element-property :org-element--cache-sync-key data)
(org-element--format-element data))
(org-element--cache-remove data)
;; We altered the tree structure. The tree
;; traversal needs to be restarted.
(setf (org-element--request-key request) key)
;; Make sure that we restart tree traversal
;; past already shifted elements (before the
;; removed DATA).
(setq start key)
(setf (org-element--request-parent request) parent)
;; Restart tree traversal.
(setq node (org-element--cache-root)
stack (list nil)
leftp t
begin -1
continue-flag t))
((and parent
(not (eq parent data))
;; Cached elements cannot have deferred `:parent'.
(let ((p (org-element-property-raw :parent data)))
(or (not p)
(< (org-element-begin p)
(org-element-begin parent))
(unless (eq p parent)
(not (org-element-property :cached p))
;; (not (avl-tree-member-p org-element--cache p))
))))
(org-element--cache-log-message
"Updating parent in %S\n Old parent: %S\n New parent: %S"
(org-element--format-element data)
(org-element--format-element
(org-element-property-raw :parent data))
(org-element--format-element parent))
(when (and (org-element-type-p parent 'org-data)
(not (org-element-type-p data 'headline)))
;; FIXME: This check is here to see whether
;; such error happens within
;; `org-element--cache-process-request' or somewhere
;; else.
(org-element--cache-warn
"Added org-data parent to non-headline element: %S
If this warning appears regularly, please report the warning text to Org mode mailing list (M-x org-submit-bug-report)."
data)
(org-element-cache-reset)
(throw 'org-element--cache-quit t))
(org-element-put-property data :parent parent)
(let ((s (org-element-property :structure parent)))
(when (and s (org-element-property :structure data))
(org-element-put-property data :structure s)))))
;; Cache is up-to-date past THRESHOLD. Request
;; interruption.
(when (and threshold (> begin threshold))
(org-element--cache-log-message "Reached threshold %S: %S"
threshold
(org-element--format-element data))
(setq exit-flag t))))
(if continue-flag
(setq continue-flag nil)
(setq node (if (setq leftp (avl-tree--node-right node))
(avl-tree--node-right node)
(pop stack)))))))
;; We reached end of tree: synchronization complete.
t))
(org-element--cache-log-message
"org-element-cache: Finished process. The cache size is %S. The remaining sync requests: %S"
org-element--cache-size
(let ((print-level 2)) (prin1-to-string org-element--cache-sync-requests)))))
(defun org-element--headline-parent-deferred (headline)
"Parse parent for HEADLINE."
(with-current-buffer (org-element-property :buffer headline)
(org-with-point-at (org-element-begin headline)
(if (or (bobp) (= 1 (org-element-property :true-level headline)))
;; Top-level heading. Parent is `org-data'.
(org-element-org-data-parser)
(re-search-backward
(org-headline-re
(1- (org-element-property :true-level headline)))
nil 'move)
(let ((parent (org-element-at-point)))
(if (org-element-type-p parent 'headline) parent
;; Before first headline. Assign `org-data'.
(org-element-lineage parent 'org-data t)))))))
(defconst org-element--headline-parent-deferred
(org-element-deferred-create
t #'org-element--headline-parent-deferred)
"Constant holding deferred value for headline `:parent' property.")
(defun org-element--parse-to (pos &optional syncp time-limit)
"Parse elements in current section, down to POS.
Start parsing from the closest between the last known element in
cache or headline above. Return the smallest element containing
POS.
When optional argument SYNCP is non-nil, return the parent of the
element containing POS instead. In that case, it is also
possible to provide TIME-LIMIT, which is a time value specifying
when the parsing should stop. The function throws
`org-element--cache-interrupt' if the process stopped before finding
the expected result."
(catch 'exit
(org-with-base-buffer nil
(org-with-wide-buffer
(goto-char pos)
(save-excursion
(forward-line 1)
(skip-chars-backward " \r\t\n")
;; Within blank lines at the beginning of buffer, return nil.
(when (bobp) (throw 'exit nil)))
(let* ((cached (and (org-element--cache-active-p)
(org-element--cache-find pos nil)))
(mode (org-element-property :mode cached))
element next)
(cond
;; Nothing in cache before point: start parsing from first
;; element in buffer down to POS or from the beginning of the
;; file.
((and (not cached) (org-element--cache-active-p))
(setq element (org-element-org-data-parser))
(unless (org-element-begin element)
(org-element--cache-warn "Error parsing org-data. Got %S\nPlease report to Org mode mailing list (M-x org-submit-bug-report)." element))
(org-element--cache-log-message
"Nothing in cache. Adding org-data: %S"
(org-element--format-element element))
(org-element--cache-put element)
(goto-char (org-element-contents-begin element))
(setq mode 'org-data))
;; Nothing in cache before point because cache is not active.
;; Parse from previous heading to avoid re-parsing the whole
;; buffer above. Arrange `:parent' to be calculated on demand.
((not cached)
(forward-line 1) ; ensure the end of current heading.
(if (re-search-backward
(org-get-limited-outline-regexp t)
nil 'move)
(progn
(setq element (org-element-headline-parser nil 'fast))
(org-element-put-property
element :parent
org-element--headline-parent-deferred)
(setq mode 'planning)
(forward-line))
(setq element (org-element-org-data-parser))
(setq mode 'org-data))
(org-skip-whitespace)
(forward-line 0))
;; Check if CACHED or any of its ancestors contain point.
;;
;; If there is such an element, we inspect it in order to know
;; if we return it or if we need to parse its contents.
;; Otherwise, we just start parsing from location, which is
;; right after the top-most element containing CACHED but
;; still before POS.
;;
;; As a special case, if POS is at the end of the buffer, we
;; want to return the innermost element ending there.
;;
;; Also, if we find an ancestor and discover that we need to
;; parse its contents, make sure we don't start from
;; `:contents-begin', as we would otherwise go past CACHED
;; again. Instead, in that situation, we will resume parsing
;; from NEXT, which is located after CACHED or its higher
;; ancestor not containing point.
(t
(let ((up cached)
(pos (if (= (point-max) pos) (1- pos) pos)))
(while (and up (<= (org-element-end up) pos))
(setq next (org-element-end up)
element up
mode (org-element--next-mode (org-element-property :mode element) (org-element-type element) nil)
;; Cached elements cannot have deferred `:parent'.
up (org-element-property-raw :parent up)))
(when next (goto-char next))
(when up (setq element up)))))
;; Parse successively each element until we reach POS.
(let ((end (or (org-element-end element) (point-max)))
(parent (org-element-property-raw :parent element)))
(while t
(when (org-element--cache-interrupt-p time-limit)
(throw 'org-element--cache-interrupt nil))
(when (and inhibit-quit org-element--cache-interrupt-C-g quit-flag)
(when quit-flag
(cl-incf org-element--cache-interrupt-C-g-count)
(setq quit-flag nil))
(when (>= org-element--cache-interrupt-C-g-count
org-element--cache-interrupt-C-g-max-count)
(setq quit-flag t)
(setq org-element--cache-interrupt-C-g-count 0)
(org-element-cache-reset)
(error "org-element: Parsing aborted by user. Cache has been cleared.
If you observe Emacs hangs frequently, please report this to Org mode mailing list (M-x org-submit-bug-report)"))
(message (substitute-command-keys
"`org-element--parse-to': Suppressed `\\[keyboard-quit]'. Press `\\[keyboard-quit]' %d more times to force interruption.")
(- org-element--cache-interrupt-C-g-max-count
org-element--cache-interrupt-C-g-count)))
(unless element
;; Do not try to parse within blank at EOB.
(unless (save-excursion
(org-skip-whitespace)
(eobp))
(setq element (org-element--current-element
end 'element mode
(org-element-property :structure parent))))
;; Make sure that we return referenced element in cache
;; that can be altered directly.
(if element
(setq element (or (org-element--cache-put element) element))
;; Nothing to parse (i.e. empty file).
(throw 'exit parent))
(unless (or parent (not (org-element--cache-active-p)))
(org-element--cache-warn
"Got empty parent while parsing. Please report it to Org mode mailing list (M-x org-submit-bug-report).\n Backtrace:\n%S"
(when (and (fboundp 'backtrace-get-frames)
(fboundp 'backtrace-to-string))
(backtrace-to-string (backtrace-get-frames 'backtrace))
(org-element-cache-reset)
(error "org-element--cache: Emergency exit"))))
(org-element-put-property element :parent parent))
(let ((elem-end (org-element-end element))
(type (org-element-type element)))
(cond
;; Skip any element ending before point. Also skip
;; element ending at point (unless it is also the end of
;; buffer) since we're sure that another element begins
;; after it.
((and (<= elem-end pos) (/= (point-max) elem-end))
;; Avoid parsing headline siblings above.
(goto-char elem-end)
(when (eq type 'headline)
(unless (when (and (/= 1 (org-element-property :true-level element))
(re-search-forward
(org-headline-re (1- (org-element-property :true-level element)))
pos t))
(forward-line 0)
t)
;; There are headings with lower level than
;; ELEMENT between ELEM-END and POS. Siblings
;; may exist though. Parse starting from the
;; last sibling or from ELEM-END if there are
;; no other siblings.
(goto-char pos)
(unless
(re-search-backward
(org-headline-re (org-element-property :true-level element))
elem-end t)
;; Roll-back to normal parsing.
(goto-char elem-end))))
(setq mode (org-element--next-mode mode type nil)))
;; A non-greater element contains point: return it.
((not (memq type org-element-greater-elements))
(throw 'exit (if syncp parent element)))
;; Otherwise, we have to decide if ELEMENT really
;; contains POS. In that case we start parsing from
;; contents' beginning.
;;
;; If POS is at contents' beginning but it is also at
;; the beginning of the first item in a list or a table.
;; In that case, we need to create an anchor for that
;; list or table, so return it.
;;
;; Also, if POS is at the end of the buffer, no element
;; can start after it, but more than one may end there.
;; Arbitrarily, we choose to return the innermost of
;; such elements.
((let ((cbeg (org-element-contents-begin element))
(cend (org-element-contents-end element)))
(when (and cbeg cend
(or (< cbeg pos)
(and (= cbeg pos)
(not (memq type '(plain-list table)))))
(or (> cend pos)
;; When we are at cend or within blank
;; lines after, it is a special case:
;; 1. At the end of buffer we return
;; the innermost element.
(= pos cend (point-max))
;; 2. At cend of element with return
;; that element (thus, no need to
;; parse inside).
nil))
(goto-char (or next cbeg))
(setq mode (if next mode (org-element--next-mode mode type t))
next nil
parent element
end (org-element-contents-end element)))))
;; Otherwise, return ELEMENT as it is the smallest
;; element containing POS.
(t (throw 'exit (if syncp parent element)))))
(setq element nil))))))))
;;;; Staging Buffer Changes
(defconst org-element--cache-sensitive-re
(concat
"^\\*+ " "\\|"
"\\\\end{[A-Za-z0-9*]+}[ \t]*$" "\\|"
"^[ \t]*\\(?:"
"#\\+END\\(?:_\\|:?[ \t]*$\\)" "\\|"
org-list-full-item-re "\\|"
":\\(?: \\|$\\)" "\\|"
":\\(?:\\w\\|[-_]\\)+:[ \t]*$"
"\\)")
"Regexp matching a sensitive line, structure wise.
A sensitive line is a headline, inlinetask, block, drawer, or
latex-environment boundary. When such a line is modified,
structure changes in the document may propagate in the whole
section, possibly making cache invalid.")
(defun org-element--cache-before-change (beg end)
"Detect modifications in sensitive parts of Org buffer.
BEG and END are the beginning and end of the range of changed
text. See `before-change-functions' for more information.
The function returns the new value of `org-element--cache-change-warning'."
(org-with-base-buffer nil
(when (org-element--cache-active-p t)
(org-with-wide-buffer
(setq org-element--cache-change-tic (buffer-chars-modified-tick))
(setq org-element--cache-last-buffer-size (buffer-size))
(goto-char beg)
(forward-line 0)
(let ((bottom (save-excursion (goto-char end) (line-end-position))))
(prog1
;; Use the worst change warning to not miss important edits.
;; This function is called before edit and after edit by
;; `org-element--cache-after-change'. Before the edit, we still
;; want to use the old value if it comes from previous
;; not yet processed edit (they may be merged by
;; `org-element--cache-submit-request'). After the edit, we want to
;; look if there was a sensitive removed during edit.
;; FIXME: This is not the most efficient way and we now
;; have to delete more elements than needed in some
;; cases. A better approach may be storing the warning
;; in the modification request itself.
(let ((org-element--cache-change-warning-before org-element--cache-change-warning)
(org-element--cache-change-warning-after))
(setq org-element--cache-change-warning-after
;; We must preserve match data when called as `before-change-functions'.
(save-match-data
(let ((case-fold-search t))
(when (re-search-forward
org-element--cache-sensitive-re bottom t)
(goto-char beg)
(forward-line 0)
(let (min-level)
(cl-loop while (re-search-forward
(rx-to-string
(if (and min-level
(> min-level 1))
`(and bol (repeat 1 ,(1- min-level) "*") " ")
`(and bol (+ "*") " ")))
bottom t)
do (setq min-level (1- (length (match-string 0))))
until (= min-level 1))
(goto-char beg)
(forward-line 0)
(or (and min-level (org-reduced-level min-level))
(when (looking-at-p "^[ \t]*#\\+CATEGORY:")
'org-data)
t))))))
(setq org-element--cache-change-warning
(cond
((and (numberp org-element--cache-change-warning-before)
(numberp org-element--cache-change-warning-after))
(min org-element--cache-change-warning-after
org-element--cache-change-warning-before))
((numberp org-element--cache-change-warning-before)
org-element--cache-change-warning-before)
((numberp org-element--cache-change-warning-after)
org-element--cache-change-warning-after)
(t (or org-element--cache-change-warning-after
org-element--cache-change-warning-before)))))
(org-element--cache-log-message
"%S is about to modify text: warning %S"
this-command
org-element--cache-change-warning)))))))
(defun org-element--cache-after-change (beg end pre)
"Update buffer modifications for current buffer.
BEG, END, and PRE are the beginning and end of the range of changed
text, and the length in bytes of the pre-change text replaced by
that range. See `after-change-functions' for more information."
(org-with-base-buffer nil
(when (org-element--cache-active-p t)
(when (not (eq org-element--cache-change-tic (buffer-chars-modified-tick)))
(org-element--cache-log-message "After change")
(org-element--cache-before-change beg end)
;; If beg is right after spaces in front of an element, we
;; risk affecting previous element, so move beg to bol, making
;; sure that we capture preceding element.
(setq beg (save-excursion
(goto-char beg)
(cl-incf pre (- beg (line-beginning-position)))
(line-beginning-position)))
;; Store synchronization request.
(let ((offset (- end beg pre)))
;; We must preserve match data when called as `after-change-functions'.
(save-match-data
(org-element--cache-submit-request beg (- end offset) offset)))
;; Activate a timer to process the request during idle time.
(org-element--cache-set-timer (current-buffer))))))
(defun org-element--cache-setup-change-functions ()
"Setup `before-change-functions' and `after-change-functions'."
(when (and (derived-mode-p 'org-mode) org-element-use-cache)
;; Clear copied local cache to avoid extra memory usage.
;; We only use cache stored in the base buffer.
(when (buffer-base-buffer)
(setq-local org-element--cache nil)
(setq-local org-element--headline-cache nil))
;; Register current buffer in `org-fold-core--indirect-buffers' to
;; be used within `org-fold-core-cycle-over-indirect-buffers'.
;; FIXME: We should eventually factor out indirect buffer tracking
;; from org-fold-core.
(org-fold-core-decouple-indirect-buffer-folds)
(add-hook 'before-change-functions
#'org-element--cache-before-change nil t)
;; Run `org-element--cache-after-change' early to handle cases
;; when other `after-change-functions' require element cache.
(add-hook 'after-change-functions
#'org-element--cache-after-change -1 t)))
(defvar org-element--cache-avoid-synchronous-headline-re-parsing nil
"How buffer changes are handled by the cache.
By default (when this variable is nil), cache re-parses modified
headlines immediately after modification preserving all the unaffected
elements inside the headline.
The default behavior works best when users types inside Org buffer of
when buffer modifications are mixed with cache requests. However,
large automated edits inserting/deleting many headlines are somewhat
slower by default (as in `org-archive-subtree'). Let-binding this
variable to non-nil will reduce cache latency after every singular edit
\(`after-change-functions') at the cost of slower cache queries.")
(defun org-element--cache-for-removal (beg end offset)
"Return first element to remove from cache.
BEG and END are buffer positions delimiting buffer modifications.
OFFSET is the size of the changes.
Returned element is usually the first element in cache containing
any position between BEG and END. As an exception, greater
elements around the changes that are robust to contents
modifications are preserved and updated according to the
changes. In the latter case, the returned element is the outermost
non-robust element affected by the changes. Note that the returned
element may end before END position in which case some cached element
starting after the returned may still be affected by the changes.
Also, when there are no elements in cache before BEG, return first
known element in cache (it may start after END)."
(let* ((elements (org-element--cache-find (1- beg) 'both))
(before (car elements))
(after (cdr elements)))
(if (not before) after
;; If BEFORE is a keyword, it may need to be removed to become
;; an affiliated keyword.
(when (org-element-type-p before 'keyword)
(let ((prev before))
(while (org-element-type-p prev 'keyword)
(setq before prev
beg (org-element-begin prev))
(setq prev (org-element--cache-find (1- (org-element-begin before)))))))
(let ((up before)
(robust-flag t))
(while up
(if (let ((type (org-element-type up)))
(or (and (memq type '( center-block dynamic-block
quote-block special-block
drawer))
(or (not (eq type 'drawer))
(not (string= "PROPERTIES" (org-element-property :drawer-name up))))
;; Sensitive change. This is
;; unconditionally non-robust change.
(not org-element--cache-change-warning)
(let ((cbeg (org-element-contents-begin up))
(cend (org-element-contents-end up)))
(and cbeg
(<= cbeg beg)
(or (> cend end)
(and (= cend end)
(= (+ end offset) (point-max)))))))
(and (memq type '(headline section org-data))
(let ((rbeg (org-element-property :robust-begin up))
(rend (org-element-property :robust-end up)))
(and rbeg rend
(<= rbeg beg)
(or (> rend end)
(and (= rend end)
(= (+ end offset) (point-max))))))
(pcase type
;; Sensitive change in section. Need to
;; re-parse.
(`section (not org-element--cache-change-warning))
;; Headline might be inserted. This is non-robust
;; change when `up' is a `headline' or `section'
;; with `>' level compared to the inserted headline.
;;
;; Also, planning info/property drawer
;; could have been inserted. It is not
;; robust change then.
(`headline
(and
(or (not (numberp org-element--cache-change-warning))
(> org-element--cache-change-warning
(org-element-property :level up)))
(org-with-point-at (org-element-contents-begin up)
(unless
(progn
(when (looking-at-p org-element-planning-line-re)
(forward-line))
(when (looking-at org-property-drawer-re)
(< beg (match-end 0))))
'robust))))
(`org-data (and (not (eq org-element--cache-change-warning 'org-data))
;; Property drawer could
;; have been inserted. It
;; is not robust change
;; then.
(org-with-wide-buffer
(goto-char (point-min))
(while (and (org-at-comment-p) (bolp)) (forward-line))
;; Should not see property
;; drawer within changed
;; region.
(or (not (looking-at org-property-drawer-re))
(> beg (match-end 0))))))
(_ 'robust)))))
;; UP is a robust greater element containing changes.
;; We only need to extend its ending boundaries.
(progn
(org-element--cache-shift-positions
up offset
(if (and (org-element-property :robust-begin up)
(org-element-property :robust-end up))
'(:contents-end :end :robust-end)
'(:contents-end :end)))
(org-element--cache-log-message
"Shifting end positions of robust parent (warning %S): %S"
org-element--cache-change-warning
(org-element--format-element up)))
(unless (or
;; UP is non-robust. Yet, if UP is headline, flagging
;; everything inside for removal may be to
;; costly. Instead, we should better re-parse only the
;; headline itself when possible. If a headline is still
;; starting from old :begin position, we do not care that
;; its boundaries could have extended to shrunk - we
;; will re-parent and shift them anyway.
(and (org-element-type-p up 'headline)
(not org-element--cache-avoid-synchronous-headline-re-parsing)
;; The change is not inside headline. Not
;; updating here.
(not (<= beg (org-element-begin up)))
(not (> end (org-element-end up)))
(let ((current (org-with-point-at (org-element-begin up)
(org-element-with-disabled-cache
(and (looking-at-p org-element-headline-re)
(org-element-headline-parser nil 'fast))))))
(when (org-element-type-p current 'headline)
(org-element--cache-log-message
"Found non-robust headline that can be updated individually (warning %S): %S"
org-element--cache-change-warning
(org-element--format-element current))
(org-element-set up current org-element--cache-element-properties)
t)))
;; If UP is org-data, the situation is similar to
;; headline case. We just need to re-parse the
;; org-data itself, unless the change is made
;; within blank lines at BOB (that could
;; potentially alter first-section).
(when (and (org-element-type-p up 'org-data)
(>= beg (org-element-contents-begin up)))
(org-element-set up (org-with-point-at 1 (org-element-org-data-parser)) org-element--cache-element-properties)
(org-element--cache-log-message
"Found non-robust change invalidating org-data. Re-parsing: %S"
(org-element--format-element up))
t))
(org-element--cache-log-message
"Found non-robust element: %S"
(org-element--format-element up))
(setq before up)
(when robust-flag (setq robust-flag nil))))
(unless (or (org-element-property-raw :parent up)
(org-element-type-p up 'org-data))
(org-element--cache-warn "Got element without parent. Please report it to Org mode mailing list (M-x org-submit-bug-report).\n%S" up)
(org-element-cache-reset)
(error "org-element--cache: Emergency exit"))
(setq up (org-element-property-raw :parent up)))
;; We're at top level element containing ELEMENT: if it's
;; altered by buffer modifications, it is first element in
;; cache to be removed. Otherwise, that first element is the
;; following one.
;;
;; As a special case, do not remove BEFORE if it is a robust
;; container for current changes.
(if (or (< (org-element-end before) beg) robust-flag) after
before)))))
(defun org-element--cache-submit-request (beg end offset)
"Submit a new cache synchronization request for current buffer.
BEG and END are buffer positions delimiting the minimal area
where cache data should be removed. OFFSET is the size of the
change, as an integer."
(org-element--cache-log-message
"Submitting new synchronization request for [%S..%S]𝝙%S"
beg end offset)
(org-with-base-buffer nil
(let ((next (car org-element--cache-sync-requests))
delete-to delete-from)
(if (and next
;; First existing sync request is in phase 0.
(= 0 (org-element--request-phase next))
;; Current changes intersect with the first sync request.
(> (setq delete-to (+ (org-element--request-end next)
(org-element--request-offset next)))
end)
(<= (setq delete-from (org-element--request-beg next))
end))
;; Current changes can be merged with first sync request: we
;; can save a partial cache synchronization.
(progn
(org-element--cache-log-message "Found another phase 0 request intersecting with current")
;; Update OFFSET of the existing request.
(cl-incf (org-element--request-offset next) offset)
;; If last change happened within area to be removed, extend
;; boundaries of robust parents, if any. Otherwise, find
;; first element to remove and update request accordingly.
(if (> beg delete-from)
;; The current modification is completely inside NEXT.
;; We already added the current OFFSET to the NEXT
;; request. However, the robust elements around
;; modifications also need to be shifted. Moreover, the
;; new modification may also have non-nil
;; `org-element--cache-change-warning'. In the latter case, we
;; also need to update the request.
(let ((first (org-element--cache-for-removal delete-from end offset) ; Shift as needed.
))
(org-element--cache-log-message
"Current request is inside next. Candidate parent: %S"
(org-element--format-element first))
(when
;; Non-robust element is now before NEXT. Need to
;; update.
(and first
(org-element--cache-key-less-p
(org-element--cache-key first)
(org-element--request-key next)))
(org-element--cache-log-message
"Current request is inside next. New parent: %S"
(org-element--format-element first))
(setf (org-element--request-key next)
(org-element--cache-key first))
(setf (org-element--request-beg next)
(org-element-begin first))
(setf (org-element--request-end next)
(max (org-element-end first)
(org-element--request-end next)))
(setf (org-element--request-parent next)
;; Cached elements cannot have deferred `:parent'.
(org-element-property-raw :parent first))))
;; The current and NEXT modifications are intersecting
;; with current modification starting before NEXT and NEXT
;; ending after current. We need to update the common
;; non-robust parent for the new extended modification
;; region.
(let ((first (org-element--cache-for-removal beg delete-to offset)))
(org-element--cache-log-message
"Current request intersects with next. Candidate parent: %S"
(org-element--format-element first))
(when (and first
(org-element--cache-key-less-p
(org-element--cache-key first)
(org-element--request-key next)))
(org-element--cache-log-message
"Current request intersects with next. Updating. New parent: %S"
(org-element--format-element first))
(setf (org-element--request-key next) (org-element--cache-key first))
(setf (org-element--request-beg next) (org-element-begin first))
(setf (org-element--request-end next)
(max (org-element-end first)
(org-element--request-end next)))
(setf (org-element--request-parent next)
;; Cached elements cannot have deferred `:parent'.
(org-element-property-raw :parent first))))))
;; Ensure cache is correct up to END. Also make sure that NEXT,
;; if any, is no longer a 0-phase request, thus ensuring that
;; phases are properly ordered. We need to provide OFFSET as
;; optional parameter since current modifications are not known
;; yet to the otherwise correct part of the cache (i.e, before
;; the first request).
(org-element--cache-log-message "Adding new phase 0 request")
(when next (org-element--cache-sync (current-buffer) end beg offset 'force))
(let ((first (org-element--cache-for-removal beg end offset)))
(if first
(push (let ((first-beg (org-element-begin first))
(key (org-element--cache-key first)))
(cond
;; When changes happen before the first known
;; element, re-parent and shift the rest of the
;; cache.
((> first-beg end)
(org-element--cache-log-message "Changes are before first known element. Submitting phase 1 request")
(vector key first-beg nil offset nil 1))
;; Otherwise, we find the first non robust
;; element containing END. All elements between
;; FIRST and this one are to be removed.
;;
;; The current modification is completely inside
;; FIRST. Clear and update cached elements in
;; region containing FIRST.
((let ((first-end (org-element-end first)))
(when (> first-end end)
(org-element--cache-log-message "Extending to non-robust element %S" (org-element--format-element first))
(vector key first-beg first-end offset
(org-element-property-raw :parent first) 0))))
(t
;; Now, FIRST is the first element after BEG or
;; non-robust element containing BEG. However,
;; FIRST ends before END and there might be
;; another ELEMENT before END that spans beyond
;; END. If there is such element, we need to
;; extend the region down to end of the common
;; parent of FIRST and everything inside
;; BEG..END.
(let* ((element (org-element--cache-find end))
(element-end (org-element-end element))
(up element))
(while (and (not (eq up first))
;; Cached elements cannot have deferred `:parent'.
(setq up (org-element-property-raw :parent up))
(>= (org-element-begin up) first-beg))
;; Note that UP might have been already
;; shifted if it is a robust element. After
;; deletion, it can put it's end before yet
;; unprocessed ELEMENT.
(setq element-end (max (org-element-end up) element-end)
element up))
;; Extend region to remove elements between
;; beginning of first and the end of outermost
;; element starting before END but after
;; beginning of first.
;; of the FIRST.
(org-element--cache-log-message
"Extending to all elements between:\n 1: %S\n 2: %S"
(org-element--format-element first)
(org-element--format-element element))
(vector key first-beg element-end offset up 0)))))
org-element--cache-sync-requests)
;; No element to remove. No need to re-parent either.
;; Simply shift additional elements, if any, by OFFSET.
(if org-element--cache-sync-requests
(progn
(org-element--cache-log-message
"Nothing to remove. Updating offset of the next request by 𝝙%S: %S"
offset
(let ((print-level 3))
(car org-element--cache-sync-requests)))
(cl-incf (org-element--request-offset (car org-element--cache-sync-requests))
offset))
(org-element--cache-log-message
"Nothing to remove. No elements in cache after %S. Terminating."
end))))))
(setq org-element--cache-change-warning nil)))
(defun org-element--cache-verify-element (element)
"Verify correctness of ELEMENT when `org-element--cache-self-verify' is non-nil.
Return non-nil when verification failed."
(let ((org-element--cache-self-verify
(or org-element--cache-self-verify
(and (boundp 'org-batch-test) org-batch-test)))
(org-element--cache-self-verify-frequency
(if (and (boundp 'org-batch-test) org-batch-test)
1
org-element--cache-self-verify-frequency)))
;; Verify correct parent for the element.
(unless (or (not org-element--cache-self-verify)
(org-element-property :parent element)
(org-element-type-p element 'org-data))
(org-element--cache-warn "Got element without parent (cache active?: %S). Please report it to Org mode mailing list (M-x org-submit-bug-report).\n%S" (org-element--cache-active-p) element)
(org-element-cache-reset))
(when (and org-element--cache-self-verify
(org-element--cache-active-p)
(org-element-type-p element 'headline)
;; Avoid too much slowdown
(< (random 1000) (* 1000 org-element--cache-self-verify-frequency)))
(org-with-point-at (org-element-begin element)
(org-element-with-disabled-cache (org-up-heading-or-point-min))
(unless (or (= (point)
(org-element-begin
(org-element-property :parent element)))
(eq (point) (point-min)))
(org-element--cache-warn
"Cached element has wrong parent in %s. Resetting.
If this warning appears regularly, please report the warning text to Org mode mailing list (M-x org-submit-bug-report).
The element is: %S\n The parent is: %S\n The real parent is: %S"
(buffer-name (current-buffer))
(org-element--format-element element)
(org-element--format-element (org-element-property :parent element))
(org-element--format-element
(org-element--current-element
(org-element-end (org-element-property :parent element)))))
(org-element-cache-reset))
(org-element--cache-verify-element
(org-element-property :parent element))))
;; Verify the element itself.
(when (and org-element--cache-self-verify
(org-element--cache-active-p)
element
(not (org-element-type-p element '(section org-data)))
;; Avoid too much slowdown
(< (random 1000) (* 1000 org-element--cache-self-verify-frequency)))
(let ((real-element (org-element-with-disabled-cache
(org-element--parse-to
(if (org-element-type-p element '(table-row item))
(1+ (org-element-begin element))
(org-element-begin element))))))
(unless (and (eq (org-element-type real-element) (org-element-type element))
(eq (org-element-begin real-element) (org-element-begin element))
(eq (org-element-end real-element) (org-element-end element))
(eq (org-element-contents-begin real-element) (org-element-contents-begin element))
(eq (org-element-contents-end real-element) (org-element-contents-end element))
(or (not (org-element-property :ID real-element))
(string= (org-element-property :ID real-element) (org-element-property :ID element))))
(org-element--cache-warn "(%S) Cached element is incorrect in %s. (Cache tic up to date: %S) Resetting.
If this warning appears regularly, please report the warning text to Org mode mailing list (M-x org-submit-bug-report).
The element is: %S\n The real element is: %S\n Cache around :begin:\n%S\n%S\n%S"
this-command
(buffer-name (current-buffer))
(if (/= org-element--cache-change-tic
(buffer-chars-modified-tick))
"no" "yes")
(org-element--format-element element)
(org-element--format-element real-element)
(org-element--format-element (org-element--cache-find (1- (org-element-begin real-element))))
(org-element--format-element (car (org-element--cache-find (org-element-begin real-element) 'both)))
(org-element--format-element (cdr (org-element--cache-find (org-element-begin real-element) 'both))))
(org-element-cache-reset))))))
;;; Cache persistence
(defun org-element--cache-persist-before-write (container &optional associated)
"Sync element cache for CONTAINER and ASSOCIATED item before saving.
This function is intended to be used in `org-persist-before-write-hook'.
Prevent writing to disk cache when cache is disabled in the CONTAINER
buffer. Otherwise, cleanup cache sync keys, unreadable :buffer
properties, and verify cache consistency."
(when (equal container '(elisp org-element--cache))
(if (and org-element-use-cache
(plist-get associated :file)
(get-file-buffer (plist-get associated :file))
org-element-cache-persistent)
(with-current-buffer (get-file-buffer (plist-get associated :file))
(if (and (derived-mode-p 'org-mode)
org-element--cache)
(org-with-wide-buffer
(org-element--cache-sync (current-buffer) (point-max))
;; Cleanup cache request keys to avoid collisions during next
;; Emacs session. Cleanup known non-printable objects.
(avl-tree-mapc
(lambda (el)
(org-element-put-property el :org-element--cache-sync-key nil)
(org-element-map el t
(lambda (el2)
(unless (org-element-type-p el2 'plain-text)
(org-element-put-property el2 :buffer nil)))
nil nil nil 'with-affiliated 'no-undefer)
(let ((org-element--cache-self-verify-frequency 1.0))
(when (and org-element--cache-self-verify-before-persisting
(org-element--cache-verify-element el))
(error "Cache verification failed: aborting"))))
org-element--cache)
nil)
'forbid))
'forbid)))
(defun org-element--cache-persist-before-read (container &optional associated)
"Avoid reading cache for CONTAINER and ASSOCIATED before Org mode is loaded.
This function is intended to be used in `org-persist-before-read-hook'.
Also, prevent reading cache when the buffer CONTAINER hash is not
consistent with the cache."
(when (equal container '(elisp org-element--cache))
(org-element--cache-log-message "Loading persistent cache for %s" (plist-get associated :file))
(if (not (and (plist-get associated :file)
(get-file-buffer (plist-get associated :file))))
(progn
(org-element--cache-log-message "%s does not have a buffer: not loading cache" (plist-get associated :file))
'forbid)
(with-current-buffer (get-file-buffer (plist-get associated :file))
(unless (and org-element-use-cache
org-element-cache-persistent
(derived-mode-p 'org-mode)
(equal (secure-hash 'md5 (current-buffer))
(plist-get associated :hash)))
(org-element--cache-log-message "Cache is not current (or persistence is disabled) in %s" (plist-get associated :file))
'forbid)))))
(defun org-element--cache-persist-after-read (container &optional associated)
"Setup restored cache for CONTAINER and ASSOCIATED.
Re-fill :buffer properties for cache elements (buffer objects cannot
be written onto disk). Also, perform some consistency checks to
prevent loading corrupted cache."
(when (and (plist-get associated :file)
(get-file-buffer (plist-get associated :file)))
(with-current-buffer (get-file-buffer (plist-get associated :file))
(when (and org-element-use-cache org-element-cache-persistent)
(catch 'abort
(when (and (equal container '(elisp org-element--cache)) org-element--cache)
;; Restore `:buffer' property.
(avl-tree-mapc
(lambda (el)
(org-element-map el t
(lambda (el2)
(unless (org-element-type-p el2 'plain-text)
(org-element-put-property el2 :buffer (current-buffer))))
nil nil nil 'with-affiliated 'no-undefer)
(org-element--cache-log-message
"Recovering persistent cached element: %S"
(org-element--format-element el))
(when (and (not (org-element-parent el)) (not (org-element-type-p el 'org-data)))
(org-element--cache-warn
"Got element without parent when loading cache from disk. Not using this persistent cache.
Please report it to Org mode mailing list (M-x org-submit-bug-report).\n%S" el)
(org-element-cache-reset)
(throw 'abort t)))
org-element--cache)
(setq-local org-element--cache-size (avl-tree-size org-element--cache)))
(when (and (equal container '(elisp org-element--headline-cache)) org-element--headline-cache)
(setq-local org-element--headline-cache-size (avl-tree-size org-element--headline-cache))))))))
(add-hook 'org-persist-before-write-hook #'org-element--cache-persist-before-write)
(add-hook 'org-persist-before-read-hook #'org-element--cache-persist-before-read)
(add-hook 'org-persist-after-read-hook #'org-element--cache-persist-after-read)
;;;; Public Functions
(defvar-local org-element--cache-gapless nil
"An alist containing (granularity . `org-element--cache-change-tic') elements.
Each element indicates the latest `org-element--cache-change-tic' when
change did not contain gaps.")
;;;###autoload
(defun org-element-cache-reset (&optional all no-persistence)
"Reset cache in current buffer.
When optional argument ALL is non-nil, reset cache in all Org
buffers.
When optional argument NO-PERSISTENCE is non-nil, do not try to update
the cache persistence in the buffer."
(interactive "P")
(dolist (buffer (if all (buffer-list) (list (current-buffer))))
(org-with-base-buffer buffer
(when (and org-element-use-cache (derived-mode-p 'org-mode))
;; Only persist cache in file buffers.
(when (and (buffer-file-name) (not no-persistence))
(when (not org-element-cache-persistent)
(org-persist-unregister
'org-element--headline-cache
(current-buffer)
:remove-related t)
(org-persist-unregister
'org-element--cache
(current-buffer)
:remove-related t))
(when (and org-element-cache-persistent
(buffer-file-name (current-buffer)))
(org-persist-register
`((elisp org-element--cache) (version ,org-element-cache-version))
(current-buffer))
(org-persist-register
'org-element--headline-cache
(current-buffer)
:inherit `((elisp org-element--cache) (version ,org-element-cache-version)))))
(setq-local org-element--cache-change-tic (buffer-chars-modified-tick))
(setq-local org-element--cache-last-buffer-size (buffer-size))
(setq-local org-element--cache-gapless nil)
(setq-local org-element--cache
(avl-tree-create #'org-element--cache-compare))
(setq-local org-element--headline-cache
(avl-tree-create #'org-element--cache-compare))
(setq-local org-element--cache-hash-left (make-vector org-element--cache-hash-size nil))
(setq-local org-element--cache-hash-right (make-vector org-element--cache-hash-size nil))
(setq-local org-element--cache-size 0)
(setq-local org-element--headline-cache-size 0)
(setq-local org-element--cache-sync-keys-value 0)
(setq-local org-element--cache-change-warning nil)
(setq-local org-element--cache-sync-requests nil)
(setq-local org-element--cache-sync-timer nil)
(org-element--cache-setup-change-functions)
;; Install in the existing indirect buffers.
(dolist (buf (seq-filter
(lambda (buf)
(eq (current-buffer)
(buffer-base-buffer buf)))
(buffer-list)))
(with-current-buffer buf
(org-element--cache-setup-change-functions)))
;; Make sure that `org-element--cache-after-change' and
;; `org-element--cache-before-change' are working inside properly created
;; indirect buffers. Note that `clone-indirect-buffer-hook'
;; will not work inside indirect buffers not created by
;; calling `clone-indirect-buffer'. We consider that the code
;; not using `clone-indirect-buffer' to be written with
;; awareness about possible consequences.
(add-hook 'clone-indirect-buffer-hook
#'org-element--cache-setup-change-functions)))))
;;;###autoload
(defun org-element-cache-store-key (epom key value &optional robust)
"Store KEY with VALUE associated with EPOM - point, marker, or element.
The key can be retrieved as long as the element (provided or at point)
contents is not modified.
If optional argument ROBUST is non-nil, the key will be retained even
when the contents (children) of current element are modified. Only
non-robust element modifications (affecting the element properties
other then begin/end boundaries) will invalidate the key then."
(let ((element (org-element-at-point epom))
(property (if robust :robust-cache :fragile-cache)))
(let ((key-store (org-element-property property element)))
(unless (hash-table-p key-store)
(setq key-store (make-hash-table :test #'equal))
(org-element-put-property element property key-store))
(puthash key value key-store))))
;;;###autoload
(defun org-element-cache-get-key (epom key &optional default)
"Get KEY associated with EPOM - point, marker, or element.
Return DEFAULT when KEY is not associated with EPOM.
The key can be retrieved as long as the element (provided or at point)
contents is not modified."
(let ((element (org-element-at-point epom)))
(let ((key-store1 (org-element-property :fragile-cache element))
(key-store2 (org-element-property :robust-cache element)))
(let ((val1 (if (hash-table-p key-store1)
(gethash key key-store1 'not-found)
'not-found))
(val2 (if (hash-table-p key-store2)
(gethash key key-store2 'not-found)
'not-found)))
(cond
((and (eq 'not-found val1)
(eq 'not-found val2))
default)
((eq 'not-found val1) val2)
((eq 'not-found val2) val1))))))
;;;###autoload
(defun org-element-cache-refresh (pos)
"Refresh cache at position POS."
(when (org-element--cache-active-p)
(org-element--cache-sync (current-buffer) pos)
(org-element--cache-submit-request pos pos 0)
(org-element--cache-set-timer (current-buffer))))
(defmacro org-element-with-enabled-cache (&rest body)
"Run BODY with org-element cache enabled (maybe temporarily).
When cache is enabled, just run body.
When cache is disabled, initialize a new cache, run BODY, and cleanup
at the end."
(declare (debug (form body)) (indent 0))
(org-with-gensyms (old-state buffer)
`(if (org-element--cache-active-p)
;; Cache is active, just run BODY.
(progn ,@body)
;; Cache is disabled.
;; Save existing cache.
(let ((,buffer (current-buffer))
(,old-state
(org-with-base-buffer nil
(mapcar #'symbol-value org-element--cache-variables)))
(org-element-use-cache t))
(unwind-protect
(progn
(org-element-cache-reset)
,@body)
(cl-mapc
(lambda (var values)
(org-with-base-buffer ,buffer
(set var values)))
org-element--cache-variables
,old-state))))))
(defvar warning-minimum-log-level) ; Defined in warning.el
(defvar org-element-cache-map-continue-from nil
"Position from where mapping should continue.
This variable can be set by called function, especially when the
function modified the buffer.")
;;;###autoload
(cl-defun org-element-cache-map (func &key (granularity 'headline+inlinetask) restrict-elements
next-re fail-re from-pos (to-pos (point-max-marker)) after-element limit-count
narrow)
"Map all elements in current buffer with FUNC according to GRANULARITY.
Collect non-nil return values into result list.
FUNC should accept a single argument - the element.
FUNC can modify the buffer, but doing so may reduce performance. If
buffer is modified, the mapping will continue from an element starting
after the last mapped element. If the last mapped element is deleted,
the subsequent element will be skipped as it cannot be distinguished
deterministically from a changed element. If FUNC is expected to
delete the element, it should directly set the value of
`org-element-cache-map-continue-from' to force `org-element-cache-map'
continue from the right point in buffer.
If some elements are not yet in cache, they will be added.
GRANULARITY can be `headline', `headline+inlinetask'
`greater-element', or `element'. The default is
`headline+inlinetask'. `object' granularity is not supported.
RESTRICT-ELEMENTS is a list of element types to be mapped over.
NEXT-RE is a regexp used to search next candidate match when FUNC
returns non-nil and to search the first candidate match. FAIL-RE is a
regexp used to search next candidate match when FUNC returns nil. The
mapping will continue starting from headline at the RE match.
FROM-POS and TO-POS are buffer positions. When non-nil, they bound the
mapped elements to elements starting at of after FROM-POS but before
TO-POS.
AFTER-ELEMENT, when non-nil, bounds the mapping to all the elements
after AFTER-ELEMENT (i.e. if AFTER-ELEMENT is a headline section, we
map all the elements starting from first element inside section, but
not including the section).
LIMIT-COUNT limits mapping to that many first matches where FUNC
returns non-nil.
NARROW controls whether current buffer narrowing should be preserved.
This function does a subset of what `org-element-map' does, but with
much better performance. Cached elements are supplied as the single
argument of FUNC. Changes to elements made in FUNC will also alter
the cache."
(org-element-with-enabled-cache
(unless (org-element--cache-active-p)
(error "Cache must be active"))
(unless (memq granularity '( headline headline+inlinetask
greater-element element))
(error "Unsupported granularity: %S" granularity))
;; Make TO-POS marker. Otherwise, buffer edits may garble the
;; process.
(unless (markerp to-pos)
(let ((mk (make-marker)))
(set-marker mk to-pos)
(setq to-pos mk)))
(let ((gc-cons-threshold #x40000000)
;; Bind variables used inside loop to avoid memory
;; re-allocation on every iteration.
;; See https://emacsconf.org/2021/talks/faster/
tmpnext-start tmpparent tmpelement)
(save-excursion
(save-restriction
(unless narrow (widen))
;; Synchronize cache up to the end of mapped region.
(org-element-at-point to-pos)
(cl-macrolet ((cache-root
;; Use the most optimal version of cache available.
() `(org-with-base-buffer nil
(if (memq granularity '(headline headline+inlinetask))
(org-element--headline-cache-root)
(org-element--cache-root))))
(cache-size
;; Use the most optimal version of cache available.
() `(org-with-base-buffer nil
(if (memq granularity '(headline headline+inlinetask))
org-element--headline-cache-size
org-element--cache-size)))
(cache-walk-restart
;; Restart tree traversal after AVL tree re-balance.
() `(when node
(org-element-at-point (point-max))
(setq node (cache-root)
stack (list nil)
leftp t
continue-flag t)))
(cache-walk-abort
;; Abort tree traversal.
() `(setq continue-flag t
node nil))
(element-match-at-point
;; Returning the first element to match around point.
;; For example, if point is inside headline and
;; granularity is restricted to headlines only, skip
;; over all the child elements inside the headline
;; and return the first parent headline.
;; When we are inside a cache gap, calling
;; `org-element-at-point' also fills the cache gap down to
;; point.
() `(progn
;; Parsing is one of the performance
;; bottlenecks. Make sure to optimize it as
;; much as possible.
;;
;; Avoid extra staff like timer cancels et al
;; and only call `org-element--cache-sync-requests' when
;; there are pending requests.
(org-with-base-buffer nil
(when org-element--cache-sync-requests
(org-element--cache-sync (current-buffer))))
;; Call `org-element--parse-to' directly avoiding any
;; kind of `org-element-at-point' overheads.
(if restrict-elements
;; Search directly instead of calling
;; `org-element-lineage' to avoid funcall overheads
;; and making sure that we do not go all
;; the way to `org-data' as `org-element-lineage'
;; does.
(progn
(setq tmpelement (org-element--parse-to (point)))
(while (and tmpelement (not (org-element-type-p tmpelement restrict-elements)))
(setq tmpelement (org-element-parent tmpelement)))
tmpelement)
(org-element--parse-to (point)))))
;; Starting from (point), search RE and move START to
;; the next valid element to be matched according to
;; restriction. Abort cache walk if no next element
;; can be found. When RE is nil, just find element at
;; point.
(move-start-to-next-match
;; Preserve match data that might be set by FUNC.
(re) `(save-match-data
(if (or (not ,re)
(if org-element--cache-map-statistics
(progn
(setq before-time (float-time))
(prog1 (re-search-forward (or (car-safe ,re) ,re) nil 'move)
(cl-incf re-search-time
(- (float-time)
before-time))))
(re-search-forward (or (car-safe ,re) ,re) nil 'move)))
(unless (or (< (point) (or start -1))
(and data
(< (point) (org-element-begin data))))
(if (cdr-safe ,re)
;; Avoid parsing when we are 100%
;; sure that regexp is good enough
;; to find new START.
(setq start (match-beginning 0))
(setq start (max (or start -1)
(or (org-element-begin data) -1)
(or (org-element-begin (element-match-at-point)) -1))))
(when (>= start to-pos) (cache-walk-abort))
(when (eq start -1) (setq start nil)))
(cache-walk-abort))))
;; Find expected begin position of an element after
;; DATA.
(next-element-start
() `(progn
(setq tmpnext-start nil)
(if (memq granularity '(headline headline+inlinetask))
(setq tmpnext-start (or (when (org-element-type-p data '(headline org-data))
(org-element-contents-begin data))
(org-element-end data)))
(setq tmpnext-start (or (when (org-element-type-p data org-element-greater-elements)
(org-element-contents-begin data))
(org-element-end data))))
;; DATA end may be the last element inside
;; i.e. source block. Skip up to the end
;; of parent in such case.
(setq tmpparent data)
(catch :exit
(when (eq tmpnext-start (org-element-contents-end tmpparent))
(setq tmpnext-start (org-element-end tmpparent)))
(while (setq tmpparent (org-element-parent tmpparent))
(if (eq tmpnext-start (org-element-contents-end tmpparent))
(setq tmpnext-start (org-element-end tmpparent))
(throw :exit t))))
tmpnext-start))
;; Check if cache does not have gaps.
(cache-gapless-p
() `(org-with-base-buffer nil
(eq org-element--cache-change-tic
(alist-get granularity org-element--cache-gapless)))))
;; The core algorithm is simple walk along binary tree. However,
;; instead of checking all the tree elements from first to last
;; (like in `avl-tree-mapcar'), we begin from FROM-POS skipping
;; the elements before FROM-POS efficiently: O(logN) instead of
;; O(Nbefore).
;;
;; Later, we may also not check every single element in the
;; binary tree after FROM-POS. Instead, we can find position of
;; next candidate elements by means of regexp search and skip the
;; binary tree branches that are before the next candidate:
;; again, O(logN) instead of O(Nbetween).
;;
;; Some elements might not yet be in the tree. So, we also parse
;; the empty gaps in cache as needed making sure that we do not
;; miss anything.
(let* (;; START is always beginning of an element. When there is
;; no element in cache at START, we are inside cache gap
;; and need to fill it.
(start (and from-pos
(progn
(goto-char from-pos)
(org-element-begin (element-match-at-point)))))
;; Some elements may start at the same position, so we
;; also keep track of the last processed element and make
;; sure that we do not try to search it again.
(prev after-element)
(node (cache-root))
data
(stack (list nil))
(leftp t)
result
;; Whether previous element matched FUNC (FUNC
;; returned non-nil).
(last-match t)
continue-flag
;; Generic regexp to search next potential match. If it
;; is a cons of (regexp . 'match-beg), we are 100% sure
;; that the match beginning is the existing element
;; beginning.
(next-element-re (pcase granularity
((or `headline
(guard (equal '(headline)
restrict-elements)))
(cons
(org-with-limited-levels
org-element-headline-re)
'match-beg))
(`headline+inlinetask
(cons
(if (equal '(inlinetask) restrict-elements)
(org-inlinetask-outline-regexp)
org-element-headline-re)
'match-beg))
;; TODO: May add other commonly
;; searched elements as needed.
(_)))
;; Make sure that we are not checking the same regexp twice.
(next-re (unless (and next-re
(string= next-re
(or (car-safe next-element-re)
next-element-re)))
next-re))
(fail-re (unless (and fail-re
(string= fail-re
(or (car-safe next-element-re)
next-element-re)))
fail-re))
(restrict-elements (or restrict-elements
(pcase granularity
(`headline
'(headline))
(`headline+inlinetask
'(headline inlinetask))
(`greater-element
org-element-greater-elements)
(_ nil))))
;; Statistics
(time (float-time))
(predicate-time 0)
(pre-process-time 0)
(re-search-time 0)
(count-predicate-calls-match 0)
(count-predicate-calls-fail 0)
;; Bind variables used inside loop to avoid memory
;; re-allocation on every iteration.
;; See https://emacsconf.org/2021/talks/faster/
cache-size before-time modified-tic)
;; Skip to first element within region.
(goto-char (or start (point-min)))
(move-start-to-next-match next-element-re)
(unless (and start (>= start to-pos))
(while node
(setq data (avl-tree--node-data node))
(if (and leftp (avl-tree--node-left node) ; Left branch.
;; Do not move to left branch when we are before
;; PREV.
(or (not prev)
(not (org-element--cache-key-less-p
(org-element--cache-key data)
(org-element--cache-key prev))))
;; ... or when we are before START.
(or (not start)
(not (> start (org-element-begin data)))))
(progn (push node stack)
(setq node (avl-tree--node-left node)))
;; The whole tree left to DATA is before START and
;; PREV. DATA may still be before START (i.e. when
;; DATA is the root or when START moved), at START, or
;; after START.
;;
;; If DATA is before start, skip it over and move to
;; subsequent elements.
;; If DATA is at start, run FUNC if necessary and
;; update START according and NEXT-RE, FAIL-RE,
;; NEXT-ELEMENT-RE.
;; If DATA is after start, we have found a cache gap
;; and need to fill it.
(unless (or (and start (< (org-element-begin data) start))
(and prev (not (org-element--cache-key-less-p
(org-element--cache-key prev)
(org-element--cache-key data)))))
;; DATA is at of after START and PREV.
(if (or (not start) (= (org-element-begin data) start))
;; DATA is at START. Match it.
;; In the process, we may alter the buffer,
;; so also keep track of the cache state.
(progn
(setq modified-tic
(org-with-base-buffer nil
org-element--cache-change-tic))
(setq cache-size (cache-size))
;; When NEXT-RE/FAIL-RE is provided, skip to
;; next regexp match after :begin of the current
;; element.
(when (if last-match next-re fail-re)
(goto-char (org-element-begin data))
(move-start-to-next-match
(if last-match next-re fail-re)))
(when (and (or (not start) (eq (org-element-begin data) start))
(< (org-element-begin data) to-pos)
(not continue-flag))
;; Calculate where next possible element
;; starts and update START if needed.
(setq start (next-element-start))
(goto-char start)
;; Move START further if possible.
(save-excursion
(when (and next-element-re
;; Do not move if we know for
;; sure that cache does not
;; contain gaps. Regexp
;; searches are not cheap.
(not (cache-gapless-p)))
(move-start-to-next-match next-element-re)))
;; Try FUNC if DATA matches all the
;; restrictions. Calculate new START.
(when (or (not restrict-elements)
(org-element-type-p data restrict-elements))
;; DATA matches restriction. FUNC may
;;
;; Call FUNC. FUNC may move point.
(setq org-element-cache-map-continue-from nil)
(if (org-with-base-buffer nil org-element--cache-map-statistics)
(progn
(setq before-time (float-time))
(push (funcall func data) result)
(cl-incf predicate-time
(- (float-time)
before-time))
(if (car result)
(cl-incf count-predicate-calls-match)
(cl-incf count-predicate-calls-fail)))
(push (funcall func data) result)
(when (car result) (cl-incf count-predicate-calls-match)))
;; Set `last-match'.
(setq last-match (car result))
;; If FUNC moved point forward, update
;; START.
(when org-element-cache-map-continue-from
(goto-char org-element-cache-map-continue-from))
(when (> (point) start)
(move-start-to-next-match nil)
;; (point) inside matching element.
;; Go further.
(when (> (point) start)
(setq data (element-match-at-point))
(if (not data)
(cache-walk-abort)
(goto-char (next-element-start))
(move-start-to-next-match next-element-re))))
;; Drop nil.
(unless (car result) (pop result)))
;; If FUNC did not move the point and we
;; know for sure that cache does not contain
;; gaps, do not try to calculate START in
;; advance but simply loop to the next cache
;; element.
(when (and (cache-gapless-p)
(eq (next-element-start)
start))
(setq start nil))
;; Reached LIMIT-COUNT. Abort.
(when (and limit-count
(>= count-predicate-calls-match
limit-count))
(cache-walk-abort))
;; Make sure that we have a cached
;; element at the new START.
(when start (element-match-at-point)))
;; Check if the buffer or cache has been modified.
(unless (org-with-base-buffer nil
(and (eq modified-tic org-element--cache-change-tic)
(eq cache-size (cache-size))))
;; START may no longer be valid, update
;; it to beginning of real element.
;; Upon modification, START may lay
;; inside an element. We want to move
;; it to real beginning then despite
;; START being larger.
(setq start nil)
(let ((data nil)) ; data may not be valid. ignore it.
(move-start-to-next-match nil))
;; The new element may now start before
;; or at already processed position.
;; Make sure that we continue from an
;; element past already processed
;; place.
(when (and start
(<= start (org-element-begin data))
(not org-element-cache-map-continue-from))
(goto-char start)
(setq data (element-match-at-point))
;; If DATA is nil, buffer is
;; empty. Abort.
(when data
(goto-char (next-element-start))
(move-start-to-next-match next-element-re)))
(org-element-at-point to-pos)
(cache-walk-restart))
(if (org-element-property :cached data)
(setq prev data)
(setq prev nil)))
;; DATA is after START. Fill the gap.
(if (org-element-type-p
(org-element--parse-to start)
'(plain-list table))
;; Tables and lists are special, we need a
;; trickery to make items/rows be populated
;; into cache.
(org-element--parse-to (1+ start)))
;; Restart tree traversal as AVL tree is
;; re-balanced upon adding elements. We can no
;; longer trust STACK.
(cache-walk-restart)))
;; Second, move to the right branch of the tree or skip
;; it altogether.
(if continue-flag
(setq continue-flag nil)
(setq node (if (and (car stack)
;; If START advanced beyond stack parent, skip the right branch.
(or (and start (< (org-element-begin (avl-tree--node-data (car stack))) start))
(and prev (org-element--cache-key-less-p
(org-element--cache-key (avl-tree--node-data (car stack)))
(org-element--cache-key prev)))))
(progn
(setq leftp nil)
(pop stack))
;; Otherwise, move ahead into the right
;; branch when it exists.
(if (setq leftp (avl-tree--node-right node))
(avl-tree--node-right node)
(pop stack))))))))
(when (and org-element--cache-map-statistics
(or (not org-element--cache-map-statistics-threshold)
(> (- (float-time) time) org-element--cache-map-statistics-threshold)))
(message "Mapped over elements in %S. %d/%d predicate matches. Total time: %f sec. Pre-process time: %f sec. Predicate time: %f sec. Re-search time: %f sec.
Calling parameters: :granularity %S :restrict-elements %S :next-re %S :fail-re %S :from-pos %S :to-pos %S :limit-count %S :after-element %S"
(current-buffer)
count-predicate-calls-match
(+ count-predicate-calls-match
count-predicate-calls-fail)
(- (float-time) time)
pre-process-time
predicate-time
re-search-time
granularity restrict-elements next-re fail-re from-pos to-pos limit-count after-element))
;; Return result.
(nreverse result))))))))
;;; The Toolbox
;;
;; The first move is to implement a way to obtain the smallest element
;; containing point. This is the job of `org-element-at-point'. It
;; basically jumps back to the beginning of section containing point
;; and proceed, one element after the other, with
;; `org-element--current-element' until the container is found. Note:
;; When using `org-element-at-point', secondary values are never
;; parsed since the function focuses on elements, not on objects.
;;
;; At a deeper level, `org-element-context' lists all elements and
;; objects containing point.
;;
;; `org-element-nested-p' and `org-element-swap-A-B' may be used
;; internally by navigation and manipulation tools.
;;;###autoload
(defun org-element-at-point (&optional epom cached-only)
"Determine closest element around point or EPOM.
When EPOM is an element, return it immediately.
Otherwise, determine element at EPOM marker or position.
Only check cached element when CACHED-ONLY is non-nil and return nil
unconditionally when element at EPOM is not in cache.
Return value is a list like (TYPE PROPS) where TYPE is the type
of the element and PROPS a plist of properties associated to the
element.
Possible types are defined in `org-element-all-elements'.
Properties depend on element or object type, but always include
`:begin', `:end', and `:post-blank' properties.
As a special case, if point is at the very beginning of the first
item in a list or sub-list, returned element will be that list
instead of the item. Likewise, if point is at the beginning of
the first row of a table, returned element will be the table
instead of the first row.
When point is at the end of the buffer, return the innermost
element ending there.
This function may modify the match data."
(if (org-element-type epom t) epom
(setq epom (or epom (point)))
(org-with-point-at epom
(unless (derived-mode-p 'org-mode)
(display-warning
'(org-element org-element-parser)
(format-message
"`org-element-at-point' cannot be used in non-Org buffer %S (%s)"
(current-buffer) major-mode)))
;; Allow re-parsing when the command can benefit from it.
(when (and cached-only
(memq this-command org-element--cache-non-modifying-commands))
(setq cached-only nil))
(let (element)
(when (org-element--cache-active-p)
(if (not (org-with-base-buffer nil org-element--cache)) (org-element-cache-reset)
(unless cached-only (org-element--cache-sync (current-buffer) epom))))
(setq element (if cached-only
(when (and (org-element--cache-active-p)
(or (not org-element--cache-sync-requests)
(< epom
(org-element--request-beg
(car org-element--cache-sync-requests)))))
(org-element--cache-find epom))
(condition-case-unless-debug err
(org-element--parse-to epom)
(error
(org-element--cache-warn
"Org parser error in %s::%S. Resetting.\n The error was: %S\n Backtrace:\n%S\n Please report this to Org mode mailing list (M-x org-submit-bug-report)."
(buffer-name (current-buffer))
epom
err
(when (and (fboundp 'backtrace-get-frames)
(fboundp 'backtrace-to-string))
(backtrace-to-string (backtrace-get-frames 'backtrace))))
(org-element-cache-reset)
(org-element--parse-to epom)))))
(when (and (org-element--cache-active-p)
element
(org-element--cache-verify-element element))
(setq element (org-element--parse-to epom)))
(unless (org-element-type-p element 'org-data)
(unless (and cached-only
(not (and element
(or (= epom (org-element-begin element))
(and (not (org-element-type-p element org-element-greater-elements))
(>= epom (org-element-begin element))
(< epom (org-element-end element)))
(and (org-element-contents-begin element)
(>= epom (org-element-begin element))
(< epom (org-element-contents-begin element)))
(and (not (org-element-contents-end element))
(>= epom (org-element-begin element))
(< epom (org-element-end element)))))))
(if (not (org-element-type-p element 'section))
element
(org-element-at-point (1+ epom) cached-only))))))))
;;;###autoload
(defsubst org-element-at-point-no-context (&optional pom)
"Quickly find element at point or POM.
It is a faster version of `org-element-at-point' that is not
guaranteed to return cached element. `:parent' element may be
deferred and slow to retrieve."
(or (org-element-at-point pom 'cached-only)
(org-element-with-disabled-cache (org-element-at-point pom))))
;;;###autoload
(defun org-element-context (&optional element)
"Return smallest element or object around point.
Return value is a list like (TYPE PROPS) where TYPE is the type
of the element or object and PROPS a plist of properties
associated to it.
Possible types are defined in `org-element-all-elements' and
`org-element-all-objects'. Properties depend on element or
object type, but always include `:begin', `:end', `:parent' and
`:post-blank'.
As a special case, if point is right after an object and not at
the beginning of any other object, return that object.
Optional argument ELEMENT, when non-nil, is the closest element
containing point, as returned by `org-element-at-point'.
Providing it allows for quicker computation.
This function may modify match data."
(catch 'objects-forbidden
(org-with-wide-buffer
(let* ((pos (point))
(element (or element (org-element-at-point)))
(type (org-element-type element))
(post (org-element-post-affiliated element)))
;; If point is inside an element containing objects or
;; a secondary string, narrow buffer to the container and
;; proceed with parsing. Otherwise, return ELEMENT.
(cond
;; At a parsed affiliated keyword, check if we're inside main
;; or dual value.
((and post (< pos post))
(forward-line 0)
(let ((case-fold-search t)) (looking-at org-element--affiliated-re))
(cond
((not (member-ignore-case (match-string 1)
org-element-parsed-keywords))
(throw 'objects-forbidden element))
((<= (match-end 0) pos)
(narrow-to-region (match-end 0) (line-end-position)))
((and (match-beginning 2)
(>= pos (match-beginning 2))
(< pos (match-end 2)))
(narrow-to-region (match-beginning 2) (match-end 2)))
(t (throw 'objects-forbidden element)))
;; Also change type to retrieve correct restrictions.
(setq type 'keyword))
;; At an item, objects can only be located within tag, if any.
((eq type 'item)
(let ((tag (org-element-property :tag element)))
(if (or (not tag) (/= (line-beginning-position) post))
(throw 'objects-forbidden element)
(forward-line 0)
(search-forward tag (line-end-position))
(goto-char (match-beginning 0))
(if (and (>= pos (point)) (< pos (match-end 0)))
(narrow-to-region (point) (match-end 0))
(throw 'objects-forbidden element)))))
;; At an headline or inlinetask, objects are in title.
((memq type '(headline inlinetask))
(let ((case-fold-search nil))
(goto-char (org-element-begin element))
(looking-at org-complex-heading-regexp)
(let ((end (match-end 4)))
(if (not end) (throw 'objects-forbidden element)
(goto-char (match-beginning 4))
(when (looking-at org-element-comment-string)
(goto-char (match-end 0)))
(if (>= (point) end) (throw 'objects-forbidden element)
(narrow-to-region (point) end))))))
;; At a paragraph, a table-row or a verse block, objects are
;; located within their contents.
((memq type '(paragraph table-row verse-block))
(let ((cbeg (org-element-contents-begin element))
(cend (org-element-contents-end element)))
;; CBEG is nil for table rules.
(if (and cbeg cend (>= pos cbeg)
(or (< pos cend) (and (= pos cend) (eobp))))
(narrow-to-region cbeg cend)
(throw 'objects-forbidden element))))
(t (throw 'objects-forbidden element)))
(goto-char (point-min))
(let ((restriction (org-element-restriction type))
(parent element)
last)
(catch 'exit
(while t
(let ((next (org-element--object-lex restriction)))
(when next (org-element-put-property next :parent parent))
;; Process NEXT, if any, in order to know if we need to
;; skip it, return it or move into it.
(if (or (not next) (> (org-element-begin next) pos))
(throw 'exit (or last parent))
(let ((end (org-element-end next))
(cbeg (org-element-contents-begin next))
(cend (org-element-contents-end next)))
(cond
;; Skip objects ending before point. Also skip
;; objects ending at point unless it is also the
;; end of buffer, since we want to return the
;; innermost object.
((and (<= end pos) (/= (point-max) end))
(goto-char end)
;; For convenience, when object ends at POS,
;; without any space, store it in LAST, as we
;; will return it if no object starts here.
(when (and (= end pos)
(not (memq (char-before) '(?\s ?\t))))
(setq last next)))
;; If POS is within a container object, move into
;; that object.
((and cbeg cend
(>= pos cbeg)
(or (< pos cend)
;; At contents' end, if there is no
;; space before point, also move into
;; object, for consistency with
;; convenience feature above.
(and (= pos cend)
(or (= (point-max) pos)
(not (memq (char-before pos)
'(?\s ?\t)))))))
(goto-char cbeg)
(narrow-to-region (point) cend)
(setq parent next)
(setq restriction (org-element-restriction next)))
;; Otherwise, return NEXT.
(t (throw 'exit next)))))))))))))
(defun org-element-nested-p (elem-A elem-B)
"Non-nil when elements ELEM-A and ELEM-B are nested."
(let ((beg-A (org-element-begin elem-A))
(beg-B (org-element-begin elem-B))
(end-A (org-element-end elem-A))
(end-B (org-element-end elem-B)))
(or (and (>= beg-A beg-B) (<= end-A end-B))
(and (>= beg-B beg-A) (<= end-B end-A)))))
(defun org-element-swap-A-B (elem-A elem-B)
"Swap elements ELEM-A and ELEM-B.
Assume ELEM-B is after ELEM-A in the buffer. Leave point at the
end of ELEM-A."
(goto-char (org-element-begin elem-A))
;; There are two special cases when an element doesn't start at bol:
;; the first paragraph in an item or in a footnote definition.
(let ((specialp (not (bolp))))
;; Only a paragraph without any affiliated keyword can be moved at
;; ELEM-A position in such a situation. Note that the case of
;; a footnote definition is impossible: it cannot contain two
;; paragraphs in a row because it cannot contain a blank line.
(when (and specialp
(or (not (org-element-type-p elem-B 'paragraph))
(/= (org-element-begin elem-B)
(org-element-contents-begin elem-B))))
(error "Cannot swap elements"))
;; Preserve folding state when `org-fold-core-style' is set to
;; `text-properties'.
(org-fold-core-ignore-modifications
;; In a special situation, ELEM-A will have no indentation. We'll
;; give it ELEM-B's (which will in, in turn, have no indentation).
(let* ((ind-B (when specialp
(goto-char (org-element-begin elem-B))
(current-indentation)))
(beg-A (org-element-begin elem-A))
(end-A (save-excursion
(goto-char (org-element-end elem-A))
(skip-chars-backward " \r\t\n")
(line-end-position)))
(beg-B (org-element-begin elem-B))
(end-B (save-excursion
(goto-char (org-element-end elem-B))
(skip-chars-backward " \r\t\n")
(line-end-position)))
;; Store inner folds responsible for visibility status.
(folds
(cons
(org-fold-core-get-regions :from beg-A :to end-A :relative t)
(org-fold-core-get-regions :from beg-B :to end-B :relative t)))
;; Get contents.
(body-A (buffer-substring beg-A end-A))
(body-B (buffer-substring beg-B end-B)))
;; Clear up the folds.
(org-fold-region beg-A end-A nil)
(org-fold-region beg-B end-B nil)
(delete-region beg-B end-B)
(goto-char beg-B)
(when specialp
(setq body-B (replace-regexp-in-string "\\`[ \t]*" "" body-B))
(indent-to-column ind-B))
(insert body-A)
;; Restore ex ELEM-A folds.
(org-fold-core-regions (car folds) :relative beg-B)
(goto-char beg-A)
(delete-region beg-A end-A)
(insert body-B)
;; Restore ex ELEM-A folds.
(org-fold-core-regions (cdr folds) :relative beg-A)
(goto-char (org-element-end elem-B))))))
(provide 'org-element)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; org-element.el ends here
org-mode-9.7.29+dfsg/lisp/org-entities.el 0000664 0000000 0000000 00000073052 15004304337 0020162 0 ustar 00root root 0000000 0000000 ;;; org-entities.el --- Support for Special Entities -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2025 Free Software Foundation, Inc.
;; Author: Carsten Dominik ,
;; Ulf Stegemann
;; Maintainer: Ihor Radchenko
;; Keywords: outlines, calendar, text
;; URL: https://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
;; Maintainer: Ihor Radchenko
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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 ' field and `:pubDate' for the publication date. In addition,
it contains the following properties:
`:item-full-text' the full text in the <item> tag
`:guid-permalink' t when the guid property is a permalink
Here are the keyword-value pair allows in `org-feed-alist'.
:drawer drawer-name
The name of the drawer for storing feed information. The default is
\"FEEDSTATUS\". Using different drawers for different feeds allows
several feeds to target the same inbox heading.
:filter filter-function
A function to select interesting entries in the feed. It gets a single
entry as parameter. It should return the entry if it is relevant, or
nil if it is not.
:template template-string
The default action on new items in the feed is to add them as children
under the headline for the feed. The template describes how the entry
should be formatted. If not given, it defaults to
`org-feed-default-template'.
:formatter formatter-function
Instead of relying on a template, you may specify a function to format
the outline node to be inserted as a child. This function gets passed
a property list describing a single feed item, and it should return a
string that is a properly formatted Org outline node of level 1.
:new-handler function
If adding new items as children to the outline is not what you want
to do with new items, define a handler function that is called with
a list of all new items in the feed, each one represented as a property
list. The handler should do what needs to be done, and org-feed will
mark all items given to this handler as \"handled\", i.e. they will not
be passed to this handler again in future readings of the feed.
When the handler is called, point will be at the feed headline.
:changed-handler function
This function gets passed a list of all entries that have been
handled before, but are now still in the feed and have *changed*
since last handled (as evidenced by a different sha1 hash).
When the handler is called, point will be at the feed headline.
:parse-feed function
This function gets passed a buffer, and should return a list
of entries, each being a property list containing the
`:guid' and `:item-full-text' keys. The default is
`org-feed-parse-rss-feed'; `org-feed-parse-atom-feed' is an
alternative.
:parse-entry function
This function gets passed an entry as returned by the parse-feed
function, and should return the entry with interesting properties added.
The default is `org-feed-parse-rss-entry'; `org-feed-parse-atom-entry'
is an alternative."
:group 'org-feed
:type '(repeat
(list :value ("" "http://" "" "")
(string :tag "Name")
(string :tag "Feed URL")
(file :tag "File for inbox")
(string :tag "Headline for inbox")
(repeat :inline t
(choice
(list :inline t :tag "Filter"
(const :filter)
(symbol :tag "Filter Function"))
(list :inline t :tag "Template"
(const :template)
(string :tag "Template"))
(list :inline t :tag "Formatter"
(const :formatter)
(symbol :tag "Formatter Function"))
(list :inline t :tag "New items handler"
(const :new-handler)
(symbol :tag "Handler Function"))
(list :inline t :tag "Changed items"
(const :changed-handler)
(symbol :tag "Handler Function"))
(list :inline t :tag "Parse Feed"
(const :parse-feed)
(symbol :tag "Parse Feed Function"))
(list :inline t :tag "Parse Entry"
(const :parse-entry)
(symbol :tag "Parse Entry Function"))
)))))
(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'."
:group 'org-feed
:type '(string :tag "Drawer Name"))
(defcustom org-feed-default-template "\n* %h\n %U\n %description\n %a\n"
"Template for the Org node created from RSS feed items.
This is just the default, each feed can specify its own.
Any fields from the feed item can be interpolated into the template with
%name, for example %title, %description, %pubDate etc. In addition, the
following special escapes are valid as well:
%h The title, or the first line of the description
%t The date as a stamp, either from <pubDate> (if present), or
the current date
%T Date and time
%u,%U Like %t,%T, but inactive time stamps
%a A link, from <guid> if that is a permalink, else from <link>
%(sexp) Evaluate elisp `(sexp)' and replace with the result, the simple
%-escapes above can be used as arguments, e.g. %(capitalize \\\"%h\\\")"
:group 'org-feed
:type '(string :tag "Template"))
(defcustom org-feed-save-after-adding t
"Non-nil means save buffer after adding new feed items."
:group 'org-feed
:type 'boolean)
(defcustom org-feed-retrieve-method 'url-retrieve-synchronously
"The method to be used to retrieve a feed URL.
This can be `curl' or `wget' to call these external programs, or it can be
an Emacs Lisp function that will return a buffer containing the content
of the file pointed to by the URL."
:group 'org-feed
:type '(choice
(const :tag "Internally with url.el" url-retrieve-synchronously)
(const :tag "Externally with curl" curl)
(const :tag "Externally with wget" wget)
(function :tag "Function")))
(defcustom org-feed-before-adding-hook nil
"Hook that is run before adding new feed items to a file.
You might want to commit the file in its current state to version control,
for example."
:group 'org-feed
:type 'hook)
(defcustom org-feed-after-adding-hook nil
"Hook that is run after new items have been added to a file.
Depending on `org-feed-save-after-adding', the buffer will already
have been saved."
:group 'org-feed
:type 'hook)
(defvar org-feed-buffer "*Org feed*"
"The buffer used to retrieve a feed.")
;;;###autoload
(defun org-feed-update-all ()
"Get inbox items from all feeds in `org-feed-alist'."
(interactive)
(let ((entries 0)
(errors 0)
(total-feeds (length org-feed-alist)))
(dolist (feed org-feed-alist)
(let ((items (ignore-errors (org-feed-update feed))))
(if items (cl-incf entries items)
(cl-incf errors))))
(message "%s from %d %s%s"
(pcase entries
(0 "No new entries")
(1 "1 new entry")
(_ (format "%d new entries" entries)))
total-feeds
(if (= total-feeds 1) "feed" "feeds")
(if (= 0 errors) "" (format " (unavailable feeds: %d)" errors)))))
;;;###autoload
(defun org-feed-update (feed &optional retrieve-only)
"Get inbox items from FEED.
FEED can be a string with an association in `org-feed-alist', or
it can be a list structured like an entry in `org-feed-alist'."
(interactive (list (org-completing-read "Feed name: " org-feed-alist)))
(if (stringp feed) (setq feed (assoc feed org-feed-alist)))
(unless feed
(error "No such feed in `org-feed-alist"))
(catch 'exit
(let ((name (car feed))
(url (nth 1 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)))
(new-handler (nth 1 (memq :new-handler feed)))
(changed-handler (nth 1 (memq :changed-handler feed)))
(template (or (nth 1 (memq :template feed))
org-feed-default-template))
(drawer (or (nth 1 (memq :drawer feed))
org-feed-drawer))
(parse-feed (or (nth 1 (memq :parse-feed feed))
'org-feed-parse-rss-feed))
(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 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))
(when retrieve-only
(throw 'exit feed-buffer))
(setq entries (funcall parse-feed feed-buffer))
(ignore-errors (kill-buffer feed-buffer))
(save-excursion
(save-window-excursion
(setq inbox-pos (org-feed-goto-inbox-internal file headline))
(setq old-status (org-feed-read-previous-status inbox-pos drawer))
;; Add the "handled" status to the appropriate entries
(setq entries (mapcar (lambda (e)
(setq e
(plist-put e :handled
(nth 1 (assoc
(plist-get e :guid)
old-status)))))
entries))
;; Find out which entries are new and which are changed
(dolist (e entries)
(if (not (plist-get e :handled))
(push e new)
(setq olds (nth 2 (assoc (plist-get e :guid) old-status)))
(if (and olds
(not (string= (sha1
(plist-get e :item-full-text))
olds)))
(push e changed))))
;; Parse the relevant entries fully
(setq new (mapcar parse-entry new)
changed (mapcar parse-entry changed))
;; Run the filter
(when filter
(setq new (delq nil (mapcar filter new))
changed (delq nil (mapcar filter new))))
(when (not (or new changed))
(message "No new items in feed %s" name)
(throw 'exit 0))
;; Get alist based on guid, to look up entries
(setq guid-alist
(append
(mapcar (lambda (e) (list (plist-get e :guid) e)) new)
(mapcar (lambda (e) (list (plist-get e :guid) e)) changed)))
;; Construct the new status
(setq status
(mapcar
(lambda (e)
(setq guid (plist-get e :guid))
(list guid
;; things count as handled if we handle them now,
;; or if they were handled previously
(if (assoc guid guid-alist) t (plist-get e :handled))
;; A hash, to detect changes
(sha1 (plist-get e :item-full-text))))
entries))
;; Handle new items in the feed
(when new
(if new-handler
(progn
(goto-char inbox-pos)
(funcall new-handler new))
;; No custom handler, do the default adding
;; Format the new entries into an alist with GUIDs in the car
(setq new-formatted
(mapcar
(lambda (e) (org-feed-format-entry e template formatter))
new)))
;; Insert the new items
(org-feed-add-items inbox-pos new-formatted))
;; Handle changed items in the feed
(when (and changed-handler changed)
(goto-char inbox-pos)
(funcall changed-handler changed))
;; Write the new status
;; We do this only now, in case something goes wrong above, so
;; that would end up with a status that does not reflect
;; which items truly have been handled
(org-feed-write-status inbox-pos drawer status)
;; Normalize the visibility of the inbox tree
(goto-char inbox-pos)
(org-fold-subtree t)
(org-fold-show-children)
;; Hooks and messages
(when org-feed-save-after-adding (save-buffer))
(message "Added %d new item%s from feed %s to file %s, heading %s"
(length new) (if (> (length new) 1) "s" "")
name
(file-name-nondirectory file) headline)
(run-hooks 'org-feed-after-adding-hook)
(length new))))))
;;;###autoload
(defun org-feed-goto-inbox (feed)
"Go to the inbox that captures the feed named FEED."
(interactive
(list (if (= (length org-feed-alist) 1)
(car org-feed-alist)
(org-completing-read "Feed name: " org-feed-alist))))
(if (stringp feed) (setq feed (assoc feed org-feed-alist)))
(unless feed
(error "No such feed in `org-feed-alist"))
(org-feed-goto-inbox-internal (nth 2 feed) (nth 3 feed)))
;;;###autoload
(defun org-feed-show-raw-feed (feed)
"Show the raw feed buffer of a feed."
(interactive
(list (if (= (length org-feed-alist) 1)
(car org-feed-alist)
(org-completing-read "Feed name: " org-feed-alist))))
(if (stringp feed) (setq feed (assoc feed org-feed-alist)))
(unless feed
(error "No such feed in `org-feed-alist"))
(pop-to-buffer-same-window
(org-feed-update feed 'retrieve-only))
(goto-char (point-min)))
(defun org-feed-goto-inbox-internal (file heading)
"Find or create HEADING in FILE.
Switch to that buffer, and return the position of that headline."
(find-file file)
(widen)
(goto-char (point-min))
(if (re-search-forward
(concat "^\\*+[ \t]+" heading "[ \t]*\\(:.*?:[ \t]*\\)?$")
nil t)
(goto-char (match-beginning 0))
(goto-char (point-max))
(insert "\n\n* " heading "\n\n")
(org-back-to-heading t))
(point))
(defun org-feed-read-previous-status (pos drawer)
"Get the alist of old GUIDs from the entry at POS.
This will find DRAWER and extract the alist."
(save-excursion
(goto-char pos)
(let ((end (save-excursion (org-end-of-subtree t t))))
(if (re-search-forward
(concat "^[ \t]*:" drawer ":[ \t]*\n\\(\\(?:.\\|\n\\)*?\\)\n[ \t]*:END:")
end t)
(read (match-string 1))
nil))))
(defun org-feed-write-status (pos drawer status)
"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))))
(if (re-search-forward (concat "^[ \t]*:" drawer ":[ \t]*\n")
end t)
(progn
(goto-char (match-end 0))
(delete-region (point)
(save-excursion
(and (re-search-forward "^[ \t]*:END:" nil t)
(match-beginning 0)))))
(outline-next-heading)
(insert " :" drawer ":\n :END:\n")
(forward-line -1))
(insert (pp-to-string status)))))
(defun org-feed-add-items (pos entries)
"Add the formatted items to the headline as POS."
(let (entry level)
(save-excursion
(goto-char pos)
(unless (looking-at org-complex-heading-regexp)
(error "Wrong position"))
(setq level (org-get-valid-level (length (match-string 1)) 1))
(org-end-of-subtree t t)
(skip-chars-backward " \t\n")
(forward-line 1)
(setq pos (point))
(while (setq entry (pop entries))
(org-paste-subtree level entry 'yank))
(org-mark-ring-push pos))))
(defun org-feed-format-entry (entry template formatter)
"Format ENTRY so that it can be inserted into an Org file.
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
(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)
(goto-char (point-min))
;; Mark %() embedded elisp for later evaluation.
(org-capture-expand-embedded-elisp 'mark)
;; 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
(forward-line 0)
(if (looking-at
(concat "^\\([ \t]*\\)%" name "[ \t]*$"))
(org-feed-make-indented-block
v (current-indentation))
v))))))))
(when replacement
(insert
;; Escape string delimiters within embedded lisp.
(if (org-capture-inside-embedded-elisp-p)
(replace-regexp-in-string "\"" "\\\\\"" replacement)
replacement)))))))
;; %() 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 ?\ )))))
(defun org-feed-skip-http-headers (buffer)
"Remove HTTP headers from BUFFER, and return it.
Assumes headers are indeed present!"
(with-current-buffer buffer
(widen)
(goto-char (point-min))
(search-forward "\n\n")
(delete-region (point-min) (point))
buffer))
(defun org-feed-get-feed (url)
"Get the RSS feed file at URL and return the buffer."
(cond
((eq org-feed-retrieve-method 'url-retrieve-synchronously)
(org-feed-skip-http-headers (url-retrieve-synchronously url)))
((eq org-feed-retrieve-method 'curl)
(ignore-errors (kill-buffer org-feed-buffer))
(call-process "curl" nil org-feed-buffer nil "--silent" url)
org-feed-buffer)
((eq org-feed-retrieve-method 'wget)
(ignore-errors (kill-buffer org-feed-buffer))
(call-process "wget" nil org-feed-buffer nil "-q" "-O" "-" url)
org-feed-buffer)
((functionp org-feed-retrieve-method)
(funcall org-feed-retrieve-method url))))
(defun org-feed-parse-rss-feed (buffer)
"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
(widen)
(goto-char (point-min))
(while (re-search-forward "<item\\>.*?>" nil t)
(setq beg (point)
end (and (re-search-forward "</item>" nil t)
(match-beginning 0)))
(setq item (buffer-substring beg end)
guid (if (string-match "<guid\\>.*?>\\(\\(?:.\\|\n\\)*?\\)</guid>" item)
(xml-substitute-special (match-string-no-properties 1 item))))
(setq entry (list :guid guid :item-full-text item))
(push entry entries)
(widen)
(goto-char end))
(nreverse entries))))
(defun org-feed-parse-rss-entry (entry)
"Parse the `:item-full-text' field for xml tags and create new properties."
(require 'xml)
(with-temp-buffer
(insert (plist-get entry :item-full-text))
(goto-char (point-min))
(while (re-search-forward "<\\([a-zA-Z]+\\>\\).*?>\\(\\(?:.\\|\n\\)*?\\)</\\1>"
nil t)
(setq entry (plist-put entry
(intern (concat ":" (match-string 1)))
(xml-substitute-special (match-string 2)))))
(goto-char (point-min))
(unless (re-search-forward "isPermaLink[ \t]*=[ \t]*\"false\"" nil t)
(setq entry (plist-put entry :guid-permalink t))))
entry)
(defun org-feed-parse-atom-feed (buffer)
"Parse BUFFER for Atom feed entries.
Returns a list of entries, with each entry a property list,
containing the properties `:guid' and `:item-full-text'.
The `:item-full-text' property actually contains the sexp
formatted as a string, not the original XML data."
(require 'xml)
(with-current-buffer buffer
(widen)
(let ((feed (car (xml-parse-region (point-min) (point-max)))))
(mapcar
(lambda (entry)
(list
:guid (car (xml-node-children (car (xml-get-children entry 'id))))
:item-full-text (prin1-to-string entry)))
(xml-get-children feed 'entry)))))
(defun org-feed-parse-atom-entry (entry)
"Parse the `:item-full-text' as a sexp and create new properties."
(let ((xml (car (read-from-string (plist-get entry :item-full-text)))))
;; Get first <link href='foo'/>.
(setq entry (plist-put entry :link
(xml-get-attribute
(car (xml-get-children xml 'link))
'href)))
;; Add <title/> as :title.
(setq entry (plist-put entry :title
(xml-substitute-special
(car (xml-node-children
(car (xml-get-children xml 'title)))))))
(let* ((content (car (xml-get-children xml 'content)))
(type (xml-get-attribute-or-nil content 'type)))
(when content
(cond
((string= type "text")
;; We like plain text.
(setq entry (plist-put entry :description
(xml-substitute-special
(car (xml-node-children content))))))
((string= type "html")
;; TODO: convert HTML to Org markup.
(setq entry (plist-put entry :description
(xml-substitute-special
(car (xml-node-children content))))))
((string= type "xhtml")
;; TODO: convert XHTML to Org markup.
(setq entry (plist-put entry :description
(prin1-to-string
(xml-node-children content)))))
(t
(setq entry (plist-put entry :description
(format-message
"Unknown `%s' content." type)))))))
entry))
(provide 'org-feed)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; org-feed.el ends here
org-mode-9.7.29+dfsg/lisp/org-fold-core.el 0000664 0000000 0000000 00000243124 15004304337 0020207 0 ustar 00root root 0000000 0000000 ;;; org-fold-core.el --- Folding buffer text -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2020-2025 Free Software Foundation, Inc.
;;
;; Author: Ihor Radchenko <yantar92 at posteo dot net>
;; Maintainer: Ihor Radchenko <yantar92 at posteo dot net>
;; Keywords: folding, invisible text
;; URL: https://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 <https://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;; This file contains library to control temporary invisibility
;; (folding and unfolding) of text in buffers.
;; The file implements the following functionality:
;;
;; - Folding/unfolding regions of text
;; - Searching and examining boundaries of folded text
;; - Interactive searching in folded text (via isearch)
;; - Handling edits in folded text
;; - Killing/yanking (copying/pasting) of the folded text
;; To setup folding in an arbitrary buffer, one must call
;; `org-fold-core-initialize', optionally providing the list of folding specs to be
;; used in the buffer. The specs can be added, removed, or
;; re-configured later. Read below for more details.
;;; Folding/unfolding regions of text
;; User can temporarily hide/reveal (fold/unfold) arbitrary regions or
;; text. The folds can be nested.
;; Internally, nested folds are marked with different folding specs
;; Overlapping folds marked with the same folding spec are
;; automatically merged, while folds with different folding specs can
;; coexist and be folded/unfolded independently.
;; When multiple folding specs are applied to the same region of text,
;; text visibility is decided according to the folding spec with
;; topmost priority.
;; By default, we define two types of folding specs:
;; - 'org-fold-visible :: the folded text is not hidden
;; - 'org-fold-hidden :: the folded text is completely hidden
;;
;; The 'org-fold-visible spec has highest priority allowing parts of
;; text folded with 'org-fold-hidden to be shown unconditionally.
;; Consider the following Org mode link:
;; [[file:/path/to/file/file.ext][description]]
;; Only the word "description" is normally visible in this link.
;;
;; The way this partial visibility is achieved is combining the two
;; folding specs. The whole link is folded using 'org-fold-hidden
;; folding spec, but the visible part is additionally folded using
;; 'org-fold-visible:
;;
;; <begin org-fold-hidden>[[file:/path/to/file/file.ext][<begin org-fold-visible>description<end org-fold-visible>]]<end org-fold-hidden>
;;
;; Because 'org-fold-visible has higher priority than
;; 'org-fold-hidden, it suppresses the 'org-fold-hidden effect and
;; thus reveals the description part of the link.
;; Similar to 'org-fold-visible, display of any arbitrary folding spec
;; can be configured using folding spec properties. In particular,
;; `:visible' folding spec property controls whether the folded text
;; is visible or not. If the `:visible' folding spec property is nil,
;; folded text is hidden or displayed as a constant string (ellipsis)
;; according to the value of `:ellipsis' folding spec property. See
;; docstring of `org-fold-core--specs' for the description of all the available
;; folding spec properties.
;; Folding spec properties of any valid folding spec can be changed
;; any time using `org-fold-core-set-folding-spec-property'.
;; If necessary, one can add or remove folding specs using
;; `org-fold-core-add-folding-spec' and `org-fold-core-remove-folding-spec'.
;; If a buffer initialized with `org-fold-core-initialize' is cloned into indirect
;; buffers, it's folding state is copied to that indirect buffer.
;; The folding states are independent.
;; When working with indirect buffers that are handled by this
;; library, one has to keep in mind that folding state is preserved on
;; copy when using non-interactive functions. Moreover, the folding
;; states of all the indirect buffers will be copied together.
;;
;; Example of the implications:
;; Consider a base buffer and indirect buffer with the following state:
;; ----- base buffer --------
;; * Heading<begin fold>
;; Some text folded in the base buffer, but unfolded in the indirect buffer<end fold>
;; * Other heading
;; Heading unfolded in both the buffers.
;; ---------------------------
;; ------ indirect buffer ----
;; * Heading
;; Some text folded in the base buffer, but unfolded in the indirect buffer
;; * Other heading
;; Heading unfolded in both the buffers.
;; ----------------------------
;; If some Elisp code copies the whole "Heading" from the indirect
;; buffer with `buffer-substring' or match data and inserts it into
;; the base buffer, the inserted heading will be folded since the
;; internal setting for the folding state is shared between the base
;; and indirect buffers. It's just that the indirect buffer ignores
;; the base buffer folding settings. However, as soon as the text is
;; copied back to the base buffer, the folding state will become
;; respected again.
;; If the described situation is undesired, Elisp code can use
;; `filter-buffer-substring' instead of `buffer-substring'. All the
;; folding states that do not belong to the currently active buffer
;; will be cleared in the copied text then. See
;; `org-fold-core--buffer-substring-filter' for more details.
;; Because of details of implementation of the folding, it is also not
;; recommended to set text visibility in buffer directly by setting
;; `invisible' text property to anything other than t. While this
;; should usually work just fine, normal folding can be broken if one
;; sets `invisible' text property to a value not listed in
;; `buffer-invisibility-spec'.
;;; Searching and examining boundaries of folded text
;; It is possible to examine folding specs (there may be several) of
;; text at point or search for regions with the same folding spec.
;; See functions defined under ";;;; Searching and examining folded
;; text" below for details.
;; All the folding specs can be specified by symbol representing their
;; name. However, this is not always convenient, especially if the
;; same spec can be used for fold different syntactical structures.
;; Any folding spec can be additionally referenced by a symbol listed
;; in the spec's `:alias' folding spec property. For example, Org
;; mode's `org-fold-outline' folding spec can be referenced as any
;; symbol from the following list: '(headline heading outline
;; inlinetask plain-list) The list is the value of the spec's `:alias'
;; property.
;; Most of the functions defined below that require a folding spec
;; symbol as their argument, can also accept any symbol from the
;; `:alias' spec property to reference that folding spec.
;; If one wants to search invisible text without using the provided
;; functions, it is important to keep in mind that 'invisible text
;; property may have multiple possible values (not just nil and
;; t). Hence, (next-single-char-property-change pos 'invisible) is not
;; guaranteed to return the boundary of invisible/visible text.
;;; Interactive searching inside folded text (via isearch)
;; The library provides a way to control if the folded text can be
;; searchable using isearch. If the text is searchable, it is also
;; possible to control to unfold it temporarily during interactive
;; isearch session.
;; The isearch behavior is controlled on per-folding-spec basis by
;; setting `isearch-open' and `isearch-ignore' folding spec
;; properties. See the docstring of `org-fold-core--specs' for more details.
;;; Handling edits inside folded text
;; The visibility of the text inserted in front, rear, or in the
;; middle of a folded region is managed according to `:front-sticky'
;; and `:rear-sticky' folding properties of the corresponding folding
;; spec. The rules are the same with stickiness of text properties in
;; Elisp.
;; If a text being inserted into the buffer is already folded and
;; invisible (before applying the stickiness rules), then it is
;; revealed. This behavior can be changed by wrapping the insertion
;; code into `org-fold-core-ignore-modifications' macro. The macro will disable
;; all the processing related to buffer modifications.
;; The library also provides a way to unfold the text after some
;; destructive changes breaking syntactical structure of the buffer.
;; For example, Org mode automatically reveals folded drawers when the
;; drawer becomes syntactically incorrect:
;; ------- before modification -------
;; :DRAWER:<begin fold>
;; Some folded text inside drawer
;; :END:<end fold>
;; -----------------------------------
;; If the ":END:" is edited, drawer syntax is not correct anymore and
;; the folded text is automatically unfolded.
;; ------- after modification --------
;; :DRAWER:
;; Some folded text inside drawer
;; :EN:
;; -----------------------------------
;; The described automatic unfolding is controlled by `:fragile'
;; folding spec property. It's value can be a function checking if
;; changes inside (or around) the fold should drigger the unfold. By
;; default, only changes that directly involve folded regions will
;; trigger the check. In addition, `org-fold-core-extend-changed-region-functions'
;; can be set to extend the checks to all folded regions intersecting
;; with the region returned by the functions listed in the variable.
;; The fragility checks can be bypassed if the code doing
;; modifications is wrapped into `org-fold-core-ignore-fragility-checks' macro.
;;; Performance considerations
;; This library is using text properties to hide text. Text
;; properties are much faster than overlays, that could be used for
;; the same purpose. Overlays are implemented with O(n) complexity in
;; Emacs (as for 2021-03-11). It means that any attempt to move
;; through hidden text in a file with many invisible overlays will
;; require time scaling with the number of folded regions (the problem
;; Overlays note of the manual warns about). For curious, historical
;; reasons why overlays are not efficient can be found in
;; https://www.jwz.org/doc/lemacs.html.
;; Despite using text properties, the performance is still limited by
;; Emacs display engine. For example, >7Mb of text hidden within
;; visible part of a buffer may cause noticeable lags (which is still
;; orders of magnitude better in comparison with overlays). If the
;; performance issues become critical while using this library, it is
;; recommended to minimize the number of folding specs used in the
;; same buffer at a time.
;; Alternatively, the library provides `org-fold-core--optimise-for-huge-buffers'
;; for additional speedup. This can be used as a file-local variable
;; in huge buffers. The variable can be set to enable various levels
;; of extra optimization. See the docstring for detailed information.
;; It is worth noting that when using `org-fold-core--optimise-for-huge-buffers'
;; with `grab-invisible' option, folded regions copied to other
;; buffers (including buffers that do not use this library) will
;; remain invisible. org-fold-core provides functions to work around
;; this issue: `org-fold-core-remove-optimisation' and `org-fold-core-update-optimisation', but
;; it is unlikely that a random external package will use them.
;; Another possible bottleneck is the fragility check after the change
;; related to the folded text. The functions used in `:fragile'
;; folding properties must be optimized. Also,
;; `org-fold-core-ignore-fragility-checks' or even `org-fold-core-ignore-modifications' may be
;; used when appropriate in the performance-critical code. When
;; inserting text from within `org-fold-core-ignore-modifications' macro, it is
;; recommended to use `insert-and-inherit' instead of `insert' and
;; `insert-before-markers-and-inherit' instead of
;; `insert-before-markers' to avoid revealing inserted text in the
;; middle of a folded region.
;; Performance of isearch is currently limited by Emacs isearch
;; implementation. For now, Emacs isearch only supports searching
;; through text hidden using overlays. This library handles isearch
;; by converting folds with matching text to overlays, which may
;; affect performance in case of large number of matches. In the
;; future, Emacs will hopefully accept the relevant patch allowing
;; isearch to work with text hidden via text properties, but the
;; performance hit has to be accepted meanwhile.
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'org-macs)
(require 'org-compat)
(declare-function isearch-filter-visible "isearch" (beg end))
;;; Customization
(defcustom org-fold-core-style (if (version< emacs-version "29")
'text-properties
'overlays)
"Internal implementation detail used to hide folded text.
Can be either `text-properties' or `overlays'.
The former is faster on large files in Emacs <29, while the latter is
generally less error-prone with regard to third-party packages.
Important: This variable must be set before loading Org."
:group 'org
:package-version '(Org . "9.7")
:type '(choice
(const :tag "Overlays" overlays)
(const :tag "Text properties" text-properties)))
(defvar-local org-fold-core-isearch-open-function #'org-fold-core--isearch-reveal
"Function used to reveal hidden text found by isearch.
The function is called with a single argument - point where text is to
be revealed.")
(defvar-local org-fold-core--optimise-for-huge-buffers nil
"Non-nil turns on extra speedup on huge buffers (Mbs of folded text).
This setting is risky and may cause various artifacts and degraded
functionality, especially when using external packages. It is
recommended to enable it on per-buffer basis as file-local variable.
When set to non-nil, must be a list containing one or multiple the
following symbols:
- `grab-invisible': Use `invisible' text property to hide text. This
will reduce the load on Emacs display engine and one may use it if
moving point across folded regions becomes slow. However, as a side
effect, some external packages extracting i.e. headlings from folded
parts of buffer may keep the text invisible.
- `ignore-fragility-checks': Do not try to detect when user edits
break structure of the folded elements. This will speed up
modifying the folded regions at the cost that some higher-level
functions relying on this package might not be able to unfold the
edited text. For example, removed leading stars from a folded
headline in Org mode will break visibility cycling since Org mode
will not be aware that the following folded text belonged to
headline.
- `ignore-modification-checks': Do not try to detect insertions in the
middle of the folded regions. This will speed up non-interactive
edits of the folded regions. However, text inserted in the middle
of the folded regions may become visible for some external packages
inserting text using `insert' instead of `insert-and-inherit' (the
latter is rarely used in practice).
- `ignore-indirect': Do not decouple folding state in the indirect
buffers. This can speed up Emacs display engine (and thus motion of
point), especially when large number of indirect buffers is being
used.
- `merge-folds': Do not distinguish between different types of folding
specs. This is the most aggressive optimization with unforeseen and
potentially drastic effects.")
(put 'org-fold-core--optimise-for-huge-buffers 'safe-local-variable 'listp)
;;; Core functionality
;;;; Folding specs
(defvar-local org-fold-core--specs '((org-fold-visible
(:visible . t)
(:alias . (visible)))
(org-fold-hidden
(:ellipsis . "...")
(:isearch-open . t)
(:alias . (hidden))))
"Folding specs defined in current buffer.
Each spec is a list (SPEC-SYMBOL SPEC-PROPERTIES).
SPEC-SYMBOL is the symbol representing the folding spec.
SPEC-PROPERTIES is an alist defining folding spec properties.
If a text region is folded using multiple specs, only the folding spec
listed earlier is used.
The following properties are known:
- :ellipsis :: must be nil or string to show when text is folded
using this spec.
- :global :: non-nil means that folding state will be preserved
when copying folded text between buffers.
- :isearch-ignore :: non-nil means that folded text is not searchable
using isearch.
- :isearch-open :: non-nil means that isearch can reveal text hidden
using this spec. This property does nothing
when `isearch-ignore' property is non-nil.
- :front-sticky :: non-nil means that text prepended to the folded text
is automatically folded.
- :rear-sticky :: non-nil means that text appended to the folded text
is folded.
- :visible :: non-nil means that folding spec visibility is not
managed. Instead, visibility settings in
`buffer-invisibility-spec' will be used as is.
Note that changing this property from nil to t may
clear the setting in `buffer-invisibility-spec'.
- :font-lock :: non-nil means that newlines after the fold should
be re-fontified upon folding/unfolding. See
`org-activate-folds'.
- :alias :: a list of aliases for the SPEC-SYMBOL.
- :fragile :: Must be a function accepting two arguments.
Non-nil means that changes in region may cause
the region to be revealed. The region is
revealed after changes if the function returns
non-nil.
The function called after changes are made with
two arguments: cons (beg . end) representing the
folded region and spec symbol.")
(defvar-local org-fold-core--spec-symbols nil
"Alist holding buffer spec symbols and aliases.
This variable is defined to reduce load on Emacs garbage collector
reducing the number of transiently allocated variables.")
(defvar-local org-fold-core--spec-list nil
"List holding buffer spec symbols, but not aliases.
This variable is defined to reduce load on Emacs garbage collector
reducing the number of transiently allocated variables.")
(defvar-local org-fold-core-extend-changed-region-functions nil
"Special hook run just before handling changes in buffer.
This is used to account changes outside folded regions that still
affect the folded region visibility. For example, removing all stars
at the beginning of a folded Org mode heading should trigger the
folded text to be revealed. Each function is called with two
arguments: beginning and the end of the changed region.")
;;; Utility functions
(defsubst org-fold-core-folding-spec-list (&optional buffer)
"Return list of all the folding spec symbols in BUFFER."
(or (buffer-local-value 'org-fold-core--spec-list (or buffer (current-buffer)))
(with-current-buffer (or buffer (current-buffer))
(setq org-fold-core--spec-list (mapcar #'car org-fold-core--specs)))))
(defun org-fold-core-get-folding-spec-from-alias (spec-or-alias)
"Return the folding spec symbol for SPEC-OR-ALIAS.
Return nil when there is no matching folding spec."
(when spec-or-alias
(unless org-fold-core--spec-symbols
(dolist (spec (org-fold-core-folding-spec-list))
(push (cons spec spec) org-fold-core--spec-symbols)
(dolist (alias (cdr (assq :alias (assq spec org-fold-core--specs))))
(push (cons alias spec) org-fold-core--spec-symbols))))
(alist-get spec-or-alias org-fold-core--spec-symbols)))
(defsubst org-fold-core-folding-spec-p (spec-or-alias)
"Check if SPEC-OR-ALIAS is a registered folding spec."
(org-fold-core-get-folding-spec-from-alias spec-or-alias))
(defsubst org-fold-core--check-spec (spec-or-alias)
"Throw an error if SPEC-OR-ALIAS is not in `org-fold-core-folding-spec-list'."
(unless (org-fold-core-folding-spec-p spec-or-alias)
(error "%s is not a valid folding spec" spec-or-alias)))
(defsubst org-fold-core-get-folding-spec-property (spec-or-alias property)
"Get PROPERTY of a folding SPEC-OR-ALIAS.
Possible properties can be found in `org-fold-core--specs' docstring."
(org-fold-core--check-spec spec-or-alias)
(if (and (memql 'ignore-indirect org-fold-core--optimise-for-huge-buffers)
(eq property :global))
t
(if (and (memql 'merge-folds org-fold-core--optimise-for-huge-buffers)
(eq property :visible))
nil
(cdr (assq property (assq (org-fold-core-get-folding-spec-from-alias spec-or-alias) org-fold-core--specs))))))
(defconst org-fold-core--spec-property-prefix "org-fold--spec-"
"Prefix used to create property symbol.")
(defsubst org-fold-core-get-folding-property-symbol (spec &optional buffer global)
"Get folding text property using to store SPEC in current buffer or BUFFER.
If GLOBAL is non-nil, do not make the property unique in the BUFFER."
(if (memql 'merge-folds org-fold-core--optimise-for-huge-buffers)
(intern (format "%s-global" org-fold-core--spec-property-prefix))
(intern (format (concat org-fold-core--spec-property-prefix "%s-%S")
(symbol-name spec)
;; (sxhash buf) appears to be not constant over time.
;; Using buffer-name is safe, since the only place where
;; buffer-local text property actually matters is an indirect
;; buffer, where the name cannot be same anyway.
(if (or global
(memql 'ignore-indirect org-fold-core--optimise-for-huge-buffers))
'global
(sxhash (buffer-name (or buffer (current-buffer)))))))))
(defsubst org-fold-core-get-folding-spec-from-folding-prop (folding-prop)
"Return folding spec symbol used for folding property with name FOLDING-PROP."
(catch :exit
(dolist (spec (org-fold-core-folding-spec-list))
;; We know that folding properties have
;; folding spec in their name.
(when (string-match-p (symbol-name spec)
(symbol-name folding-prop))
(throw :exit spec)))))
(defvar org-fold-core--property-symbol-cache (make-hash-table :test 'equal)
"Saved values of folding properties for (buffer . spec) conses.")
(defvar-local org-fold-core--indirect-buffers nil
"List of indirect buffers created from current buffer.
The first element of the list is always the current buffer.
This variable is needed to work around Emacs bug#46982, while Emacs
does not provide a way `after-change-functions' in any other buffer
than the buffer where the change was actually made.")
(defmacro org-fold-core-cycle-over-indirect-buffers (&rest body)
"Execute BODY in current buffer and all its indirect buffers.
Also, make sure that folding properties from killed buffers are not
hanging around."
(declare (debug (form body)) (indent 0))
`(let (buffers dead-properties)
(if (and (not (buffer-base-buffer))
(not (memq (current-buffer) org-fold-core--indirect-buffers)))
;; We are in base buffer with `org-fold-core--indirect-buffers' value from
;; different buffer. This can happen, for example, when
;; org-capture copies local variables into *Capture* buffer.
(setq buffers (list (current-buffer)))
(let ((all-buffers (buffer-local-value
'org-fold-core--indirect-buffers
(or (buffer-base-buffer) (current-buffer)))))
(dolist (buf (cons (or (buffer-base-buffer) (current-buffer))
(buffer-local-value 'org-fold-core--indirect-buffers (or (buffer-base-buffer) (current-buffer)))))
(if (buffer-live-p buf)
(push buf buffers)
(dolist (spec (org-fold-core-folding-spec-list))
(when (and (not (org-fold-core-get-folding-spec-property spec :global))
(gethash (cons buf spec) org-fold-core--property-symbol-cache))
;; Make sure that dead-properties variable can be passed
;; as argument to `remove-text-properties'.
(push t dead-properties)
(push (gethash (cons buf spec) org-fold-core--property-symbol-cache)
dead-properties)))))
(when dead-properties
(with-current-buffer (or (buffer-base-buffer) (current-buffer))
(setq-local org-fold-core--indirect-buffers
(seq-filter #'buffer-live-p all-buffers))))))
(dolist (buf buffers)
(with-current-buffer buf
(when dead-properties
(with-silent-modifications
(save-restriction
(widen)
(remove-text-properties
(point-min) (point-max)
dead-properties))))
,@body))))
;; This is the core function used to fold text in buffers. We use
;; text properties to hide folded text, however 'invisible property is
;; not directly used (unless risky `org-fold-core--optimise-for-huge-buffers' is
;; enabled). Instead, we define unique text property (folding
;; property) for every possible folding spec and add the resulting
;; text properties into `char-property-alias-alist', so that
;; 'invisible text property is automatically defined if any of the
;; folding properties is non-nil. This approach lets us maintain
;; multiple folds for the same text region - poor man's overlays (but
;; much faster). Additionally, folding properties are ensured to be
;; unique for different buffers (especially for indirect
;; buffers). This is done to allow different folding states in
;; indirect buffers.
(defun org-fold-core--property-symbol-get-create (spec &optional buffer return-only)
"Return a unique symbol suitable as folding text property.
Return value is unique for folding SPEC in BUFFER.
If the buffer already have buffer-local setup in `char-property-alias-alist'
and the setup appears to be created for different buffer,
copy the old invisibility state into new buffer-local text properties,
unless RETURN-ONLY is non-nil."
(if (eq org-fold-core-style 'overlays)
(or (gethash (cons 'global spec) org-fold-core--property-symbol-cache)
(puthash (cons 'global spec)
(org-fold-core-get-folding-property-symbol spec nil 'global)
org-fold-core--property-symbol-cache))
(let* ((buf (or buffer (current-buffer))))
;; Create unique property symbol for SPEC in BUFFER
(let ((local-prop (or (gethash (cons buf spec) org-fold-core--property-symbol-cache)
(puthash (cons buf spec)
(org-fold-core-get-folding-property-symbol
spec buf
(org-fold-core-get-folding-spec-property spec :global))
org-fold-core--property-symbol-cache))))
(prog1
local-prop
(unless return-only
(with-current-buffer buf
;; Update folding properties carried over from other
;; buffer (implying that current buffer is indirect
;; buffer). Normally, `char-property-alias-alist' in new
;; indirect buffer is a copy of the same variable from
;; the base buffer. Then, `char-property-alias-alist'
;; would contain folding properties, which are not
;; matching the generated `local-prop'.
(unless (member local-prop (cdr (assq 'invisible char-property-alias-alist)))
;; Copy all the old folding properties to preserve the folding state
(with-silent-modifications
(dolist (old-prop (cdr (assq 'invisible char-property-alias-alist)))
(org-with-wide-buffer
(let* ((pos (point-min))
(spec (org-fold-core-get-folding-spec-from-folding-prop old-prop))
;; Generate new buffer-unique folding property
(new-prop (when spec (org-fold-core--property-symbol-get-create spec nil 'return-only))))
;; Copy the visibility state for `spec' from `old-prop' to `new-prop'
(unless (eq old-prop new-prop)
(while (< pos (point-max))
(let ((val (get-text-property pos old-prop))
(next (next-single-char-property-change pos old-prop)))
(when val
(put-text-property pos next new-prop val))
(setq pos next)))))))
;; Update `char-property-alias-alist' with folding
;; properties unique for the current buffer.
(setq-local char-property-alias-alist
(cons (cons 'invisible
(mapcar (lambda (spec)
(org-fold-core--property-symbol-get-create spec nil 'return-only))
(org-fold-core-folding-spec-list)))
(remove (assq 'invisible char-property-alias-alist)
char-property-alias-alist)))
;; Set folding property stickiness according to
;; their `:font-sticky' and `:rear-sticky'
;; parameters.
(let (full-prop-list)
(org-fold-core-cycle-over-indirect-buffers
(setq full-prop-list
(append full-prop-list
(delq nil
(mapcar (lambda (spec)
(cond
((org-fold-core-get-folding-spec-property spec :front-sticky)
(cons (org-fold-core--property-symbol-get-create spec nil 'return-only)
nil))
((org-fold-core-get-folding-spec-property spec :rear-sticky)
nil)
(t
(cons (org-fold-core--property-symbol-get-create spec nil 'return-only)
t))))
(org-fold-core-folding-spec-list))))))
(org-fold-core-cycle-over-indirect-buffers
(setq-local text-property-default-nonsticky
(delete-dups (append
text-property-default-nonsticky
full-prop-list))))))))))))))
(defun org-fold-core--update-buffer-folds ()
"Copy folding state in a new buffer with text copied from old buffer."
(org-fold-core--property-symbol-get-create (car (org-fold-core-folding-spec-list))))
(defun org-fold-core-decouple-indirect-buffer-folds ()
"Copy and decouple folding state in a newly created indirect buffer.
This function is mostly intended to be used in
`clone-indirect-buffer-hook'."
;; Add current buffer to the list of indirect buffers in the base buffer.
(when (buffer-base-buffer)
(let ((new-buffer (current-buffer)))
(with-current-buffer (buffer-base-buffer)
(setq-local org-fold-core--indirect-buffers
(let (bufs)
(org-fold-core-cycle-over-indirect-buffers
(push (current-buffer) bufs))
(push new-buffer bufs)
(delete-dups bufs))))))
(when (and (buffer-base-buffer)
(eq org-fold-core-style 'text-properties)
(not (memql 'ignore-indirect org-fold-core--optimise-for-huge-buffers)))
(org-fold-core--update-buffer-folds)))
;;; API
;;;; Modifying folding specs
(defun org-fold-core-set-folding-spec-property (spec property value &optional force)
"Set PROPERTY of a folding SPEC to VALUE.
Possible properties and values can be found in `org-fold-core--specs' docstring.
Do not check previous value when FORCE is non-nil."
(pcase property
(:ellipsis
(unless (and (not force) (equal value (org-fold-core-get-folding-spec-property spec :ellipsis)))
(remove-from-invisibility-spec (cons spec (org-fold-core-get-folding-spec-property spec :ellipsis)))
(unless (org-fold-core-get-folding-spec-property spec :visible)
(add-to-invisibility-spec (cons spec value)))))
(:visible
(unless (or (memql 'merge-folds org-fold-core--optimise-for-huge-buffers)
(and (not force) (equal value (org-fold-core-get-folding-spec-property spec :visible))))
(if value
(remove-from-invisibility-spec (cons spec (org-fold-core-get-folding-spec-property spec :ellipsis)))
(add-to-invisibility-spec (cons spec (org-fold-core-get-folding-spec-property spec :ellipsis))))))
(:alias
;; Clear symbol cache.
(setq org-fold-core--spec-symbols nil))
(:isearch-open nil)
(:isearch-ignore nil)
(:front-sticky nil)
(:rear-sticky nil)
(_ nil))
(setf (cdr (assq property (assq spec org-fold-core--specs))) value))
(defun org-fold-core-add-folding-spec (spec &optional properties buffer append)
"Add a new folding SPEC with PROPERTIES in BUFFER.
SPEC must be a symbol. BUFFER can be a buffer to set SPEC in or nil to
set SPEC in current buffer.
By default, the added SPEC will have highest priority among the
previously defined specs. When optional APPEND argument is non-nil,
SPEC will have the lowest priority instead. If SPEC was already
defined earlier, it will be redefined according to provided optional
arguments.
`
The folding spec properties will be set to PROPERTIES (see
`org-fold-core--specs' for details)."
(when (eq spec 'all) (error "Cannot use reserved folding spec symbol 'all"))
(with-current-buffer (or buffer (current-buffer))
;; Clear the cache.
(setq org-fold-core--spec-list nil
org-fold-core--spec-symbols nil)
(let* ((full-properties (mapcar (lambda (prop) (cons prop (cdr (assq prop properties))))
'( :visible :ellipsis :isearch-ignore
:global :isearch-open :front-sticky
:rear-sticky :fragile :alias :font-lock)))
(full-spec (cons spec full-properties)))
(add-to-list 'org-fold-core--specs full-spec append)
(mapc (lambda (prop-cons) (org-fold-core-set-folding-spec-property spec (car prop-cons) (cdr prop-cons) 'force)) full-properties)
;; Update buffer inivisibility specs.
(org-fold-core--property-symbol-get-create spec))))
(defun org-fold-core-remove-folding-spec (spec &optional buffer)
"Remove a folding SPEC in BUFFER.
SPEC must be a symbol.
BUFFER can be a buffer to remove SPEC in, nil to remove SPEC in current
buffer, or `all' to remove SPEC in all open `org-mode' buffers and all
future org buffers."
(org-fold-core--check-spec spec)
(when (eq buffer 'all)
(setq-default org-fold-core--specs (delete (cdr (assq spec org-fold-core--specs)) org-fold-core--specs))
(mapc (lambda (buf)
(org-fold-core-remove-folding-spec spec buf))
(buffer-list)))
(let ((buffer (or buffer (current-buffer))))
(with-current-buffer buffer
;; Clear the cache.
(setq org-fold-core--spec-list nil
org-fold-core--spec-symbols nil)
(org-fold-core-set-folding-spec-property spec :visible t)
(setq org-fold-core--specs (delete (cdr (assq spec org-fold-core--specs)) org-fold-core--specs)))))
(defun org-fold-core-initialize (&optional specs)
"Setup folding in current buffer using SPECS as value of `org-fold-core--specs'."
;; Preserve the priorities.
(when specs (setq specs (nreverse specs)))
(unless specs (setq specs org-fold-core--specs))
(setq org-fold-core--specs nil
org-fold-core--spec-list nil
org-fold-core--spec-symbols nil)
(dolist (spec specs)
(org-fold-core-add-folding-spec (car spec) (cdr spec)))
(add-hook 'after-change-functions 'org-fold-core--fix-folded-region nil 'local)
(add-hook 'clone-indirect-buffer-hook #'org-fold-core-decouple-indirect-buffer-folds nil 'local)
;; Setup killing text
(setq-local filter-buffer-substring-function #'org-fold-core--buffer-substring-filter)
(if (and (boundp 'isearch-opened-regions)
(eq org-fold-core-style 'text-properties))
;; Use new implementation of isearch allowing to search inside text
;; hidden via text properties.
(org-fold-core--isearch-setup 'text-properties)
(org-fold-core--isearch-setup 'overlays)))
;;;; Searching and examining folded text
(defsubst org-fold-core-folded-p (&optional pos spec-or-alias)
"Non-nil if the character after POS is folded.
If POS is nil, use `point' instead.
If SPEC-OR-ALIAS is a folding spec or a list, only check the given
folding spec or the listed specs."
(if (and spec-or-alias (listp spec-or-alias))
(catch :found
(dolist (spec spec-or-alias)
(let ((val (org-fold-core-get-folding-spec spec pos)))
(when val (throw :found val)))))
(org-fold-core-get-folding-spec spec-or-alias pos)))
(defun org-fold-core-region-folded-p (beg end &optional spec-or-alias)
"Non-nil if the region between BEG and END is folded.
If SPEC-OR-ALIAS is a folding spec, only check the given folding spec."
(org-with-point-at beg
(catch :visible
(while (< (point) end)
(unless (org-fold-core-get-folding-spec spec-or-alias) (throw :visible nil))
(goto-char (org-fold-core-next-folding-state-change spec-or-alias nil end)))
t)))
(defun org-fold-core-get-folding-spec (&optional spec-or-alias pom)
"Get folding state at `point' or POM.
Return nil if there is no folding at point or POM.
If SPEC-OR-ALIAS is nil, return a folding spec with highest priority
among present at `point' or POM.
If SPEC-OR-ALIAS is `all', return the list of all present folding
specs.
If SPEC-OR-ALIAS is a valid folding spec or a spec alias, return the
corresponding folding spec (if the text is folded using that spec)."
(let ((spec (if (eq spec-or-alias 'all)
'all
(org-fold-core-get-folding-spec-from-alias spec-or-alias))))
(when (and spec (not (eq spec 'all))) (org-fold-core--check-spec spec))
(org-with-point-at pom
(cond
((or (null spec) (eq spec 'all))
(catch :single-spec
(let ((result))
(dolist (lspec (org-fold-core-folding-spec-list))
(let ((val (if (eq org-fold-core-style 'text-properties)
(get-text-property (point) (org-fold-core--property-symbol-get-create lspec nil t))
(get-char-property (point) (org-fold-core--property-symbol-get-create lspec nil t)))))
(when (and val (null spec)) (throw :single-spec val))
(when val (push val result))))
(reverse result))))
(t (if (eq org-fold-core-style 'text-properties)
(get-text-property (point) (org-fold-core--property-symbol-get-create spec nil t))
(get-char-property (point) (org-fold-core--property-symbol-get-create spec nil t))))))))
(defun org-fold-core-get-folding-specs-in-region (beg end)
"Get all folding specs in region from BEG to END."
(let ((pos beg)
all-specs)
(while (< pos end)
(setq all-specs (append all-specs (org-fold-core-get-folding-spec nil pos)))
(setq pos (org-fold-core-next-folding-state-change nil pos end)))
(unless (listp all-specs) (setq all-specs (list all-specs)))
(delete-dups all-specs)))
(defun org-fold-core-get-region-at-point (&optional spec-or-alias pom)
"Return region folded using SPEC-OR-ALIAS at POM.
If SPEC is nil, return the largest possible folded region.
The return value is a cons of beginning and the end of the region.
Return nil when no fold is present at point of POM."
(let ((spec (org-fold-core-get-folding-spec-from-alias spec-or-alias)))
(org-with-point-at (or pom (point))
(if spec
(if (eq org-fold-core-style 'text-properties)
(org-find-text-property-region (point) (org-fold-core--property-symbol-get-create spec nil t))
(let ((ov (cdr (get-char-property-and-overlay (point) (org-fold-core--property-symbol-get-create spec nil t)))))
(when ov (cons (overlay-start ov) (overlay-end ov)))))
(let ((region (cons (point) (point))))
(dolist (spec (org-fold-core-get-folding-spec 'all))
(let ((local-region (org-fold-core-get-region-at-point spec)))
(when (< (car local-region) (car region))
(setcar region (car local-region)))
(when (> (cdr local-region) (cdr region))
(setcdr region (cdr local-region)))))
(unless (eq (car region) (cdr region)) region))))))
(defun org-fold-core-next-visibility-change (&optional pos limit ignore-hidden-p previous-p)
"Return next point from POS up to LIMIT where text becomes visible/invisible.
By default, text hidden by any means (i.e. not only by folding, but
also via fontification) will be considered.
If IGNORE-HIDDEN-P is non-nil, consider only folded text.
If PREVIOUS-P is non-nil, search backwards."
(let* ((pos (or pos (point)))
(invisible-p (if ignore-hidden-p
#'org-fold-core-folded-p
#'invisible-p))
(invisible-initially? (funcall invisible-p pos))
(limit (or limit (if previous-p
(point-min)
(point-max))))
(cmp (if previous-p #'> #'<))
(next-change (if previous-p
(if ignore-hidden-p
(lambda (p) (org-fold-core-previous-folding-state-change (org-fold-core-get-folding-spec nil p) p limit))
(lambda (p) (max limit (previous-single-char-property-change p 'invisible nil limit))))
(if ignore-hidden-p
(lambda (p) (org-fold-core-next-folding-state-change (org-fold-core-get-folding-spec nil p) p limit))
(lambda (p) (next-single-char-property-change p 'invisible nil limit)))))
(next pos))
(while (and (funcall cmp next limit)
(not (org-xor
invisible-initially?
(funcall invisible-p
(if previous-p
;; NEXT-1 -> NEXT is the change.
(max limit (1- next))
;; NEXT -> NEXT+1 is the change.
next)))))
(setq next (funcall next-change next)))
next))
(defun org-fold-core-previous-visibility-change (&optional pos limit ignore-hidden-p)
"Call `org-fold-core-next-visibility-change' searching backwards."
(org-fold-core-next-visibility-change pos limit ignore-hidden-p 'previous))
(defun org-fold-core-next-folding-state-change (&optional spec-or-alias pos limit previous-p)
"Return point after POS where folding state changes up to LIMIT.
If SPEC-OR-ALIAS is nil, return next point where _any_ single folding
spec changes.
For example, (org-fold-core-next-folding-state-change nil) with point
somewhere in the below structure will return the nearest <...> point.
* Headline <begin outline fold>
:PROPERTIES:<begin drawer fold>
:ID: test
:END:<end drawer fold>
Fusce suscipit, wisi nec facilisis facilisis, est dui fermentum leo,
quis tempor ligula erat quis odio.
** Another headline
:DRAWER:<begin drawer fold>
:END:<end drawer fold>
** Yet another headline
<end of outline fold>
If SPEC-OR-ALIAS is a folding spec symbol, only consider that folding
spec.
If SPEC-OR-ALIAS is a list, only consider changes of folding specs
from the list.
Search backwards when PREVIOUS-P is non-nil."
(when (and spec-or-alias (symbolp spec-or-alias))
(setq spec-or-alias (list spec-or-alias)))
(when spec-or-alias
(setq spec-or-alias
(mapcar (lambda (spec-or-alias)
(or (org-fold-core-get-folding-spec-from-alias spec-or-alias)
spec-or-alias))
spec-or-alias))
(mapc #'org-fold-core--check-spec spec-or-alias))
(unless spec-or-alias
(setq spec-or-alias (org-fold-core-folding-spec-list)))
(setq pos (or pos (point)))
(let ((limit (or limit (if previous-p (point-min) (point-max)))))
(catch :limit
(dolist (prop (mapcar
(lambda (el)
(org-fold-core--property-symbol-get-create el nil t))
spec-or-alias))
(when (= limit pos) (throw :limit limit))
(setq
limit
(if previous-p
(previous-single-char-property-change pos prop nil limit)
(next-single-char-property-change pos prop nil limit))))
limit)))
(defun org-fold-core-previous-folding-state-change (&optional spec-or-alias pos limit)
"Call `org-fold-core-next-folding-state-change' searching backwards."
(org-fold-core-next-folding-state-change spec-or-alias pos limit 'previous))
(defun org-fold-core-search-forward (spec-or-alias &optional limit)
"Search next region folded via folding SPEC-OR-ALIAS up to LIMIT.
Move point right after the end of the region, to LIMIT, or
`point-max'. The `match-data' will contain the region."
(let ((spec (org-fold-core-get-folding-spec-from-alias spec-or-alias)))
(let ((prop-symbol (org-fold-core--property-symbol-get-create spec nil t)))
(goto-char (or (next-single-char-property-change (point) prop-symbol nil limit) limit (point-max)))
(when (and (< (point) (or limit (point-max)))
(not (org-fold-core-get-folding-spec spec)))
(goto-char (next-single-char-property-change (point) prop-symbol nil limit)))
(when (org-fold-core-get-folding-spec spec)
(let ((region (org-fold-core-get-region-at-point spec)))
(when (< (cdr region) (or limit (point-max)))
(goto-char (1+ (cdr region)))
(set-match-data (list (set-marker (make-marker) (car region) (current-buffer))
(set-marker (make-marker) (cdr region) (current-buffer))))))))))
(cl-defun org-fold-core-get-regions (&key specs from to with-markers relative)
"Find all the folded regions in current buffer.
Each element of the returned list represent folded region boundaries
and the folding spec: (BEG END SPEC).
Search folds intersecting with (FROM TO) buffer region if FROM and TO
are provided.
If FROM is non-nil and TO is nil, search the folded regions at FROM.
When both FROM and TO are nil, search folded regions in the whole buffer.
When SPECS is non-nil it should be a list of folding specs or a symbol.
Only return the matching fold types.
When WITH-MARKERS is non-nil, use markers to represent region
boundaries.
When RELATIVE is a buffer position, regions boundaries are given
relative to that position.
When RELATIVE is t, use FROM as the position.
WITH-MARKERS must be nil when RELATIVE is non-nil."
(when (and relative with-markers)
(error "Cannot use markers in non-absolute region boundaries"))
(when (eq relative t) (setq relative from))
(unless (listp specs) (setq specs (list specs)))
(let (regions region mk-region)
(org-with-wide-buffer
(when (and (not from) (not to))
(setq from (point-min)
to (point-max)))
(when (and from (not to)) (setq to (point-max)))
(when (and from (< from (point-min))) (setq from (point-min)))
(when (and to (> to (point-max))) (setq to (point-max)))
(unless from (setq from (point-min)))
(dolist (spec (or specs (org-fold-core-folding-spec-list)) regions)
(goto-char from)
(catch :exit
(while (or (not to) (< (point) to))
(when (org-fold-core-get-folding-spec spec)
(setq region (org-fold-core-get-region-at-point spec))
(when relative
(cl-decf (car region) relative)
(cl-decf (cdr region) relative))
(if (not with-markers)
(setq mk-region `(,(car region) ,(cdr region) ,spec))
(setq mk-region `(,(make-marker) ,(make-marker) ,spec))
(move-marker (nth 0 mk-region) (car region))
(move-marker (nth 1 mk-region) (cdr region)))
(push mk-region regions))
(unless to (throw :exit nil))
(goto-char (org-fold-core-next-folding-state-change spec nil to))))))))
;;;; Changing visibility
;;;;; Region visibility
(defvar org-fold-core--keep-overlays nil
"When non-nil, `org-fold-core-region' will not remove existing overlays.")
(defvar org-fold-core--isearch-overlays) ; defined below
(defmacro org-fold-core--keep-overlays (&rest body)
"Run BODY with `org-fold-core--keep-overlays' set to t."
(declare (debug (body)))
`(let ((org-fold-core--keep-overlays t))
,@body))
(defvar org-fold-core--isearch-active nil
"When non-nil, `org-fold-core-region' records created overlays.
New overlays will be added to `org-fold-core--isearch-overlays'.")
(defmacro org-fold-core--with-isearch-active (&rest body)
"Run BODY with `org-fold-core--isearch-active' set to t."
(declare (debug (body)))
`(let ((org-fold-core--isearch-active t))
,@body))
;; This is the core function performing actual folding/unfolding. The
;; folding state is stored in text property (folding property)
;; returned by `org-fold-core--property-symbol-get-create'. The value of the
;; folding property is folding spec symbol.
(defun org-fold-core-region (from to flag &optional spec-or-alias)
"Hide or show lines from FROM to TO, according to FLAG.
SPEC-OR-ALIAS is the folding spec or foldable element, as a symbol.
If SPEC-OR-ALIAS is omitted and FLAG is nil, unfold everything in the region."
(let ((spec (org-fold-core-get-folding-spec-from-alias spec-or-alias)))
(when spec (org-fold-core--check-spec spec))
(with-silent-modifications
(org-with-wide-buffer
;; Arrange fontifying newlines after all the folds between FROM
;; and TO to match the first character before the fold; not the
;; last as per Emacs defaults. This makes :extend faces span
;; past the ellipsis. See bug#65896. The face properties are
;; assigned via `org-activate-folds'.
(when (or (not spec) (org-fold-core-get-folding-spec-property spec :font-lock))
(when (equal ?\n (char-after from))
(font-lock-flush from (1+ from)))
(when (equal ?\n (char-after to))
(font-lock-flush to (1+ to)))
(dolist (region (org-fold-core-get-regions :from from :to to :specs spec))
(when (equal ?\n (char-after (cadr region)))
(font-lock-flush (cadr region) (1+ (cadr region))))
;; Re-fontify beginning of the fold - we may
;; unfold inside an existing fold, with FROM begin a newline
;; after spliced fold.
(when (equal ?\n (char-after (car region)))
(font-lock-flush (car region) (1+ (car region))))))
(when (eq org-fold-core-style 'overlays)
(if org-fold-core--keep-overlays
(mapc
(lambda (ov)
(when (or (not spec)
(eq spec (overlay-get ov 'invisible)))
(when (and org-fold-core--isearch-active
(overlay-get ov 'invisible)
(org-fold-core-get-folding-spec-property
(overlay-get ov 'invisible) :isearch-open))
(when-let* ((spec (overlay-get ov 'invisible)))
(overlay-put ov 'org-invisible spec)
(overlay-put ov (org-fold-core--property-symbol-get-create spec) nil))
(overlay-put ov 'invisible nil)
(when org-fold-core--isearch-active
(cl-pushnew ov org-fold-core--isearch-overlays)))))
(overlays-in from to))
(when spec
(remove-overlays from to 'org-invisible spec)
(remove-overlays from to 'invisible spec))))
(if flag
(if (not spec)
(error "Calling `org-fold-core-region' with missing SPEC")
(if (eq org-fold-core-style 'overlays)
;; Use `front-advance' since text right before to the beginning of
;; the overlay belongs to the visible line than to the contents.
(let ((o (make-overlay from to nil
(org-fold-core-get-folding-spec-property spec :front-sticky)
(org-fold-core-get-folding-spec-property spec :rear-sticky))))
(when org-fold-core--isearch-active
(push o org-fold-core--isearch-overlays))
(overlay-put o 'evaporate t)
(overlay-put o (org-fold-core--property-symbol-get-create spec) spec)
(overlay-put o 'invisible spec)
;; Preserve priority.
(overlay-put o 'priority (length (member spec (org-fold-core-folding-spec-list))))
(overlay-put o 'isearch-open-invisible #'org-fold-core--isearch-show))
(put-text-property from to (org-fold-core--property-symbol-get-create spec) spec)
(put-text-property from to 'isearch-open-invisible #'org-fold-core--isearch-show)
(put-text-property from to 'isearch-open-invisible-temporary #'org-fold-core--isearch-show-temporary)
(when (memql 'grab-invisible org-fold-core--optimise-for-huge-buffers)
;; If the SPEC has highest priority, assign it directly
;; to 'invisible property as well. This is done to speed
;; up Emacs redisplay on huge (Mbs) folded regions where
;; we don't even want Emacs to spend time cycling over
;; `char-property-alias-alist'.
(when (eq spec (caar org-fold-core--specs)) (put-text-property from to 'invisible spec)))))
(if (not spec)
(mapc (lambda (spec) (org-fold-core-region from to nil spec)) (org-fold-core-folding-spec-list))
(when (and (memql 'grab-invisible org-fold-core--optimise-for-huge-buffers)
(eq org-fold-core-style 'text-properties))
(when (eq spec (caar org-fold-core--specs))
(let ((pos from))
(while (< pos to)
(if (eq spec (get-text-property pos 'invisible))
(let ((next (org-fold-core-next-folding-state-change spec pos to)))
(remove-text-properties pos next '(invisible t))
(setq pos next))
(setq pos (next-single-char-property-change pos 'invisible nil to)))))))
(when (eq org-fold-core-style 'text-properties)
(remove-text-properties from to (list (org-fold-core--property-symbol-get-create spec) nil)))))
;; Re-calculate trailing faces for all the folds revealed
;; by unfolding or created by folding.
(when (or (not spec) (org-fold-core-get-folding-spec-property spec :font-lock))
(dolist (region (org-fold-core-get-regions :from from :to to :specs spec))
(when (equal ?\n (char-after (cadr region)))
(font-lock-flush (cadr region) (1+ (cadr region))))))))))
(cl-defmacro org-fold-core-regions (regions &key override clean-markers relative)
"Fold every region in REGIONS list in current buffer.
Each region in the list is a list (BEG END SPEC-OR-ALIAS) describing
region and folding spec to be applied.
When optional argument OVERRIDE is non-nil, clear folding state in the
buffer first.
When optional argument CLEAN-MARKERS is non-nil, clear markers used to
mark region boundaries in REGIONS.
When optional argument RELATIVE is non-nil, it must be a buffer
position. REGION boundaries are then treated as relative distances
from that position."
`(org-with-wide-buffer
(when ,override (org-fold-core-region (point-min) (point-max) nil))
(pcase-dolist (`(,beg ,end ,spec) (delq nil ,regions))
(let ((rel ,relative))
(if rel
(org-fold-core-region (+ rel beg) (+ rel end) t spec)
(org-fold-core-region beg end t spec)))
(when ,clean-markers
(when (markerp beg) (set-marker beg nil))
(when (markerp end) (set-marker end nil))))))
(defmacro org-fold-core-save-visibility (use-markers &rest body)
"Save and restore folding state around BODY.
If USE-MARKERS is non-nil, use markers for the positions. This
means that the buffer may change while running BODY, but it also
means that the buffer should stay alive during the operation,
because otherwise all these markers will point to nowhere."
(declare (debug (form body)) (indent 1))
(org-with-gensyms (regions)
`(let* ((,regions (org-fold-core-get-regions :with-markers ,use-markers)))
(unwind-protect (progn ,@body)
(org-fold-core-regions ,regions :override t :clean-markers t)))))
;;; Make isearch search in some text hidden via text propertoes
(defvar org-fold-core--isearch-overlays nil
"List of overlays temporarily created during isearch.
This is used to allow searching in regions hidden via text properties.
As for [2020-05-09 Sat], Isearch only has special handling of hidden overlays.
Any text hidden via text properties is not revealed even if `search-invisible'
is set to t.")
(defvar-local org-fold-core--isearch-local-regions (make-hash-table :test 'equal)
"Hash table storing temporarily shown folds from isearch matches.")
(defun org-fold-core--isearch-setup (type)
"Initialize isearch in org buffer.
TYPE can be either `text-properties' or `overlays'."
(pcase type
(`text-properties
(setq-local search-invisible 'open-all)
(add-hook 'isearch-mode-end-hook #'org-fold-core--clear-isearch-state nil 'local)
(add-hook 'isearch-mode-hook #'org-fold-core--clear-isearch-state nil 'local)
(setq-local isearch-filter-predicate #'org-fold-core--isearch-filter-predicate-text-properties))
(`overlays
(when (eq org-fold-core-style 'text-properties)
(add-function :before (local 'isearch-filter-predicate) #'org-fold-core--create-isearch-overlays)
;; When `isearch-filter-predicate' is called outside isearch,
;; it is common that `isearch-mode-end-hook' does not get
;; executed, but `isearch-clean-overlays' usually does.
(advice-add
'isearch-clean-overlays :after
#'org-fold-core--clear-isearch-overlays
'((name . isearch-clean-overlays@org-fold-core)))))
(_ (error "%s: Unknown type of setup for `org-fold-core--isearch-setup'" type))))
(defun org-fold-core--isearch-reveal (pos)
"Default function used to reveal hidden text at POS for isearch."
(let ((region (org-fold-core-get-region-at-point nil pos)))
(org-fold-core-region (car region) (cdr region) nil)))
(defun org-fold-core--isearch-filter-predicate-text-properties (beg end)
"Make sure that folded text is searchable when user want so.
This function is intended to be used as `isearch-filter-predicate'."
(and
;; Check folding specs that cannot be searched
(not (memq nil (mapcar (lambda (spec) (not (org-fold-core-get-folding-spec-property spec :isearch-ignore)))
(org-fold-core-get-folding-specs-in-region beg end))))
;; Check 'invisible properties that are not folding specs.
(or (eq search-invisible t) ; User wants to search anyway, allow it.
(let ((pos beg)
unknown-invisible-property)
(while (and (< pos end)
(not unknown-invisible-property))
(when (and (get-text-property pos 'invisible)
(not (org-fold-core-folding-spec-p (get-text-property pos 'invisible))))
(setq unknown-invisible-property t))
(setq pos (next-single-char-property-change pos 'invisible)))
(not unknown-invisible-property)))
(or (and (eq search-invisible t)
;; FIXME: this opens regions permanenly for now.
;; I also tried to force search-invisible 'open-all around
;; `isearch-range-invisible', but that somehow causes
;; infinite loop in `isearch-lazy-highlight'.
(prog1 t
;; We still need to reveal the folded location
(org-fold-core--isearch-show-temporary (cons beg end) nil)))
(not (isearch-range-invisible beg end)))))
(defun org-fold-core--clear-isearch-state ()
"Clear `org-fold-core--isearch-local-regions'."
(clrhash org-fold-core--isearch-local-regions))
(defun org-fold-core--isearch-show (overlay-or-region)
"Reveal text at OVERLAY-OR-REGION found by isearch."
(let (beg end)
(if (overlayp overlay-or-region)
(setq beg (overlay-start overlay-or-region)
end (overlay-end overlay-or-region))
(setq beg (car overlay-or-region)
end (cdr overlay-or-region)))
;; FIXME: Reveal the match (usually point, but may sometimes go beyond the region).
(when (< beg (point) end)
(funcall org-fold-core-isearch-open-function (point)))
(if (overlayp overlay-or-region)
(delete-overlay overlay-or-region)
(org-fold-core-region beg end nil))))
(defun org-fold-core--isearch-show-temporary (region hide-p)
"Temporarily reveal text in REGION.
Hide text instead if HIDE-P is non-nil.
REGION can also be an overlay in current buffer."
(save-match-data ; match data must not be modified.
(let ((org-fold-core-style (if (overlayp region) 'overlays 'text-properties)))
(if hide-p
(if (not (overlayp region))
nil ;; FIXME: after isearch supports text properties.
(when-let* ((spec (overlay-get region 'org-invisible)))
(overlay-put region 'invisible spec)
(overlay-put region (org-fold-core--property-symbol-get-create spec) spec)))
;; isearch expects all the temporarily opened overlays to exist.
;; See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=60399
(org-fold-core--keep-overlays
(org-fold-core--with-isearch-active
(org-fold-core--isearch-show region)))))))
(defvar-local org-fold-core--isearch-special-specs nil
"List of specs that can break visibility state when converted to overlays.
This is a hack, but I do not see a better way around until isearch
gets support of text properties.")
(defun org-fold-core--create-isearch-overlays (beg end)
"Replace text property invisibility spec by overlays between BEG and END.
All the searchable folded regions will be changed to use overlays
instead of text properties. The created overlays will be stored in
`org-fold-core--isearch-overlays'."
(let ((pos beg))
(while (< pos end)
;; We need loop below to make sure that we clean all invisible
;; properties, which may be nested.
(catch :repeat
(dolist (spec (org-fold-core-get-folding-spec 'all pos))
(unless (org-fold-core-get-folding-spec-property spec :isearch-ignore)
(let* ((region (org-fold-core-get-region-at-point spec pos)))
(when (memq spec org-fold-core--isearch-special-specs)
(setq end (max end (cdr region)))
(when (< (car region) beg)
(setq beg (car region))
(setq pos beg)
(throw :repeat t)))
;; Changing text properties is considered buffer modification.
;; We do not want it here.
(with-silent-modifications
(org-fold-core-region (car region) (cdr region) nil spec)
(let ((org-fold-core-style 'overlays))
(org-fold-core--with-isearch-active
(org-fold-core-region (car region) (cdr region) t spec)))))))
(setq pos (org-fold-core-next-folding-state-change nil pos end))))))
(defun org-fold-core--clear-isearch-overlay (ov)
"Convert OV region back into using text properties."
(let ((spec (overlay-get ov 'invisible)))
;; Ignore deleted overlays.
(when (and spec
(overlay-buffer ov))
;; Changing text properties is considered buffer modification.
;; We do not want it here.
(with-silent-modifications
(when (<= (overlay-end ov) (point-max))
(org-fold-core-region (overlay-start ov) (overlay-end ov) t spec)))))
(delete-overlay ov))
(defun org-fold-core--clear-isearch-overlays ()
"Convert overlays from `org-fold-core--isearch-overlays' back to text properties."
(when org-fold-core--isearch-overlays
(mapc #'org-fold-core--clear-isearch-overlay org-fold-core--isearch-overlays)
(setq org-fold-core--isearch-overlays nil)))
;;; Handling changes in folded elements
(defvar org-fold-core--ignore-modifications nil
"Non-nil: skip processing modifications in `org-fold-core--fix-folded-region'.")
(defvar org-fold-core--ignore-fragility-checks nil
"Non-nil: skip fragility checks in `org-fold-core--fix-folded-region'.")
(defvar org-fold-core--suppress-folding-fix nil
"Non-nil: skip folding fix in `org-fold-core--fix-folded-region'.")
(defmacro org-fold-core-ignore-modifications (&rest body)
"Run BODY ignoring buffer modifications in `org-fold-core--fix-folded-region'."
(declare (debug (form body)) (indent 0))
`(let ((org-fold-core--ignore-modifications t))
(unwind-protect (progn ,@body)
(setq org-fold-core--last-buffer-chars-modified-tick (buffer-chars-modified-tick)))))
(defmacro org-fold-core-suppress-folding-fix (&rest body)
"Run BODY skipping re-folding checks in `org-fold-core--fix-folded-region'."
(declare (debug (form body)) (indent 0))
`(let ((org-fold-core--suppress-folding-fix t))
(progn ,@body)))
(defmacro org-fold-core-ignore-fragility-checks (&rest body)
"Run BODY skipping :fragility checks in `org-fold-core--fix-folded-region'."
(declare (debug (form body)) (indent 0))
`(let ((org-fold-core--ignore-fragility-checks t))
(progn ,@body)))
(defvar org-fold-core--region-delayed-list nil
"List holding (MKFROM MKTO FLAG SPEC-OR-ALIAS) arguments to process.
The list is used by `org-fold-core--region-delayed'.")
(defun org-fold-core--region-delayed (from to flag &optional spec-or-alias)
"Call `org-fold-core-region' after current command.
Pass the same FROM, TO, FLAG, and SPEC-OR-ALIAS."
;; Setup delayed folding.
(add-hook 'post-command-hook #'org-fold-core--process-delayed)
(let ((frommk (make-marker))
(tomk (make-marker)))
(set-marker frommk from (current-buffer))
(set-marker tomk to (current-buffer))
(push (list frommk tomk flag spec-or-alias) org-fold-core--region-delayed-list)))
(defun org-fold-core--process-delayed ()
"Perform folding for `org-fold-core--region-delayed-list'."
(when org-fold-core--region-delayed-list
(mapc (lambda (args)
(when (and (buffer-live-p (marker-buffer (nth 0 args)))
(buffer-live-p (marker-buffer (nth 1 args)))
(< (nth 0 args) (nth 1 args)))
(org-with-point-at (car args)
(apply #'org-fold-core-region args))))
;; Restore the initial folding order.
(nreverse org-fold-core--region-delayed-list))
;; Cleanup `post-command-hook'.
(remove-hook 'post-command-hook #'org-fold-core--process-delayed)
(setq org-fold-core--region-delayed-list nil)))
(defvar-local org-fold-core--last-buffer-chars-modified-tick nil
"Variable storing the last return value of `buffer-chars-modified-tick'.")
(defun org-fold-core--fix-folded-region (from to _)
"Process modifications in folded elements within FROM . TO region.
This function intended to be used as one of `after-change-functions'.
This function does nothing if text the only modification was changing
text properties (for the sake of reducing overheads).
If a text was inserted into invisible region, hide the inserted text.
If a text was inserted in front/back of the region, hide it according
to :front-sticky/:rear-sticky folding spec property.
If the folded region is folded with a spec with non-nil :fragile
property, unfold the region if the :fragile function returns non-nil."
;; If no insertions or deletions in buffer, skip all the checks.
(unless (or org-fold-core--ignore-modifications
(eq org-fold-core--last-buffer-chars-modified-tick (buffer-chars-modified-tick))
(memql 'ignore-modification-checks org-fold-core--optimise-for-huge-buffers))
;; Store the new buffer modification state.
(setq org-fold-core--last-buffer-chars-modified-tick (buffer-chars-modified-tick))
(save-match-data
;; Handle changes in all the indirect buffers and in the base
;; buffer. Work around Emacs bug#46982.
;; Re-hide text inserted in the middle/front/back of a folded
;; region.
(unless (or org-fold-core--suppress-folding-fix (equal from to)) ; Ignore deletions.
(when (eq org-fold-core-style 'text-properties)
(org-fold-core-cycle-over-indirect-buffers
(dolist (spec (org-fold-core-folding-spec-list))
;; Reveal fully invisible text inserted in the middle
;; of visible portion of the buffer. This is needed,
;; for example, when there was a deletion in a folded
;; heading, the heading was unfolded, end `undo' was
;; called. The `undo' would insert the folded text.
(when (and (or (eq from (point-min))
(not (org-fold-core-folded-p (1- from) spec)))
(or (eq to (point-max))
(not (org-fold-core-folded-p to spec)))
(org-fold-core-region-folded-p from to spec))
(org-fold-core-region from to nil spec))
;; Look around and fold the new text if the nearby folds are
;; sticky.
(unless (org-fold-core-region-folded-p from to spec)
(let ((spec-to (org-fold-core-get-folding-spec spec (min to (1- (point-max)))))
(spec-from (org-fold-core-get-folding-spec spec (max (point-min) (1- from)))))
;; Reveal folds around undone deletion.
(when undo-in-progress
(let ((lregion (org-fold-core-get-region-at-point spec (max (point-min) (1- from))))
(rregion (org-fold-core-get-region-at-point spec (min to (1- (point-max))))))
(if (and lregion rregion)
(org-fold-core-region (car lregion) (cdr rregion) nil spec)
(when lregion
(org-fold-core-region (car lregion) (cdr lregion) nil spec))
(when rregion
(org-fold-core-region (car rregion) (cdr rregion) nil spec)))))
;; Hide text inserted in the middle of a fold.
(when (and (or spec-from (eq from (point-min)))
(or spec-to (eq to (point-max)))
(or spec-from spec-to)
(eq spec-to spec-from)
(or (org-fold-core-get-folding-spec-property spec :front-sticky)
(org-fold-core-get-folding-spec-property spec :rear-sticky)))
(unless (and (eq from (point-min)) (eq to (point-max))) ; Buffer content replaced.
(org-fold-core-region from to t (or spec-from spec-to))))
;; Hide text inserted at the end of a fold.
(when (and spec-from (org-fold-core-get-folding-spec-property spec-from :rear-sticky))
(org-fold-core-region from to t spec-from))
;; Hide text inserted in front of a fold.
(when (and spec-to
(not (eq to (point-max))) ; Text inserted at the end of buffer is not prepended anywhere.
(org-fold-core-get-folding-spec-property spec-to :front-sticky))
(org-fold-core-region from to t spec-to))))))))
;; Process all the folded text between `from' and `to'. Do it
;; only in current buffer to avoid verifying semantic structure
;; multiple times in indirect buffers that have exactly same
;; text anyway.
(unless (or org-fold-core--ignore-fragility-checks
(memql 'ignore-fragility-checks org-fold-core--optimise-for-huge-buffers))
(dolist (func org-fold-core-extend-changed-region-functions)
(let ((new-region (funcall func from to)))
(setq from (car new-region))
(setq to (cdr new-region))))
(org-fold-core-cycle-over-indirect-buffers
(dolist (spec (org-fold-core-folding-spec-list))
;; No action is needed when :fragile is nil for the spec.
(when (org-fold-core-get-folding-spec-property spec :fragile)
(org-with-wide-buffer
;; Expand the considered region to include partially present fold.
;; Note: It is important to do this inside loop over all
;; specs. Otherwise, the region may be expanded to huge
;; outline fold, potentially involving majority of the
;; buffer. That would cause the below code to loop over
;; almost all the folds in buffer, which would be too slow.
(let ((local-from from)
(local-to to)
(region-from (org-fold-core-get-region-at-point spec (max (point-min) (1- from))))
(region-to (org-fold-core-get-region-at-point spec (min to (1- (point-max))))))
(when region-from (setq local-from (car region-from)))
(when region-to (setq local-to (cdr region-to)))
(let ((pos local-from))
;; Move to the first hidden region.
(unless (org-fold-core-get-folding-spec spec pos)
(setq pos (org-fold-core-next-folding-state-change spec pos local-to)))
;; Cycle over all the folds.
(while (< pos local-to)
(save-match-data ; we should not clobber match-data in after-change-functions
(let ((fold-begin (and (org-fold-core-get-folding-spec spec pos)
pos))
(fold-end (org-fold-core-next-folding-state-change spec pos local-to)))
(when (and fold-begin fold-end)
(when (save-excursion
(funcall (org-fold-core-get-folding-spec-property spec :fragile)
(cons fold-begin fold-end)
spec))
;; Reveal completely, not just from the SPEC.
;; Do it only after command is finished -
;; some Emacs commands assume that
;; visibility is not altered by `after-change-functions'.
(org-fold-core--region-delayed fold-begin fold-end nil)))))
;; Move to next fold.
(setq pos (org-fold-core-next-folding-state-change spec pos local-to)))))))))))))
;;; Handling killing/yanking of folded text
;; By default, all the text properties of the killed text are
;; preserved, including the folding text properties. This can be
;; awkward when we copy a text from an indirect buffer to another
;; indirect buffer (or the base buffer). The copied text might be
;; visible in the source buffer, but might disappear if we yank it in
;; another buffer. This happens in the following situation:
;; ---- base buffer ----
;; * Headline<begin fold>
;; Some text hidden in the base buffer, but revealed in the indirect
;; buffer.<end fold>
;; * Another headline
;;
;; ---- end of base buffer ----
;; ---- indirect buffer ----
;; * Headline
;; Some text hidden in the base buffer, but revealed in the indirect
;; buffer.
;; * Another headline
;;
;; ---- end of indirect buffer ----
;; If we copy the text under "Headline" from the indirect buffer and
;; insert it under "Another headline" in the base buffer, the inserted
;; text will be hidden since it's folding text properties are copied.
;; Basically, the copied text would have two sets of folding text
;; properties: (1) Properties for base buffer telling that the text is
;; hidden; (2) Properties for the indirect buffer telling that the
;; text is visible. The first set of the text properties in inactive
;; in the indirect buffer, but will become active once we yank the
;; text back into the base buffer.
;;
;; To avoid the above situation, we simply clear all the properties,
;; unrealated to current buffer when a text is copied.
;; FIXME: Ideally, we may want to carry the folding state of copied
;; text between buffer (probably via user customization).
(defun org-fold-core--buffer-substring-filter (beg end &optional delete)
"Clear folding state in killed text.
This function is intended to be used as `filter-buffer-substring-function'.
The arguments and return value are as specified for `filter-buffer-substring'."
(let ((return-string (buffer-substring--filter beg end delete))
;; The list will be used as an argument to `remove-text-properties'.
props-list)
;; There is no easy way to examine all the text properties of a
;; string, so we utilize the fact that printed string
;; representation lists all its properties.
;; Loop over the elements of string representation.
(unless (or (string= "" return-string)
(<= end beg)
(eq org-fold-core-style 'overlays))
;; Collect all the text properties the string is completely
;; hidden with.
(dolist (spec (org-fold-core-folding-spec-list))
(when (and (org-fold-core-region-folded-p beg end spec)
(org-region-invisible-p beg end))
(push (org-fold-core--property-symbol-get-create spec nil t) props-list)))
(dolist (plist
(if (fboundp 'object-intervals)
(object-intervals return-string)
;; Backward compatibility with Emacs <28.
;; FIXME: Is there any better way to do it?
;; Yes, it is a hack.
;; The below gives us string representation as a list.
;; Note that we need to remove unreadable values, like markers (#<...>).
(seq-partition
(cdr (let ((data (read (replace-regexp-in-string
"^#(" "("
(replace-regexp-in-string
" #(" " ("
(replace-regexp-in-string
"#<[^>]+>" "dummy"
;; Get text representation of the string object.
;; Make sure to print everything (see `prin1' docstring).
;; `prin1' is used to print "%S" format.
(let (print-level print-length)
(format "%S" return-string))))))))
(if (listp data) data (list data))))
3)))
(let* ((start (car plist))
(fin (cadr plist))
(plist (car (cddr plist))))
;; Only lists contain text properties.
(when (listp plist)
;; Collect all the relevant text properties.
(while plist
(let* ((prop (car plist))
(prop-name (symbol-name prop)))
;; Reveal hard-hidden text. See
;; `org-fold-core--optimise-for-huge-buffers'.
(when (and (eq prop 'invisible)
(member (cadr plist) (org-fold-core-folding-spec-list)))
(remove-text-properties start fin '(invisible t) return-string))
;; We do not care about values now.
(setq plist (cddr plist))
(when (string-match-p org-fold-core--spec-property-prefix prop-name)
;; Leave folding specs from current buffer. See
;; comments in `org-fold-core--property-symbol-get-create' to
;; understand why it works.
(unless (member prop (cdr (assq 'invisible char-property-alias-alist)))
(push prop props-list))))))))
(remove-text-properties 0 (length return-string) props-list return-string))
return-string))
(defun org-fold-core-update-optimisation (beg end)
"Update huge buffer optimization between BEG and END.
See `org-fold-core--optimise-for-huge-buffers'."
(when (and (memql 'grab-invisible org-fold-core--optimise-for-huge-buffers)
(eq org-fold-core-style 'text-properties))
(let ((pos beg))
(while (< pos end)
(when (and (org-fold-core-folded-p pos (caar org-fold-core--specs))
(not (eq (caar org-fold-core--specs) (get-text-property pos 'invisible))))
(put-text-property pos (org-fold-core-next-folding-state-change (caar org-fold-core--specs) pos end)
'invisible (caar org-fold-core--specs)))
(setq pos (org-fold-core-next-folding-state-change (caar org-fold-core--specs) pos end))))))
(defun org-fold-core-remove-optimisation (beg end)
"Remove huge buffer optimization between BEG and END.
See `org-fold-core--optimise-for-huge-buffers'."
(when (and (memql 'grab-invisible org-fold-core--optimise-for-huge-buffers)
(eq org-fold-core-style 'text-properties))
(let ((pos beg))
(while (< pos end)
(if (and (org-fold-core-folded-p pos (caar org-fold-core--specs))
(eq (caar org-fold-core--specs) (get-text-property pos 'invisible)))
(remove-text-properties pos (org-fold-core-next-folding-state-change (caar org-fold-core--specs) pos end)
'(invisible t)))
(setq pos (org-fold-core-next-folding-state-change (caar org-fold-core--specs) pos end))))))
(provide 'org-fold-core)
;;; org-fold-core.el ends here
org-mode-9.7.29+dfsg/lisp/org-fold.el 0000664 0000000 0000000 00000113067 15004304337 0017263 0 ustar 00root root 0000000 0000000 ;;; org-fold.el --- Folding of Org entries -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2020-2025 Free Software Foundation, Inc.
;;
;; Author: Ihor Radchenko <yantar92 at posteo dot net>
;; Maintainer: Ihor Radchenko <yantar92 at posteo dot net>
;; Keywords: folding, invisible text
;; URL: https://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 <https://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;; This file contains code handling temporary invisibility (folding
;; and unfolding) of text in org buffers.
;; The folding is implemented using generic org-fold-core library. This file
;; contains org-specific implementation of the folding. Also, various
;; useful functions from org-fold-core are aliased under shorted `org-fold'
;; prefix.
;; The following features are implemented:
;; - Folding/unfolding various Org mode elements and regions of Org buffers:
;; + Region before first heading;
;; + Org headings, their text, children (subtree), siblings, parents, etc;
;; + Org blocks and drawers
;; - Revealing Org structure around invisible point location
;; - Revealing folded Org elements broken by user edits
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'org-macs)
(require 'org-fold-core)
(defvar org-inlinetask-min-level)
(defvar org-odd-levels-only)
(defvar org-drawer-regexp)
(defvar org-property-end-re)
(defvar org-link-descriptive)
(defvar org-outline-regexp-bol)
(defvar org-archive-tag)
(defvar org-custom-properties-overlays)
(defvar org-element-headline-re)
(declare-function isearch-filter-visible "isearch" (beg end))
(declare-function org-element-type "org-element-ast" (node &optional anonymous))
(declare-function org-element-at-point "org-element" (&optional pom cached-only))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-end "org-element" (node))
(declare-function org-element-post-affiliated "org-element" (node))
(declare-function org-element--current-element "org-element" (limit &optional granularity mode structure))
(declare-function org-toggle-custom-properties-visibility "org" ())
(declare-function org-item-re "org-list" ())
(declare-function org-up-heading-safe "org" ())
(declare-function org-get-tags "org" (&optional pos local fontify))
(declare-function org-get-valid-level "org" (level &optional change))
(declare-function org-before-first-heading-p "org" ())
(declare-function org-goto-sibling "org" (&optional previous))
(declare-function org-block-map "org" (function &optional start end))
(declare-function org-map-region "org" (fun beg end))
(declare-function org-end-of-subtree "org" (&optional invisible-ok to-heading))
(declare-function org-back-to-heading-or-point-min "org" (&optional invisible-ok))
(declare-function org-back-to-heading "org" (&optional invisible-ok))
(declare-function org-at-heading-p "org" (&optional invisible-not-ok))
(declare-function org-cycle-hide-drawers "org-cycle" (state))
(declare-function outline-show-branches "outline" ())
(declare-function outline-hide-sublevels "outline" (levels))
(declare-function outline-get-next-sibling "outline" ())
(declare-function outline-invisible-p "outline" (&optional pos))
(declare-function outline-next-heading "outline" ())
;;; Customization
(defgroup org-fold-reveal-location nil
"Options about how to make context of a location visible."
:tag "Org Reveal Location"
:group 'org-structure)
(defcustom org-fold-show-context-detail '((agenda . local)
(bookmark-jump . lineage)
(isearch . lineage)
(default . ancestors))
"Alist between context and visibility span when revealing a location.
\\<org-mode-map>Some actions may move point into invisible
locations. As a consequence, Org always exposes a neighborhood
around point. How much is shown depends on the initial action,
or context. Valid contexts are
agenda when exposing an entry from the agenda
org-goto when using the command `org-goto' (`\\[org-goto]')
occur-tree when using the command `org-occur' (`\\[org-sparse-tree] /')
tags-tree when constructing a sparse tree based on tags matches
link-search when exposing search matches associated with a link
mark-goto when exposing the jump goal of a mark
bookmark-jump when exposing a bookmark location
isearch when exiting from an incremental search
default default for all contexts not set explicitly
Allowed visibility spans are
minimal show current headline; if point is not on headline,
also show entry
local show current headline, entry and next headline
ancestors show current headline and its direct ancestors; if
point is not on headline, also show entry
ancestors-full show current subtree and its direct ancestors
lineage show current headline, its direct ancestors and all
their children; if point is not on headline, also show
entry and first child
tree show current headline, its direct ancestors and all
their children; if point is not on headline, also show
entry and all children
canonical show current headline, its direct ancestors along with
their entries and children; if point is not located on
the headline, also show current entry and all children
As special cases, a nil or t value means show all contexts in
`minimal' or `canonical' view, respectively.
Some views can make displayed information very compact, but also
make it harder to edit the location of the match. In such
a case, use the command `org-fold-reveal' (`\\[org-fold-reveal]') to show
more context."
:group 'org-fold-reveal-location
:version "26.1"
:package-version '(Org . "9.0")
:type '(choice
(const :tag "Canonical" t)
(const :tag "Minimal" nil)
(repeat :greedy t :tag "Individual contexts"
(cons
(choice :tag "Context"
(const agenda)
(const org-goto)
(const occur-tree)
(const tags-tree)
(const link-search)
(const mark-goto)
(const bookmark-jump)
(const isearch)
(const default))
(choice :tag "Detail level"
(const minimal)
(const local)
(const ancestors)
(const ancestors-full)
(const lineage)
(const tree)
(const canonical))))))
(defvar org-fold-reveal-start-hook nil
"Hook run before revealing a location.")
(defcustom org-fold-catch-invisible-edits 'smart
"Check if in invisible region before inserting or deleting a character.
Valid values are:
nil Do not check, so just do invisible edits.
error Throw an error and do nothing.
show Make point visible, and do the requested edit.
show-and-error Make point visible, then throw an error and abort the edit.
smart Make point visible, and do insertion/deletion if it is
adjacent to visible text and the change feels predictable.
Never delete a previously invisible character or add in the
middle or right after an invisible region. Basically, this
allows insertion and backward-delete right before ellipses.
FIXME: maybe in this case we should not even show?
This variable only affects commands listed in
`org-fold-catch-invisible-edits-commands'."
:group 'org-edit-structure
:version "24.1"
:type '(choice
(const :tag "Do not check" nil)
(const :tag "Throw error when trying to edit" error)
(const :tag "Unhide, but do not do the edit" show-and-error)
(const :tag "Show invisible part and do the edit" show)
(const :tag "Be smart and do the right thing" smart)))
(defcustom org-fold-catch-invisible-edits-commands
;; We do not add non-Org commands here by default to avoid advising
;; globally. See `org-fold--advice-edit-commands'.
'((org-self-insert-command . insert)
(org-delete-backward-char . delete-backward)
(org-delete-char . delete)
(org-meta-return . insert)
(org-return . insert))
"Alist of commands where Org checks for invisible edits.
Each element is (COMMAND . KIND), where COMMAND is symbol representing
command as stored in `this-command' and KIND is symbol `insert',
symbol `delete', or symbol `delete-backward'.
The checks are performed around `point'.
This variable must be set before loading Org in order to take effect.
Also, see `org-fold-catch-invisible-edits'."
:group 'org-edit-structure
:package-version '("Org" . "9.7")
:type '(alist
:key-type symbol
:value-type (choice
(const insert)
(const delete)
(const delete-backward))))
;;; Core functionality
;;; API
;;;; Modifying folding specs
(defalias 'org-fold-folding-spec-p #'org-fold-core-folding-spec-p)
(defalias 'org-fold-add-folding-spec #'org-fold-core-add-folding-spec)
(defalias 'org-fold-remove-folding-spec #'org-fold-core-remove-folding-spec)
(defun org-fold-initialize (ellipsis)
"Setup folding in current Org buffer."
(setq-local org-fold-core-isearch-open-function #'org-fold--isearch-reveal)
(setq-local org-fold-core-extend-changed-region-functions (list #'org-fold--extend-changed-region))
;; FIXME: Converting org-link + org-description to overlays when
;; search matches hidden "[[" part of the link, reverses priority of
;; link and description and hides the whole link. Working around
;; this until there will be no need to convert text properties to
;; overlays for isearch.
(setq-local org-fold-core--isearch-special-specs '(org-link))
(org-fold-core-initialize
`((,(if (eq org-fold-core-style 'text-properties) 'org-fold-outline 'outline)
(:ellipsis . ,ellipsis)
(:fragile . ,#'org-fold--reveal-outline-maybe)
(:isearch-open . t)
(:font-lock . t)
;; This is needed to make sure that inserting a
;; new planning line in folded heading is not
;; revealed. Also, the below combination of :front-sticky and
;; :rear-sticky conforms to the overlay properties in outline.el
;; and the older Org versions as in `outline-flag-region'.
(:front-sticky . t)
(:rear-sticky . nil)
(:alias . (headline heading outline inlinetask plain-list)))
(,(if (eq org-fold-core-style 'text-properties) 'org-fold-block 'org-hide-block)
(:ellipsis . ,ellipsis)
(:fragile . ,#'org-fold--reveal-drawer-or-block-maybe)
(:isearch-open . t)
(:font-lock . t)
(:front-sticky . t)
(:alias . ( block center-block comment-block
dynamic-block example-block export-block
quote-block special-block src-block
verse-block)))
(,(if (eq org-fold-core-style 'text-properties) 'org-fold-drawer 'org-hide-drawer)
(:ellipsis . ,ellipsis)
(:fragile . ,#'org-fold--reveal-drawer-or-block-maybe)
(:isearch-open . t)
(:font-lock . t)
(:front-sticky . t)
(:alias . (drawer property-drawer))))))
;;;; Searching and examining folded text
(defalias 'org-fold-folded-p #'org-fold-core-folded-p)
(defalias 'org-fold-get-folding-spec #'org-fold-core-get-folding-spec)
(defalias 'org-fold-get-folding-specs-in-region #'org-fold-core-get-folding-specs-in-region)
(defalias 'org-fold-get-region-at-point #'org-fold-core-get-region-at-point)
(defalias 'org-fold-get-regions #'org-fold-core-get-regions)
(defalias 'org-fold-next-visibility-change #'org-fold-core-next-visibility-change)
(defalias 'org-fold-previous-visibility-change #'org-fold-core-previous-visibility-change)
(defalias 'org-fold-next-folding-state-change #'org-fold-core-next-folding-state-change)
(defalias 'org-fold-previous-folding-state-change #'org-fold-core-previous-folding-state-change)
(defalias 'org-fold-search-forward #'org-fold-core-search-forward)
;;;;; Macros
(defalias 'org-fold-save-outline-visibility #'org-fold-core-save-visibility)
;;;; Changing visibility (regions, blocks, drawers, headlines)
;;;;; Region visibility
(defalias 'org-fold-region #'org-fold-core-region)
(defalias 'org-fold-regions #'org-fold-core-regions)
(defun org-fold-show-all (&optional types)
"Show all contents in the visible part of the buffer.
By default, the function expands headings, blocks and drawers.
When optional argument TYPES is a list of symbols among `blocks',
`drawers' and `headings', to only expand one specific type."
(interactive)
(dolist (type (or types '(blocks drawers headings)))
(org-fold-region (point-min) (point-max) nil
(pcase type
(`blocks 'block)
(`drawers 'drawer)
(`headings 'headline)
(_ (error "Invalid type: %S" type))))))
(defun org-fold-flag-above-first-heading (&optional arg)
"Hide from bob up to the first heading.
Move point to the beginning of first heading or end of buffer."
(goto-char (point-min))
(unless (org-at-heading-p)
(outline-next-heading))
(unless (bobp)
(org-fold-region 1 (1- (point)) (not arg) 'outline)))
;;;;; Heading visibility
(defun org-fold-heading (flag &optional entry)
"Fold/unfold the current heading. FLAG non-nil means make invisible.
When ENTRY is non-nil, show the entire entry."
(save-excursion
(org-back-to-heading t)
;; Check if we should show the entire entry
(if (not entry)
(org-fold-region
(line-end-position 0) (line-end-position) flag 'outline)
(org-fold-show-entry)
(save-excursion
;; FIXME: potentially catches inlinetasks
(and (outline-next-heading)
(org-fold-heading nil))))))
(defun org-fold-hide-entry ()
"Hide the body directly following this heading."
(interactive)
(save-excursion
(org-back-to-heading-or-point-min t)
(when (org-at-heading-p) (forward-line))
(unless (or (eobp) (org-at-heading-p)) ; Current headline is empty.
(org-fold-region
(line-end-position 0)
(save-excursion
(if (re-search-forward
(concat "[\r\n]" (org-get-limited-outline-regexp)) nil t)
(line-end-position 0)
(point-max)))
t
'outline))))
(defun org-fold-subtree (flag)
"Hide (when FLAG) or reveal subtree at point."
(save-excursion
(org-back-to-heading t)
(org-fold-region
(line-end-position)
(progn (org-end-of-subtree t t) (if (eobp) (point) (1- (point))))
flag
'outline)))
;; Replaces `outline-hide-subtree'.
(defun org-fold-hide-subtree ()
"Hide everything after this heading at deeper levels."
(interactive)
(org-fold-subtree t))
;; Replaces `outline-hide-sublevels'
(defun org-fold-hide-sublevels (levels)
"Hide everything but the top LEVELS levels of headers, in whole buffer.
This also unhides the top heading-less body, if any.
Interactively, the prefix argument supplies the value of LEVELS.
When invoked without a prefix argument, LEVELS defaults to the level
of the current heading, or to 1 if the current line is not a heading."
(interactive (list
(cond
(current-prefix-arg (prefix-numeric-value current-prefix-arg))
((save-excursion (forward-line 0)
(looking-at outline-regexp))
(funcall outline-level))
(t 1))))
(if (< levels 1)
(error "Must keep at least one level of headers"))
(save-excursion
(let* ((beg (progn
(goto-char (point-min))
;; Skip the prelude, if any.
(unless (org-at-heading-p) (outline-next-heading))
(point)))
(end (progn
(goto-char (point-max))
;; Keep empty last line, if available.
(max (point-min) (if (bolp) (1- (point)) (point))))))
(if (< end beg)
(setq beg (prog1 end (setq end beg))))
;; First hide everything.
(org-fold-region beg end t 'headline)
;; Then unhide the top level headers.
(org-map-region
(lambda ()
(when (<= (funcall outline-level) levels)
(org-fold-heading nil)))
beg end)
;; Finally unhide any trailing newline.
(goto-char (point-max))
(if (and (bolp) (not (bobp)) (outline-invisible-p (1- (point))))
(org-fold-region (max (point-min) (1- (point))) (point) nil)))))
(defun org-fold-show-entry (&optional hide-drawers)
"Show the body directly following its heading.
Show the heading too, if it is currently invisible."
(interactive)
(save-excursion
(org-back-to-heading-or-point-min t)
(org-fold-region
(line-end-position 0)
(save-excursion
(if (re-search-forward
(concat "[\r\n]\\(" (org-get-limited-outline-regexp) "\\)") nil t)
(match-beginning 1)
(point-max)))
nil
'outline)
(when hide-drawers (org-cycle-hide-drawers 'children))))
(defalias 'org-fold-show-hidden-entry #'org-fold-show-entry
"Show an entry where even the heading is hidden.")
(defun org-fold-show-siblings ()
"Show all siblings of the current headline."
(save-excursion
(while (org-goto-sibling) (org-fold-heading nil)))
(save-excursion
(while (org-goto-sibling 'previous)
(org-fold-heading nil))))
(defun org-fold-show-children (&optional level)
"Show all direct subheadings of this heading.
Prefix arg LEVEL is how many levels below the current level should be
shown. If direct subheadings are deeper than LEVEL, they are still
displayed."
(interactive "p")
(unless (org-before-first-heading-p)
(save-excursion
(org-with-limited-levels (org-back-to-heading t))
(let* ((current-level (funcall outline-level))
(parent-level current-level)
(max-level (org-get-valid-level
parent-level
(if level (prefix-numeric-value level) 1)))
(min-level-direct-child most-positive-fixnum)
(end (save-excursion (org-end-of-subtree t t)))
(regexp-fmt "^\\*\\{%d,%s\\}\\(?: \\|$\\)")
;; Make sure to skip inlinetasks.
(re (format regexp-fmt
current-level
(cond
((not (featurep 'org-inlinetask)) "")
(org-odd-levels-only (- (* 2 org-inlinetask-min-level)
3))
(t (1- org-inlinetask-min-level))))))
;; Display parent heading.
(org-fold-heading nil)
(forward-line)
;; Display children. First child may be deeper than expected
;; MAX-LEVEL. Since we want to display it anyway, adjust
;; MAX-LEVEL accordingly.
(while (re-search-forward re end t)
(setq current-level (funcall outline-level))
(when (< current-level min-level-direct-child)
(setq min-level-direct-child current-level
re (format regexp-fmt
parent-level
(max min-level-direct-child max-level))))
(org-fold-heading nil))))))
(defun org-fold-show-subtree ()
"Show everything after this heading at deeper levels."
(interactive)
(org-fold-region
(point) (save-excursion (org-end-of-subtree t t)) nil 'outline))
(defun org-fold-show-branches ()
"Show all subheadings of this heading, but not their bodies."
(interactive)
(org-fold-show-children 1000))
(defun org-fold-show-branches-buffer ()
"Show all branches in the buffer."
(org-fold-flag-above-first-heading)
(org-fold-hide-sublevels 1)
(unless (eobp)
(org-fold-show-branches)
(while (outline-get-next-sibling)
(org-fold-show-branches)))
(goto-char (point-min)))
;;;;; Blocks and drawers visibility
(defun org-fold--hide-wrapper-toggle (element category force no-error)
"Toggle visibility for ELEMENT.
ELEMENT is a block or drawer type parsed element. CATEGORY is
either `block' or `drawer'. When FORCE is `off', show the block
or drawer. If it is non-nil, hide it unconditionally. Throw an
error when not at a block or drawer, unless NO-ERROR is non-nil.
Return a non-nil value when toggling is successful."
(let ((type (org-element-type element)))
(cond
((memq type
(pcase category
(`drawer '(drawer property-drawer))
(`block '(center-block
comment-block dynamic-block example-block export-block
quote-block special-block src-block verse-block))
(_ (error "Unknown category: %S" category))))
(let* ((post (org-element-post-affiliated element))
(start (save-excursion
(goto-char post)
(line-end-position)))
(end (save-excursion
(goto-char (org-element-end element))
(skip-chars-backward " \t\n")
(line-end-position))))
;; Do nothing when not before or at the block opening line or
;; at the block closing line.
(unless (let ((eol (line-end-position)))
(and (> eol start) (/= eol end)))
(org-fold-region start end
(cond ((eq force 'off) nil)
(force t)
((org-fold-folded-p start category) nil)
(t t))
category)
;; When the block is hidden away, make sure point is left in
;; a visible part of the buffer.
(when (invisible-p (max (1- (point)) (point-min)))
(goto-char post))
;; Signal success.
t)))
(no-error nil)
(t
(user-error (format "%s@%s: %s"
(buffer-file-name (buffer-base-buffer))
(point)
(if (eq category 'drawer)
"Not at a drawer"
"Not at a block")))))))
(defun org-fold-hide-block-toggle (&optional force no-error element)
"Toggle the visibility of the current block.
When optional argument FORCE is `off', make block visible. If it
is non-nil, hide it unconditionally. Throw an error when not at
a block, unless NO-ERROR is non-nil. When optional argument
ELEMENT is provided, consider it instead of the current block.
Return a non-nil value when toggling is successful."
(interactive)
(org-fold--hide-wrapper-toggle
(or element (org-element-at-point)) 'block force no-error))
(defun org-fold-hide-drawer-toggle (&optional force no-error element)
"Toggle the visibility of the current drawer.
When optional argument FORCE is `off', make drawer visible. If
it is non-nil, hide it unconditionally. Throw an error when not
at a drawer, unless NO-ERROR is non-nil. When optional argument
ELEMENT is provided, consider it instead of the current drawer.
Return a non-nil value when toggling is successful."
(interactive)
(org-fold--hide-wrapper-toggle
(or element (org-element-at-point)) 'drawer force no-error))
(defun org-fold-hide-block-all ()
"Fold all blocks in the current buffer."
(interactive)
(org-block-map (apply-partially #'org-fold-hide-block-toggle 'hide)))
(defun org-fold-hide-drawer-all (&optional begin end)
"Fold all drawers in the current buffer or active region BEGIN..END."
(interactive (list (and (use-region-p) (region-beginning))
(and (use-region-p) (region-end))))
(let ((begin (or begin (point-min)))
(end (or end (point-max))))
(org-fold--hide-drawers begin end)))
(defun org-fold--hide-drawers (begin end)
"Hide all drawers between BEGIN and END."
(save-excursion
(goto-char begin)
(while (and (< (point) end)
(re-search-forward org-drawer-regexp end t))
;; Skip folded drawers
(if (org-fold-folded-p nil 'drawer)
(goto-char (org-fold-next-folding-state-change 'drawer nil end))
(let* ((drawer (org-element-at-point))
(type (org-element-type drawer)))
(when (memq type '(drawer property-drawer))
(org-fold-hide-drawer-toggle t nil drawer)
;; Make sure to skip drawer entirely or we might flag it
;; another time when matching its ending line with
;; `org-drawer-regexp'.
(goto-char (org-element-end drawer))))))))
(defun org-fold-hide-archived-subtrees (beg end)
"Re-hide all archived subtrees after a visibility state change."
(org-with-wide-buffer
(let ((case-fold-search nil)
(re (concat org-outline-regexp-bol ".*:" org-archive-tag ":")))
(goto-char beg)
;; Include headline point is currently on.
(forward-line 0)
(while (and (< (point) end) (re-search-forward re end t))
(when (member org-archive-tag (org-get-tags nil t))
(org-fold-subtree t)
(org-end-of-subtree t))))))
;;;;; Reveal point location
(defun org-fold-show-context (&optional key)
"Make sure point and context are visible.
Optional argument KEY, when non-nil, is a symbol. See
`org-fold-show-context-detail' for allowed values and how much is to
be shown."
(org-fold-show-set-visibility
(cond ((symbolp org-fold-show-context-detail) org-fold-show-context-detail)
((cdr (assq key org-fold-show-context-detail)))
(t (cdr (assq 'default org-fold-show-context-detail))))))
(defvar org-hide-emphasis-markers); Defined in org.el
(defvar org-pretty-entities); Defined in org.el
(defun org-fold-show-set-visibility (detail)
"Set visibility around point according to DETAIL.
DETAIL is either nil, `minimal', `local', `ancestors',
`ancestors-full', `lineage', `tree', `canonical' or t. See
`org-show-context-detail' for more information."
;; Show current heading and possibly its entry, following headline
;; or all children.
(if (and (org-at-heading-p) (not (eq detail 'local)))
(org-fold-heading nil)
(org-fold-show-entry)
;; If point is hidden make sure to expose it.
(when (org-invisible-p)
;; FIXME: No clue why, but otherwise the following might not work.
(redisplay)
;; Reveal emphasis markers.
(when (eq detail 'local)
(let (org-hide-emphasis-markers
org-link-descriptive
org-pretty-entities
(org-hide-macro-markers nil)
(region (or (org-find-text-property-region (point) 'org-emphasis)
(org-find-text-property-region (point) 'org-macro)
(org-find-text-property-region (point) 'invisible))))
;; Silence byte-compiler.
(ignore org-hide-macro-markers)
(when region
(org-with-point-at (car region)
(forward-line 0)
(let (font-lock-extend-region-functions)
(font-lock-fontify-region (max (point-min) (1- (car region))) (cdr region)))))))
(let (region)
(dolist (spec (org-fold-core-folding-spec-list))
(setq region (org-fold-get-region-at-point spec))
(when region
(org-fold-region (car region) (cdr region) nil spec)))))
(unless (org-before-first-heading-p)
(org-with-limited-levels
(cl-case detail
((tree canonical t) (org-fold-show-children))
((nil minimal ancestors ancestors-full))
(t (save-excursion
(outline-next-heading)
(org-fold-heading nil)))))))
;; Show whole subtree.
(when (eq detail 'ancestors-full) (org-fold-show-subtree))
;; Show all siblings.
(when (eq detail 'lineage) (org-fold-show-siblings))
;; Show ancestors, possibly with their children.
(when (memq detail '(ancestors ancestors-full lineage tree canonical t))
(save-excursion
(while (org-up-heading-safe)
(org-fold-heading nil)
(when (memq detail '(canonical t)) (org-fold-show-entry))
(when (memq detail '(tree canonical t)) (org-fold-show-children))))))
(defun org-fold-reveal (&optional siblings)
"Show current entry, hierarchy above it, and the following headline.
This can be used to show a consistent set of context around
locations exposed with `org-fold-show-context'.
With optional argument SIBLINGS, on each level of the hierarchy all
siblings are shown. This repairs the tree structure to what it would
look like when opened with hierarchical calls to `org-cycle'.
With a \\[universal-argument] \\[universal-argument] prefix, \
go to the parent and show the entire tree."
(interactive "P")
(run-hooks 'org-fold-reveal-start-hook)
(cond ((equal siblings '(4)) (org-fold-show-set-visibility 'canonical))
((equal siblings '(16))
(save-excursion
(when (org-up-heading-safe)
(org-fold-show-subtree)
(run-hook-with-args 'org-cycle-hook 'subtree))))
(t (org-fold-show-set-visibility 'lineage))))
;;; Make isearch search in some text hidden via text properties.
(defun org-fold--isearch-reveal (pos)
"Reveal text at POS found by isearch."
(org-with-point-at pos
(org-fold-show-context 'isearch)))
;;; Handling changes in folded elements
(defun org-fold--extend-changed-region (from to)
"Consider folded regions in the next/previous line when fixing region visibility.
This function is intended to be used as a member of
`org-fold-core-extend-changed-region-functions'."
;; If the edit is done in the first line of a folded drawer/block,
;; the folded text is only starting from the next line and needs to
;; be checked.
(setq to (save-excursion (goto-char to) (line-beginning-position 2)))
;; If the ":END:" line of the drawer is deleted, the folded text is
;; only ending at the previous line and needs to be checked.
(setq from (save-excursion (goto-char from) (line-beginning-position 0)))
(cons from to))
(defun org-fold--reveal-headline-at-point ()
"Reveal header line and empty contents inside.
Reveal the header line and, if present, also reveal its contents, when
the contents consists of blank lines.
Assume that point is located at the header line."
(org-with-wide-buffer
(forward-line 0)
(org-fold-region
(max (point-min) (1- (point)))
(let ((endl (line-end-position)))
(save-excursion
(goto-char endl)
(skip-chars-forward "\n\t\r ")
;; Unfold blank lines after newly inserted headline.
(if (equal (point)
(save-excursion
(goto-char endl)
(org-end-of-subtree t)
(skip-chars-forward "\n\t\r ")))
(point)
endl)))
nil 'headline)))
(defun org-fold--reveal-outline-maybe (region _)
"Reveal folded outline in REGION when needed.
This function is intended to be used as :fragile property of
`org-fold-outline' spec. See `org-fold-core--specs' for details."
(save-match-data
(org-with-wide-buffer
(goto-char (car region))
;; The line before beginning of the fold should be either a
;; headline or a list item.
(backward-char)
(forward-line 0)
;; Make sure that headline is not partially hidden.
(unless (org-fold-folded-p nil 'headline)
(org-fold--reveal-headline-at-point))
;; Never hide level 1 headlines
(save-excursion
(goto-char (line-end-position))
(unless (>= (point) (cdr region))
(when (re-search-forward (rx bol "* ") (cdr region) t)
(org-fold--reveal-headline-at-point))))
;; Make sure that headline after is not partially hidden.
(goto-char (cdr region))
(forward-line 0)
(unless (org-fold-folded-p nil 'headline)
(when (looking-at-p org-element-headline-re)
(org-fold--reveal-headline-at-point)))
;; Check the validity of headline
(goto-char (car region))
(backward-char)
(forward-line 0)
(unless (let ((case-fold-search t))
(looking-at (rx-to-string
`(or (regex ,(org-item-re))
(regex ,org-outline-regexp-bol)))))
t))))
(defun org-fold--reveal-drawer-or-block-maybe (region spec)
"Reveal folded drawer/block (according to SPEC) in REGION when needed.
This function is intended to be used as :fragile property of
`org-fold-drawer' or `org-fold-block' spec."
(let ((begin-re (cond
((eq spec (org-fold-core-get-folding-spec-from-alias 'drawer))
org-drawer-regexp)
;; Group one below contains the type of the block.
((eq spec (org-fold-core-get-folding-spec-from-alias 'block))
(rx bol (zero-or-more (any " " "\t"))
"#+begin"
(or ":"
(seq "_"
(group (one-or-more (not (syntax whitespace))))))))))
;; To be determined later. May depend on `begin-re' match (i.e. for blocks).
end-re)
(save-match-data ; we should not clobber match-data in after-change-functions
(let ((fold-begin (car region))
(fold-end (cdr region)))
(let (unfold?)
(catch :exit
;; The line before folded text should be beginning of
;; the drawer/block.
(save-excursion
(goto-char fold-begin)
;; The line before beginning of the fold should be the
;; first line of the drawer/block.
(backward-char)
(forward-line 0)
(unless (let ((case-fold-search t))
(looking-at begin-re)) ; the match-data will be used later
(throw :exit (setq unfold? t))))
;; Set `end-re' for the current drawer/block.
(setq end-re
(cond
((eq spec (org-fold-core-get-folding-spec-from-alias 'drawer))
org-property-end-re)
((eq spec (org-fold-core-get-folding-spec-from-alias 'block))
(let ((block-type (match-string 1))) ; the last match is from `begin-re'
(concat (rx bol (zero-or-more (any " " "\t")) "#+end")
(if block-type
(concat "_"
(regexp-quote block-type)
(rx (zero-or-more (any " " "\t")) eol))
(rx (opt ":") (zero-or-more (any " " "\t")) eol)))))))
;; The last line of the folded text should match `end-re'.
(save-excursion
(goto-char fold-end)
(forward-line 0)
(unless (let ((case-fold-search t))
(looking-at end-re))
(throw :exit (setq unfold? t))))
;; There should be no `end-re' or
;; `org-outline-regexp-bol' anywhere in the
;; drawer/block body.
(save-excursion
(goto-char fold-begin)
(when (save-excursion
(let ((case-fold-search t))
(re-search-forward (rx-to-string `(or (regex ,end-re)
(regex ,org-outline-regexp-bol)))
(max (point)
(1- (save-excursion
(goto-char fold-end)
(line-beginning-position))))
t)))
(throw :exit (setq unfold? t)))))
unfold?)))))
;; Catching user edits inside invisible text
(defun org-fold-check-before-invisible-edit (kind)
"Check if editing KIND is dangerous with invisible text around.
The detailed reaction depends on the user option
`org-fold-catch-invisible-edits'."
;; First, try to get out of here as quickly as possible, to reduce overhead
(when (and org-fold-catch-invisible-edits
(or (not (boundp 'visible-mode)) (not visible-mode))
(or (org-invisible-p)
(org-invisible-p (max (point-min) (1- (point))))))
;; OK, we need to take a closer look. Only consider invisibility
;; caused by folding of headlines, drawers, and blocks. Edits
;; inside links will be handled by font-lock.
(let* ((invisible-at-point (org-fold-folded-p (point) '(headline drawer block)))
(invisible-before-point
(and (not (bobp))
(org-fold-folded-p (1- (point)) '(headline drawer block))))
(border-and-ok-direction
(or
;; Check if we are acting predictably before invisible
;; text.
(and invisible-at-point (not invisible-before-point)
(memq kind '(insert delete-backward)))
;; Check if we are acting predictably after invisible text
;; This works not well, and I have turned it off. It seems
;; better to always show and stop after invisible text.
;; (and (not invisible-at-point) invisible-before-point
;; (memq kind '(insert delete)))
)))
(when (or invisible-at-point invisible-before-point)
(when (eq org-fold-catch-invisible-edits 'error)
(user-error "Editing in invisible areas is prohibited, make them visible first"))
(if (and org-custom-properties-overlays
(y-or-n-p "Display invisible properties in this buffer? "))
(org-toggle-custom-properties-visibility)
;; Make the area visible
(save-excursion
(org-fold-show-set-visibility 'local))
(when invisible-before-point
(org-with-point-at (1- (point)) (org-fold-show-set-visibility 'local)))
(cond
((eq org-fold-catch-invisible-edits 'show)
;; That's it, we do the edit after showing
(message
"Unfolding invisible region around point before editing")
(sit-for 1))
((and (eq org-fold-catch-invisible-edits 'smart)
border-and-ok-direction)
(message "Unfolding invisible region around point before editing"))
(t
;; Don't do the edit, make the user repeat it in full visibility
(user-error "Edit in invisible region aborted, repeat to confirm with text visible"))))))))
(defun org-fold-check-before-invisible-edit-maybe (&rest _)
"Check before invisible command by `this-command'."
(when (derived-mode-p 'org-mode)
(pcase (alist-get this-command org-fold-catch-invisible-edits-commands)
((pred null) nil)
(kind (org-fold-check-before-invisible-edit kind)))))
(defun org-fold--advice-edit-commands ()
"Advice editing commands according to `org-fold-catch-invisible-edits-commands'.
The advices are installed in current buffer."
(dolist (command (mapcar #'car org-fold-catch-invisible-edits-commands))
(advice-add command :before #'org-fold-check-before-invisible-edit-maybe)))
(provide 'org-fold)
;;; org-fold.el ends here
org-mode-9.7.29+dfsg/lisp/org-footnote.el 0000664 0000000 0000000 00000113222 15004304337 0020165 0 ustar 00root root 0000000 0000000 ;;; org-footnote.el --- Footnote support in Org -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2009-2025 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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 <https://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;; This file contains the code dealing with footnotes in Org mode.
;;; Code:
(require 'org-macs)
(org-assert-version)
;;;; Declarations
(require 'cl-lib)
(require 'org-macs)
(require 'org-compat)
(declare-function org-at-comment-p "org" ())
(declare-function org-at-heading-p "org" (&optional ignored))
(declare-function org-back-over-empty-lines "org" ())
(declare-function org-end-of-meta-data "org" (&optional full))
(declare-function org-edit-footnote-reference "org-src" ())
(declare-function org-element-at-point "org-element" (&optional pom cached-only))
(declare-function org-element-class "org-element" (datum &optional parent))
(declare-function org-element-context "org-element" (&optional element))
(declare-function org-element-lineage "org-element-ast" (blob &optional types with-self))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-type "org-element-ast" (node &optional anonymous))
(declare-function org-element-type-p "org-element-ast" (node types))
(declare-function org-end-of-subtree "org" (&optional invisible-ok to-heading))
(declare-function org-fill-paragraph "org" (&optional justify region))
(declare-function org-in-block-p "org" (names))
(declare-function org-in-verbatim-emphasis "org" ())
(declare-function org-inside-LaTeX-fragment-p "org" ())
(declare-function org-inside-latex-macro-p "org" ())
(declare-function org-mark-ring-push "org" (&optional pos buffer))
(declare-function org-fold-show-context "org-fold" (&optional key))
(declare-function outline-next-heading "outline")
(defvar electric-indent-mode)
(defvar org-blank-before-new-entry) ; defined in org.el
(defvar org-link-bracket-re) ; defined in org.el
(defvar org-complex-heading-regexp) ; defined in org.el
(defvar org-odd-levels-only) ; defined in org.el
(defvar org-outline-regexp) ; defined in org.el
(defvar org-outline-regexp-bol) ; defined in org.el
;;;; Constants
(defconst org-footnote-re
"\\[fn:\\(?:\\(?1:[-_[:word:]]+\\)?\\(:\\)\\|\\(?1:[-_[:word:]]+\\)\\]\\)"
"Regular expression for matching footnotes.
Match group 1 contains footnote's label. It is nil for anonymous
footnotes. Match group 2 is non-nil only when footnote is
inline, i.e., it contains its own definition.")
(defconst org-footnote-definition-re "^\\[fn:\\([-_[:word:]]+\\)\\]"
"Regular expression matching the definition of a footnote.
Match group 1 contains definition's label.")
(defconst org-footnote-forbidden-blocks '("comment" "example" "export" "src")
"Names of blocks where footnotes are not allowed.")
;;;; Customization
(defgroup org-footnote nil
"Footnotes in Org mode."
:tag "Org Footnote"
:group 'org)
(defcustom org-footnote-section "Footnotes"
"Outline heading containing footnote definitions.
This can be nil, to place footnotes locally at the end of the current
outline node. It can also be a string representing the name of a
special outline heading under which footnotes should be put.
This variable defines the place where Org puts the definition
automatically, i.e. when creating the footnote, and when sorting
the notes. However, by hand, you may place definitions
*anywhere*.
If this is a string, during export, all subtrees starting with
this heading will be ignored.
If you don't use the customize interface to change this variable,
you will need to run the following command after the change:
`\\[universal-argument] \\[org-element-cache-reset]'"
:group 'org-footnote
:initialize 'custom-initialize-default
:set (lambda (var val)
(set-default-toplevel-value var val)
(when (fboundp 'org-element-cache-reset)
(org-element-cache-reset 'all)))
:type '(choice
(string :tag "Collect footnotes under heading")
(const :tag "Define footnotes locally" nil))
:safe #'string-or-null-p)
(defcustom org-footnote-define-inline nil
"Non-nil means define footnotes inline, at reference location.
When nil, footnotes will be defined in a special section near
the end of the document. When t, the [fn:label:definition] notation
will be used to define the footnote at the reference position."
:group 'org-footnote
:type 'boolean
:safe #'booleanp)
(defcustom org-footnote-auto-label t
"Non-nil means define automatically new labels for footnotes.
Possible values are:
nil Prompt the user for each label.
t Create unique labels of the form [fn:1], [fn:2], etc.
anonymous Create anonymous footnotes
confirm Like t, but let the user edit the created value.
The label can be removed from the minibuffer to create
an anonymous footnote.
random Automatically generate a unique, random label."
:group 'org-footnote
:package-version '(Org . "9.7")
:type '(choice
(const :tag "Prompt for label" nil)
(const :tag "Create automatic [fn:N]" t)
(const :tag "Offer automatic [fn:N] for editing" confirm)
(const :tag "Create anonymous [fn::]" anonymous)
(const :tag "Create a random label" random))
:safe #'symbolp)
(defcustom org-footnote-auto-adjust nil
"Non-nil means automatically adjust footnotes after insert/delete.
When this is t, after each insertion or deletion of a footnote,
simple fn:N footnotes will be renumbered, and all footnotes will be sorted.
If you want to have just sorting or just renumbering, set this variable
to `sort' or `renumber'.
The main values of this variable can be set with in-buffer options:
#+STARTUP: fnadjust
#+STARTUP: nofnadjust"
:group 'org-footnote
:type '(choice
(const :tag "No adjustment" nil)
(const :tag "Renumber" renumber)
(const :tag "Sort" sort)
(const :tag "Renumber and Sort" t))
:safe #'symbolp)
(defcustom org-footnote-fill-after-inline-note-extraction nil
"Non-nil means fill paragraphs after extracting footnotes.
When extracting inline footnotes, the lengths of lines can change a lot.
When this option is set, paragraphs from which an inline footnote has been
extracted will be filled again."
:group 'org-footnote
:type 'boolean
:safe #'booleanp)
;;;; Predicates
(defun org-footnote-in-valid-context-p ()
"Is point in a context where footnotes are allowed?"
(save-match-data
(not (or (org-at-comment-p)
(org-inside-LaTeX-fragment-p)
;; Avoid literal example.
(org-in-verbatim-emphasis)
(save-excursion
(forward-line 0)
(looking-at "[ \t]*:[ \t]+"))
;; Avoid forbidden blocks.
(org-in-block-p org-footnote-forbidden-blocks)))))
(defun org-footnote-at-reference-p ()
"Non-nil if point is at a footnote reference.
If so, return a list containing its label, beginning and ending
positions, and the definition, when inline."
(let ((reference (org-element-context)))
(when (org-element-type-p reference 'footnote-reference)
(let ((end (save-excursion
(goto-char (org-element-property :end reference))
(skip-chars-backward " \t")
(point))))
(when (< (point) end)
(list (org-element-property :label reference)
(org-element-property :begin reference)
end
(and (eq 'inline (org-element-property :type reference))
(buffer-substring-no-properties
(org-element-property :contents-begin reference)
(org-element-property :contents-end
reference)))))))))
(defun org-footnote-at-definition-p ()
"Non-nil if point is within a footnote definition.
This matches only pure definitions like [fn:name] at the
beginning of a line. It does not match references like
\[fn:name:definition], where the footnote text is included and
defined locally.
The return value is nil if not at a footnote definition, and
a list with label, start, end and definition of the footnote
otherwise."
(pcase (org-element-lineage (org-element-at-point) 'footnote-definition t)
(`nil nil)
(definition
(let* ((label (org-element-property :label definition))
(begin (org-element-property :post-affiliated definition))
(end (save-excursion
(goto-char (org-element-property :end definition))
(skip-chars-backward " \r\t\n")
(line-beginning-position 2)))
(contents-begin (org-element-property :contents-begin definition))
(contents-end (org-element-property :contents-end definition))
(contents
(if (not contents-begin) ""
(org-trim
(buffer-substring-no-properties contents-begin
contents-end)))))
(list label begin end contents)))))
;;;; Internal functions
(defun org-footnote--allow-reference-p ()
"Non-nil when a footnote reference can be inserted at point."
;; XXX: This is similar to `org-footnote-in-valid-context-p' but
;; more accurate and usually faster, except in some corner cases.
;; It may replace it after doing proper benchmarks as it would be
;; used in fontification.
(unless (bolp)
(let* ((context (org-element-context))
(type (org-element-type context)))
(cond
;; No footnote reference in attributes.
((let ((post (org-element-property :post-affiliated context)))
(and post (< (point) post)))
nil)
;; Paragraphs and blank lines at top of document are fine.
((memq type '(nil paragraph)))
;; So are contents of verse blocks.
((eq type 'verse-block)
(and (>= (point) (org-element-property :contents-begin context))
(< (point) (org-element-property :contents-end context))))
;; In an headline or inlinetask, point must be either on the
;; heading itself or on the blank lines below.
((memq type '(headline inlinetask))
(or (not (org-at-heading-p))
(and (save-excursion
(forward-line 0)
(and (let ((case-fold-search t))
(not (looking-at-p "\\*+ END[ \t]*$")))
(let ((case-fold-search nil))
(looking-at org-complex-heading-regexp))))
(match-beginning 4)
(>= (point) (match-beginning 4))
(or (not (match-beginning 5))
(< (point) (match-beginning 5))))))
;; White spaces after an object or blank lines after an element
;; are OK.
((>= (point)
(save-excursion (goto-char (org-element-property :end context))
(skip-chars-backward " \r\t\n")
(if (eq (org-element-class context) 'object) (point)
(line-beginning-position 2)))))
;; At the beginning of a footnote definition, right after the
;; label, is OK.
((eq type 'footnote-definition) (looking-at (rx space)))
;; Other elements are invalid.
((eq (org-element-class context) 'element) nil)
;; Just before object is fine.
((= (point) (org-element-property :begin context)))
;; Within recursive object too, but not in a link.
((eq type 'link) nil)
((eq type 'table-cell)
;; :contents-begin is not reliable on empty cells, so special
;; case it.
(<= (save-excursion (skip-chars-backward " \t") (point))
(org-element-property :contents-end context)))
((let ((cbeg (org-element-property :contents-begin context))
(cend (org-element-property :contents-end context)))
(and cbeg (>= (point) cbeg) (<= (point) cend))))))))
(defun org-footnote--clear-footnote-section ()
"Remove all footnote sections in buffer and create a new one.
New section is created at the end of the buffer. Leave point
within the new section."
(when org-footnote-section
(goto-char (point-min))
(let ((regexp (format "^\\*+ +%s[ \t]*$"
(regexp-quote org-footnote-section))))
(while (re-search-forward regexp nil t)
(delete-region
(match-beginning 0)
(org-end-of-subtree t t))))
(goto-char (point-max))
;; Clean-up blank lines at the end of the buffer.
(skip-chars-backward " \r\t\n")
(unless (bobp)
(forward-line)
(when (eolp) (insert "\n")))
(delete-region (point) (point-max))
(when (and (cdr (assq 'heading org-blank-before-new-entry))
(zerop (save-excursion (org-back-over-empty-lines))))
(insert "\n"))
(insert "* " org-footnote-section "\n")))
(defun org-footnote--set-label (label)
"Set label of footnote at point to string LABEL.
Assume point is at the beginning of the reference or definition
to rename."
(forward-char 4)
(cond ((eq (char-after) ?:) (insert label))
((looking-at "\\([-_[:word:]]+\\)") (replace-match label nil nil nil 1))
(t nil)))
(defun org-footnote--collect-references (&optional anonymous)
"Collect all labeled footnote references in current buffer.
Return an alist where associations follow the pattern
(LABEL MARKER TOP-LEVEL SIZE)
with
LABEL the label of the of the definition,
MARKER a marker pointing to its beginning,
TOP-LEVEL a boolean, nil when the footnote is contained within
another one,
SIZE the length of the inline definition, in characters,
or nil for non-inline references.
When optional ANONYMOUS is non-nil, also collect anonymous
references. In such cases, LABEL is nil.
References are sorted according to a deep-reading order."
(org-with-wide-buffer
(goto-char (point-min))
(let ((regexp (if anonymous org-footnote-re "\\[fn:[-_[:word:]]+[]:]"))
references nested)
(save-excursion
(while (re-search-forward regexp nil t)
;; Ignore definitions.
(unless (and (eq (char-before) ?\])
(= (line-beginning-position) (match-beginning 0)))
;; Ensure point is within the reference before parsing it.
(backward-char)
(let ((object (org-element-context)))
(when (org-element-type-p object 'footnote-reference)
(let* ((label (org-element-property :label object))
(begin (org-element-property :begin object))
(size
(and (eq (org-element-property :type object) 'inline)
(- (org-element-property :contents-end object)
(org-element-property :contents-begin object)))))
(let ((d (org-element-lineage object 'footnote-definition)))
(push (list label (copy-marker begin) (not d) size)
references)
(when d
;; Nested references are stored in alist NESTED.
;; Associations there follow the pattern
;;
;; (DEFINITION-LABEL . REFERENCES)
(let* ((def-label (org-element-property :label d))
(labels (assoc def-label nested)))
(if labels (push label (cdr labels))
(push (list def-label label) nested)))))))))))
;; Sort the list of references. Nested footnotes have priority
;; over top-level ones.
(letrec ((ordered nil)
(add-reference
(lambda (ref allow-nested)
(when (or allow-nested (nth 2 ref))
(push ref ordered)
(dolist (r (mapcar (lambda (l) (assoc l references))
(reverse
(cdr (assoc (nth 0 ref) nested)))))
(funcall add-reference r t))))))
(dolist (r (reverse references) (nreverse ordered))
(funcall add-reference r nil))))))
(defun org-footnote--collect-definitions (&optional delete)
"Collect all footnote definitions in current buffer.
Return an alist where associations follow the pattern
(LABEL . DEFINITION)
with LABEL and DEFINITION being, respectively, the label and the
definition of the footnote, as strings.
When optional argument DELETE is non-nil, delete the definition
while collecting them."
(org-with-wide-buffer
(goto-char (point-min))
(let (definitions seen)
(while (re-search-forward org-footnote-definition-re nil t)
(backward-char)
(let ((element (org-element-at-point)))
(let ((label (org-element-property :label element)))
(when (and (org-element-type-p element 'footnote-definition)
(not (member label seen)))
(push label seen)
(let* ((beg (progn
(goto-char (org-element-property :begin element))
(skip-chars-backward " \r\t\n")
(if (bobp) (point) (line-beginning-position 2))))
(end (progn
(goto-char (org-element-property :end element))
(skip-chars-backward " \r\t\n")
(line-beginning-position 2)))
(def (org-trim (buffer-substring-no-properties beg end))))
(push (cons label def) definitions)
(when delete (delete-region beg end)))))))
definitions)))
(defun org-footnote--goto-local-insertion-point ()
"Find insertion point for footnote, just before next outline heading.
Assume insertion point is within currently accessible part of the buffer."
(org-with-limited-levels (outline-next-heading))
(skip-chars-backward " \t\n")
(unless (bobp) (forward-line))
(unless (bolp) (insert "\n")))
;;;; Navigation
(defun org-footnote-get-next-reference (&optional label backward limit)
"Return complete reference of the next footnote.
If LABEL is provided, get the next reference of that footnote. If
BACKWARD is non-nil, find previous reference instead. LIMIT is
the buffer position bounding the search.
Return value is a list like those provided by `org-footnote-at-reference-p'.
If no footnote is found, return nil."
(let ((label-regexp (if label (format "\\[fn:%s[]:]" label) org-footnote-re)))
(catch :exit
(save-excursion
(while (funcall (if backward #'re-search-backward #'re-search-forward)
label-regexp limit t)
(unless backward (backward-char))
(pcase (org-footnote-at-reference-p)
(`nil nil)
(reference (throw :exit reference))))))))
(defun org-footnote-next-reference-or-definition (limit)
"Move point to next footnote reference or definition.
LIMIT is the buffer position bounding the search.
Return value is a list like those provided by
`org-footnote-at-reference-p' or `org-footnote-at-definition-p'.
If no footnote is found, return nil.
This function is meant to be used for fontification only."
(let ((origin (point)))
(catch 'exit
(while t
(unless (re-search-forward org-footnote-re limit t)
(goto-char origin)
(throw 'exit nil))
;; Beware: with non-inline footnotes point will be just after
;; the closing square bracket.
(backward-char)
(cond
((and (/= (match-beginning 0) (line-beginning-position))
(let* ((beg (match-beginning 0))
(label (match-string-no-properties 1))
;; Inline footnotes don't end at (match-end 0)
;; as `org-footnote-re' stops just after the
;; second colon. Find the real ending with
;; `scan-sexps', so Org doesn't get fooled by
;; unrelated closing square brackets.
(end (ignore-errors (scan-sexps beg 1))))
(and end
;; Verify match isn't a part of a link.
(not (save-excursion
(goto-char beg)
(let ((linkp
(save-match-data
(org-in-regexp org-link-bracket-re))))
(and linkp (< (point) (cdr linkp))))))
;; Verify point doesn't belong to a LaTeX macro.
(not (org-inside-latex-macro-p))
(throw 'exit
(list label beg end
;; Definition: ensure this is an
;; inline footnote first.
(and (match-end 2)
(org-trim
(buffer-substring-no-properties
(match-end 0) (1- end))))))))))
;; Definition: also grab the last square bracket, matched in
;; `org-footnote-re' for non-inline footnotes.
((and (save-excursion
(forward-line 0)
(save-match-data (org-footnote-in-valid-context-p)))
(save-excursion
(end-of-line)
;; Footnotes definitions are separated by new
;; headlines, another footnote definition or 2 blank
;; lines.
(let ((end (match-end 0))
(lim (save-excursion
(re-search-backward
(concat org-outline-regexp-bol
"\\|^\\([ \t]*\n\\)\\{2,\\}")
nil t))))
(and (re-search-backward org-footnote-definition-re lim t)
(throw 'exit
(list nil
(match-beginning 0)
(if (eq (char-before end) ?\]) end
(1+ end)))))))))
(t nil))))))
(defun org-footnote-goto-definition (label &optional location)
"Move point to the definition of the footnote LABEL.
LOCATION, when non-nil specifies the buffer position of the
definition.
Throw an error if there is no definition or if it cannot be
reached from current narrowed part of buffer. Return a non-nil
value if point was successfully moved."
(interactive "sLabel: ")
(let* ((label (org-footnote-normalize-label label))
(def-start (or location (nth 1 (org-footnote-get-definition label)))))
(cond
((not def-start)
(user-error "Cannot find definition of footnote %s" label))
((or (> def-start (point-max)) (< def-start (point-min)))
(user-error "Definition is outside narrowed part of buffer")))
(org-mark-ring-push)
(goto-char def-start)
(looking-at (format "\\[fn:%s[]:]" (regexp-quote label)))
(goto-char (match-end 0))
(org-fold-show-context 'link-search)
(when (derived-mode-p 'org-mode)
(message "%s" (substitute-command-keys
"Edit definition and go back with \
`\\[org-mark-ring-goto]' or, if unique, with `\\[org-ctrl-c-ctrl-c]'.")))
t))
(defun org-footnote-goto-previous-reference (label)
"Find the first closest (to point) reference of footnote with label LABEL."
(interactive "sLabel: ")
(let* ((label (org-footnote-normalize-label label))
(reference
(save-excursion
(or (org-footnote-get-next-reference label t)
(org-footnote-get-next-reference label)
(and (buffer-narrowed-p)
(org-with-wide-buffer
(or (org-footnote-get-next-reference label t)
(org-footnote-get-next-reference label)))))))
(start (nth 1 reference)))
(cond ((not reference)
(user-error "Cannot find reference of footnote %S" label))
((or (> start (point-max)) (< start (point-min)))
(user-error "Reference is outside narrowed part of buffer")))
(org-mark-ring-push)
(goto-char start)
(org-fold-show-context 'link-search)))
;;;; Getters
(defun org-footnote-normalize-label (label)
"Return LABEL without \"fn:\" prefix.
If LABEL is the empty string or constituted of white spaces only,
return nil instead."
(pcase (org-trim label)
("" nil)
((pred (string-prefix-p "fn:")) (substring label 3))
(_ label)))
(defun org-footnote-get-definition (label)
"Return label, boundaries and definition of the footnote LABEL."
(let* ((label (regexp-quote (org-footnote-normalize-label label)))
(re (format "^\\[fn:%s\\]\\|.\\[fn:%s:" label label)))
(org-with-wide-buffer
(goto-char (point-min))
(catch 'found
(while (re-search-forward re nil t)
(let* ((datum (progn (backward-char) (org-element-context)))
(type (org-element-type datum)))
(when (memq type '(footnote-definition footnote-reference))
(throw 'found
(list
label
(org-element-property :begin datum)
(org-element-property :end datum)
(let ((cbeg (org-element-property :contents-begin datum)))
(if (not cbeg) ""
(replace-regexp-in-string
"[ \t\n]*\\'"
""
(buffer-substring-no-properties
cbeg
(org-element-property :contents-end datum))))))))))
nil))))
(defun org-footnote-all-labels ()
"List all defined footnote labels used throughout the buffer.
This function ignores narrowing, if any."
(org-with-wide-buffer
(goto-char (point-min))
(let (all)
(while (re-search-forward org-footnote-re nil t)
(backward-char)
(let ((context (org-element-context)))
(when (org-element-type-p
context '(footnote-definition footnote-reference))
(let ((label (org-element-property :label context)))
(when label (cl-pushnew label all :test #'equal))))))
all)))
(defun org-footnote-unique-label (&optional current)
"Return a new unique footnote label.
The function returns the first numeric label currently unused.
Optional argument CURRENT is the list of labels active in the
buffer."
(let ((current (or current (org-footnote-all-labels))))
(let ((count 1))
(while (member (number-to-string count) current)
(cl-incf count))
(number-to-string count))))
;;;; Adding, Deleting Footnotes
(defun org-footnote-new ()
"Insert a new footnote.
This command prompts for a label. If this is a label referencing an
existing label, only insert the label. If the footnote label is empty
or new, let the user edit the definition of the footnote."
(interactive)
(unless (org-footnote--allow-reference-p)
(user-error "Cannot insert a footnote here"))
(let* ((all (org-footnote-all-labels))
(label
(unless (eq org-footnote-auto-label 'anonymous)
(if (eq org-footnote-auto-label 'random)
(format "%x" (abs (random)))
(org-footnote-normalize-label
(let ((propose (org-footnote-unique-label all)))
(if (eq org-footnote-auto-label t) propose
(completing-read
"Label (leave empty for anonymous): "
(mapcar #'list all) nil nil
(and (eq org-footnote-auto-label 'confirm) propose)))))))))
(cond ((not label)
(insert "[fn::]")
(backward-char 1))
((member label all)
(insert "[fn:" label "]")
(message "New reference to existing note"))
(org-footnote-define-inline
(insert "[fn:" label ":]")
(backward-char 1)
(org-footnote-auto-adjust-maybe))
(t
(insert "[fn:" label "]")
(let ((p (org-footnote-create-definition label)))
;; `org-footnote-goto-definition' needs to be called
;; after `org-footnote-auto-adjust-maybe'. Otherwise
;; both label and location of the definition are lost.
;; On the contrary, it needs to be called before
;; `org-edit-footnote-reference' so that the remote
;; editing buffer can display the correct label.
(if (ignore-errors (org-footnote-goto-definition label p))
(org-footnote-auto-adjust-maybe)
;; Definition was created outside current scope: edit
;; it remotely.
(org-footnote-auto-adjust-maybe)
(org-edit-footnote-reference)))))))
(defun org-footnote-create-definition (label)
"Start the definition of a footnote with label LABEL.
Return buffer position at the beginning of the definition. This
function doesn't move point."
(let ((label (org-footnote-normalize-label label))
electric-indent-mode) ; Prevent wrong indentation.
(org-preserve-local-variables
(org-with-wide-buffer
(cond
((not org-footnote-section) (org-footnote--goto-local-insertion-point))
((save-excursion
(goto-char (point-min))
(re-search-forward
(concat "^\\*+[ \t]+" (regexp-quote org-footnote-section) "[ \t]*$")
nil t))
(goto-char (match-end 0))
(org-end-of-meta-data t)
(unless (bolp) (insert "\n")))
(t (org-footnote--clear-footnote-section)))
(when (zerop (org-back-over-empty-lines)) (insert "\n"))
(insert "[fn:" label "] \n")
(line-beginning-position 0)))))
(defun org-footnote-delete-references (label)
"Delete every reference to footnote LABEL.
Return the number of footnotes removed."
(save-excursion
(goto-char (point-min))
(let (ref (nref 0))
(while (setq ref (org-footnote-get-next-reference label))
(goto-char (nth 1 ref))
(delete-region (nth 1 ref) (nth 2 ref))
(cl-incf nref))
nref)))
(defun org-footnote-delete-definitions (label)
"Delete every definition of the footnote LABEL.
Return the number of footnotes removed."
(save-excursion
(goto-char (point-min))
(let ((def-re (format "^\\[fn:%s\\]" (regexp-quote label)))
(ndef 0))
(while (re-search-forward def-re nil t)
(pcase (org-footnote-at-definition-p)
(`(,_ ,start ,end ,_)
;; Remove the footnote, and all blank lines before it.
(delete-region (progn
(goto-char start)
(skip-chars-backward " \r\t\n")
(if (bobp) (point) (line-beginning-position 2)))
(progn
(goto-char end)
(skip-chars-backward " \r\t\n")
(if (bobp) (point) (line-beginning-position 2))))
(cl-incf ndef))))
ndef)))
(defun org-footnote-delete (&optional label)
"Delete the footnote at point.
This will remove the definition (even multiple definitions if they exist)
and all references of a footnote label.
If LABEL is non-nil, delete that footnote instead."
(catch 'done
(org-preserve-local-variables
(let* ((nref 0) (ndef 0) x
;; 1. Determine LABEL of footnote at point.
(label (cond
;; LABEL is provided as argument.
(label)
;; Footnote reference at point. If the footnote is
;; anonymous, delete it and exit instead.
((setq x (org-footnote-at-reference-p))
(or (car x)
(progn
(delete-region (nth 1 x) (nth 2 x))
(message "Anonymous footnote removed")
(throw 'done t))))
;; Footnote definition at point.
((setq x (org-footnote-at-definition-p))
(car x))
(t (error "Don't know which footnote to remove")))))
;; 2. Now that LABEL is non-nil, find every reference and every
;; definition, and delete them.
(setq nref (org-footnote-delete-references label)
ndef (org-footnote-delete-definitions label))
;; 3. Verify consistency of footnotes and notify user.
(org-footnote-auto-adjust-maybe)
(message "%d definition(s) of and %d reference(s) of footnote %s removed"
ndef nref label)))))
;;;; Sorting, Renumbering, Normalizing
(defun org-footnote-renumber-fn:N ()
"Order numbered footnotes into a sequence in the document."
(interactive)
(let* ((c 0)
(references (cl-remove-if-not
(lambda (r) (string-match-p "\\`[0-9]+\\'" (car r)))
(org-footnote--collect-references)))
(alist (mapcar (lambda (l) (cons l (number-to-string (cl-incf c))))
(delete-dups (mapcar #'car references)))))
(org-with-wide-buffer
;; Re-number references.
(dolist (ref references)
(goto-char (nth 1 ref))
(org-footnote--set-label (cdr (assoc (nth 0 ref) alist))))
;; Re-number definitions.
(goto-char (point-min))
(while (re-search-forward "^\\[fn:\\([0-9]+\\)\\]" nil t)
(replace-match (or (cdr (assoc (match-string 1) alist))
;; Un-referenced definitions get higher
;; numbers.
(number-to-string (cl-incf c)))
nil nil nil 1)))))
(defun org-footnote-sort ()
"Rearrange footnote definitions in the current buffer.
Sort footnote definitions so they match order of footnote
references. Also relocate definitions at the end of their
relative section or within a single footnote section, according
to `org-footnote-section'. Inline definitions are ignored."
(let ((references (org-footnote--collect-references)))
(org-preserve-local-variables
(let ((definitions (org-footnote--collect-definitions 'delete)))
(org-with-wide-buffer
(org-footnote--clear-footnote-section)
;; Insert footnote definitions at the appropriate location,
;; separated by a blank line. Each definition is inserted
;; only once throughout the buffer.
(let (inserted)
(dolist (cell references)
(let ((label (car cell))
(nested (not (nth 2 cell)))
(inline (nth 3 cell)))
(unless (or (member label inserted) inline)
(push label inserted)
(unless (or org-footnote-section nested)
;; If `org-footnote-section' is non-nil, or
;; reference is nested, point is already at the
;; correct position. Otherwise, move at the
;; appropriate location within the section
;; containing the reference.
(goto-char (nth 1 cell))
(org-footnote--goto-local-insertion-point))
(insert "\n"
(or (cdr (assoc label definitions))
(format "[fn:%s] DEFINITION NOT FOUND." label))
"\n"))))
;; Insert un-referenced footnote definitions at the end.
;; Combine all insertions into one to create a single cache
;; update call.
(org-combine-change-calls (point) (point)
(pcase-dolist (`(,label . ,definition) definitions)
(unless (member label inserted)
(insert "\n" definition "\n"))))))))))
(defun org-footnote-normalize ()
"Turn every footnote in buffer into a numbered one."
(interactive)
(org-preserve-local-variables
(let ((n 0)
(translations nil)
(definitions nil)
(references (org-footnote--collect-references 'anonymous)))
(org-with-wide-buffer
;; Update label for reference. We need to do this before
;; clearing definitions in order to rename nested footnotes
;; before they are deleted.
(dolist (cell references)
(let* ((label (car cell))
(anonymous (not label))
(new
(cond
;; In order to differentiate anonymous references
;; from regular ones, set their labels to integers,
;; not strings.
(anonymous (setcar cell (cl-incf n)))
((cdr (assoc label translations)))
(t (let ((l (number-to-string (cl-incf n))))
(push (cons label l) translations)
l)))))
(goto-char (nth 1 cell)) ; Move to reference's start.
(org-footnote--set-label
(if anonymous (number-to-string new) new))
(let ((size (nth 3 cell)))
;; Transform inline footnotes into regular references and
;; retain their definition for later insertion as
;; a regular footnote definition.
(when size
(let ((def (concat
(format "[fn:%s] " new)
(org-trim
(substring
(delete-and-extract-region
(point) (+ (point) size 1))
1)))))
(push (cons (if anonymous new label) def) definitions)
(when org-footnote-fill-after-inline-note-extraction
(org-fill-paragraph)))))))
;; Collect definitions. Update labels according to ALIST.
(let ((definitions
(nconc definitions
(org-footnote--collect-definitions 'delete)))
(inserted))
(org-footnote--clear-footnote-section)
(dolist (cell references)
(let* ((label (car cell))
(anonymous (integerp label))
(pos (nth 1 cell)))
;; Move to appropriate location, if required. When there
;; is a footnote section or reference is nested, point is
;; already at the expected location.
(unless (or org-footnote-section (not (nth 2 cell)))
(goto-char pos)
(org-footnote--goto-local-insertion-point))
;; Insert new definition once label is updated.
(unless (member label inserted)
(push label inserted)
(let ((stored (cdr (assoc label definitions)))
;; Anonymous footnotes' label is already
;; up-to-date.
(new (if anonymous label
(cdr (assoc label translations)))))
(insert "\n"
(cond
((not stored)
(format "[fn:%s] DEFINITION NOT FOUND." new))
(anonymous stored)
(t
(replace-regexp-in-string
"\\`\\[fn:\\(.*?\\)\\]" new stored nil nil 1)))
"\n")))))
;; Insert un-referenced footnote definitions at the end.
(pcase-dolist (`(,label . ,definition) definitions)
(unless (member label inserted)
(insert "\n"
(replace-regexp-in-string org-footnote-definition-re
(format "[fn:%d]" (cl-incf n))
definition)
"\n"))))))))
(defun org-footnote-auto-adjust-maybe ()
"Renumber and/or sort footnotes according to user settings."
(when (memq org-footnote-auto-adjust '(t renumber))
(org-footnote-renumber-fn:N))
(when (memq org-footnote-auto-adjust '(t sort))
(let ((label (car (org-footnote-at-definition-p))))
(org-footnote-sort)
(when label
(goto-char (point-min))
(and (re-search-forward (format "^\\[fn:%s\\]" (regexp-quote label))
nil t)
(progn (insert " ")
(just-one-space)))))))
;;;; End-user interface
;;;###autoload
(defun org-footnote-action (&optional special)
"Do the right thing for footnotes.
When at a footnote reference, jump to the definition.
When at a definition, jump to the references if they exist, offer
to create them otherwise.
When neither at definition or reference, create a new footnote,
interactively if possible.
With prefix arg SPECIAL, or when no footnote can be created,
offer additional commands in a menu."
(interactive "P")
(let* ((context (and (not special) (org-element-context)))
(type (org-element-type context)))
(cond
;; On white space after element, insert a new footnote.
((and context
(> (point)
(save-excursion
(goto-char (org-element-property :end context))
(skip-chars-backward " \t")
(point))))
(org-footnote-new))
((eq type 'footnote-reference)
(let ((label (org-element-property :label context)))
(cond
;; Anonymous footnote: move point at the beginning of its
;; definition.
((not label)
(goto-char (org-element-property :contents-begin context)))
;; Check if a definition exists: then move to it.
((let ((p (nth 1 (org-footnote-get-definition label))))
(when p (org-footnote-goto-definition label p))))
;; No definition exists: offer to create it.
((yes-or-no-p (format "No definition for %s. Create one? " label))
(let ((p (org-footnote-create-definition label)))
(or (ignore-errors (org-footnote-goto-definition label p))
;; Since definition was created outside current scope,
;; edit it remotely.
(org-edit-footnote-reference)))))))
((eq type 'footnote-definition)
(org-footnote-goto-previous-reference
(org-element-property :label context)))
((or special (not (org-footnote--allow-reference-p)))
(message "Footnotes: [s]ort | [r]enumber fn:N | [S]=r+s | [n]ormalize | \
\[d]elete")
(pcase (read-char-exclusive)
(?s (org-footnote-sort))
(?r (org-footnote-renumber-fn:N))
(?S (org-footnote-renumber-fn:N)
(org-footnote-sort))
(?n (org-footnote-normalize))
(?d (org-footnote-delete))
(char (error "No such footnote command %c" char))))
(t (org-footnote-new)))))
(provide 'org-footnote)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; org-footnote.el ends here
org-mode-9.7.29+dfsg/lisp/org-goto.el 0000664 0000000 0000000 00000024376 15004304337 0017313 0 ustar 00root root 0000000 0000000 ;;; org-goto.el --- Fast navigation in an Org buffer -*- lexical-binding: t; -*-
;; Copyright (C) 2012-2025 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
;; Keywords: outlines, hypermedia, calendar, text
;; 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'org)
(require 'org-refile)
(defvar org-goto-exit-command nil)
(defvar org-goto-map nil)
(defvar org-goto-marker nil)
(defvar org-goto-selected-point nil)
(defvar org-goto-start-pos nil)
(defvar org-goto-window-configuration nil)
(defconst org-goto-local-auto-isearch-map (make-sparse-keymap))
(set-keymap-parent org-goto-local-auto-isearch-map isearch-mode-map)
(defconst org-goto-help
"Browse buffer copy, to find location or copy text.%s
RET=jump to location C-g=quit and return to previous location
\[Up]/[Down]=next/prev headline TAB=cycle visibility [/] org-occur")
;;; Customization
(defgroup org-goto nil
"Options concerning Org Goto navigation interface."
:tag "Org Goto"
:group 'org)
(defcustom org-goto-interface 'outline
"The default interface to be used for `org-goto'.
Allowed values are:
`outline'
The interface shows an outline of the relevant file and the
correct heading is found by moving through the outline or by
searching with incremental search.
`outline-path-completion'
Headlines in the current buffer are offered via completion.
This is the interface also used by the refile command."
:group 'org-goto
:type '(choice
(const :tag "Outline" outline)
(const :tag "Outline-path-completion" outline-path-completion)))
(defcustom org-goto-max-level 5
"Maximum target level when running `org-goto' with refile interface."
:group 'org-goto
:type 'integer)
(defcustom org-goto-auto-isearch t
"Non-nil means typing characters in `org-goto' starts incremental search.
When nil, you can use these keybindings to navigate the buffer:
q Quit the Org Goto interface
n Go to the next visible heading
p Go to the previous visible heading
f Go one heading forward on same level
b Go one heading backward on same level
u Go one heading up"
:group 'org-goto
:type 'boolean)
;;; Internal functions
(defun org-goto--set-map ()
"Set the keymap `org-goto'."
(setq org-goto-map
(let ((map (make-sparse-keymap)))
(let ((cmds '(isearch-forward isearch-backward kill-ring-save set-mark-command
mouse-drag-region universal-argument org-occur)))
(dolist (cmd cmds)
(substitute-key-definition cmd cmd map global-map)))
(if org-goto-auto-isearch
;; Suppress 0-9 interpreted as digital arguments.
;; Make them initiate isearch instead.
(suppress-keymap map t)
(suppress-keymap map))
(org-defkey map "\C-m" 'org-goto-ret)
(org-defkey map [(return)] 'org-goto-ret)
(org-defkey map [(left)] 'org-goto-left)
(org-defkey map [(right)] 'org-goto-right)
(org-defkey map [(control ?g)] 'org-goto-quit)
(org-defkey map "\C-i" 'org-cycle)
(org-defkey map [(tab)] 'org-cycle)
(org-defkey map [(down)] 'outline-next-visible-heading)
(org-defkey map [(up)] 'outline-previous-visible-heading)
(if org-goto-auto-isearch
(define-key-after map [t] 'org-goto-local-auto-isearch)
(org-defkey map "q" 'org-goto-quit)
(org-defkey map "n" 'outline-next-visible-heading)
(org-defkey map "p" 'outline-previous-visible-heading)
(org-defkey map "f" 'outline-forward-same-level)
(org-defkey map "b" 'outline-backward-same-level)
(org-defkey map "u" 'outline-up-heading))
(org-defkey map "/" 'org-occur)
(org-defkey map "\C-c\C-n" 'outline-next-visible-heading)
(org-defkey map "\C-c\C-p" 'outline-previous-visible-heading)
(org-defkey map "\C-c\C-f" 'outline-forward-same-level)
(org-defkey map "\C-c\C-b" 'outline-backward-same-level)
(org-defkey map "\C-c\C-u" 'outline-up-heading)
map)))
;; `isearch-other-control-char' was removed in Emacs 24.4.
(if (fboundp 'isearch-other-control-char)
(progn
(define-key org-goto-local-auto-isearch-map "\C-i" 'isearch-other-control-char)
(define-key org-goto-local-auto-isearch-map "\C-m" 'isearch-other-control-char))
(define-key org-goto-local-auto-isearch-map "\C-i" nil)
(define-key org-goto-local-auto-isearch-map "\C-m" nil)
(define-key org-goto-local-auto-isearch-map [return] nil))
(defun org-goto--local-search-headings (string bound noerror)
"Search and make sure that any matches are in headlines."
(catch 'return
(while (if isearch-forward
(search-forward string bound noerror)
(search-backward string bound noerror))
(when (save-match-data
(and (save-excursion
(forward-line 0)
(looking-at org-complex-heading-regexp))
(or (not (match-beginning 5))
(< (point) (match-beginning 5)))))
(throw 'return (point))))))
(defun org-goto-local-auto-isearch ()
"Start isearch."
(interactive)
(let ((keys (this-command-keys)))
(when (eq (lookup-key isearch-mode-map keys) 'isearch-printing-char)
(isearch-mode t)
(isearch-process-search-char (string-to-char keys))
(font-lock-ensure))))
(defun org-goto-ret (&optional _arg)
"Finish `org-goto' by going to the new location."
(interactive "P")
(setq org-goto-selected-point (point))
(setq org-goto-exit-command 'return)
(throw 'exit nil))
(defun org-goto-left ()
"Finish `org-goto' by going to the new location."
(interactive)
(if (org-at-heading-p)
(progn
(forward-line 0)
(setq org-goto-selected-point (point)
org-goto-exit-command 'left)
(throw 'exit nil))
(user-error "Not on a heading")))
(defun org-goto-right ()
"Finish `org-goto' by going to the new location."
(interactive)
(if (org-at-heading-p)
(progn
(setq org-goto-selected-point (point)
org-goto-exit-command 'right)
(throw 'exit nil))
(user-error "Not on a heading")))
(defun org-goto-quit ()
"Finish `org-goto' without cursor motion."
(interactive)
(setq org-goto-selected-point nil)
(setq org-goto-exit-command 'quit)
(throw 'exit nil))
;;; Public API
;;;###autoload
(defun org-goto-location (&optional _buf help)
"Let the user select a location in current buffer.
This function uses a recursive edit. It returns the selected
position or nil."
(let ((isearch-mode-map org-goto-local-auto-isearch-map)
(isearch-hide-immediately nil)
(isearch-search-fun-function
(lambda () #'org-goto--local-search-headings))
(help (or help org-goto-help)))
(save-excursion
(save-window-excursion
(and (get-buffer "*org-goto*") (kill-buffer "*org-goto*"))
(pop-to-buffer
(condition-case nil
(make-indirect-buffer (current-buffer) "*org-goto*" t)
(error (make-indirect-buffer (current-buffer) "*org-goto*" t)))
'(org-display-buffer-full-frame))
(let (temp-buffer-show-function temp-buffer-show-hook)
(with-output-to-temp-buffer "*Org Help*"
(princ (format help (if org-goto-auto-isearch
" Just type for auto-isearch."
" n/p/f/b/u to navigate, q to quit.")))))
(org-fit-window-to-buffer (get-buffer-window "*Org Help*"))
(org-cycle-overview)
(setq buffer-read-only t)
(if (and (boundp 'org-goto-start-pos)
(integer-or-marker-p org-goto-start-pos))
(progn (goto-char org-goto-start-pos)
(when (org-invisible-p)
(org-fold-show-set-visibility 'lineage)))
(goto-char (point-min)))
(let (org-special-ctrl-a/e) (org-beginning-of-line))
(message "Select location and press RET")
(use-local-map org-goto-map)
(unwind-protect (recursive-edit)
(when-let* ((window (get-buffer-window "*Org Help*" t)))
(quit-window 'kill window)))))
(when (get-buffer "*org-goto*") (kill-buffer "*org-goto*"))
(cons org-goto-selected-point org-goto-exit-command)))
;;;###autoload
(defun org-goto (&optional alternative-interface)
"Look up a different location in the current file, keeping current visibility.
When you want look-up or go to a different location in a
document, the fastest way is often to fold the entire buffer and
then dive into the tree. This method has the disadvantage, that
the previous location will be folded, which may not be what you
want.
This command works around this by showing a copy of the current
buffer in an indirect buffer, in overview mode. You can dive
into the tree in that copy, use `org-occur' and incremental search
to find a location. When pressing RET or `Q', the command
returns to the original buffer in which the visibility is still
unchanged. After RET it will also jump to the location selected
in the indirect buffer and expose the headline hierarchy above.
With a prefix argument, use the alternative interface: e.g., if
`org-goto-interface' is `outline' use `outline-path-completion'."
(interactive "P")
(org-goto--set-map)
(let* ((org-refile-targets `((nil . (:maxlevel . ,org-goto-max-level))))
(org-refile-use-outline-path t)
(org-refile-target-verify-function nil)
(interface
(if (not alternative-interface)
org-goto-interface
(if (eq org-goto-interface 'outline)
'outline-path-completion
'outline)))
(org-goto-start-pos (point))
(selected-point
(if (eq interface 'outline) (car (org-goto-location))
(let ((pa (org-refile-get-location "Goto")))
(org-refile-check-position pa)
(nth 3 pa)))))
(if selected-point
(progn
(org-mark-ring-push org-goto-start-pos)
(goto-char selected-point)
(when (or (org-invisible-p) (org-invisible-p2))
(org-fold-show-context 'org-goto)))
(message "Quit"))))
(provide 'org-goto)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; org-goto.el ends here
org-mode-9.7.29+dfsg/lisp/org-habit.el 0000664 0000000 0000000 00000042166 15004304337 0017427 0 ustar 00root root 0000000 0000000 ;;; org-habit.el --- The habit tracking code for Org -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2025 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw at gnu dot org>
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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 <https://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;; This file contains the habit tracking code for Org mode
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'cl-lib)
(require 'org)
(require 'org-agenda)
(defgroup org-habit nil
"Options concerning habit tracking in Org mode."
:tag "Org Habit"
:group 'org-progress)
(defcustom org-habit-graph-column 40
"The absolute column at which to insert habit consistency graphs.
Note that consistency graphs will overwrite anything else in the buffer."
:group 'org-habit
:type 'integer)
(defcustom org-habit-preceding-days 21
"Number of days before today to appear in consistency graphs."
:group 'org-habit
:type 'integer)
(defcustom org-habit-following-days 7
"Number of days after today to appear in consistency graphs."
:group 'org-habit
:type 'integer)
(defcustom org-habit-show-habits t
"If non-nil, show habits in agenda buffers."
:group 'org-habit
:type 'boolean)
(defcustom org-habit-show-habits-only-for-today t
"If non-nil, only show habits on today's agenda, and not for future days.
Note that even when shown for future days, the graph is always
relative to the current effective date."
:group 'org-habit
:type 'boolean)
(defcustom org-habit-show-all-today nil
"If non-nil, show the consistency graph of all habits on
today's agenda, even if they are not scheduled."
:group 'org-habit
:type 'boolean)
(defcustom org-habit-today-glyph ?!
"Glyph character used to identify today."
:group 'org-habit
:version "24.1"
:type 'character)
(defcustom org-habit-completed-glyph ?*
"Glyph character used to show completed days on which a task was done."
:group 'org-habit
:version "24.1"
:type 'character)
(defcustom org-habit-show-done-always-green nil
"Non-nil means DONE days will always be green in the consistency graph.
It will be green even if it was done after the deadline."
:group 'org-habit
:type 'boolean)
(defcustom org-habit-scheduled-past-days nil
"Value to use instead of `org-scheduled-past-days', for habits only.
If nil, `org-scheduled-past-days' is used.
Setting this to say 10000 is a way to make habits always show up
as a reminder, even if you set `org-scheduled-past-days' to a
small value because you regard scheduled items as a way of
\"turning on\" TODO items on a particular date, rather than as a
means of creating calendar-based reminders."
:group 'org-habit
:type '(choice integer (const nil))
:package-version '(Org . "9.3")
:safe (lambda (v) (or (integerp v) (null v))))
(defface org-habit-clear-face
'((((background light)) (:background "#8270f9"))
(((background dark)) (:background "blue")))
"Face for days on which a task shouldn't be done yet."
:group 'org-habit
:group 'org-faces)
(defface org-habit-clear-future-face
'((((background light)) (:background "#d6e4fc"))
(((background dark)) (:background "midnightblue")))
"Face for future days on which a task shouldn't be done yet."
:group 'org-habit
:group 'org-faces)
(defface org-habit-ready-face
'((((background light)) (:background "#4df946"))
(((background dark)) (:background "forestgreen")))
"Face for days on which a task should start to be done."
:group 'org-habit
:group 'org-faces)
(defface org-habit-ready-future-face
'((((background light)) (:background "#acfca9"))
(((background dark)) (:background "darkgreen")))
"Face for days on which a task should start to be done."
:group 'org-habit
:group 'org-faces)
(defface org-habit-alert-face
'((((background light)) (:background "#f5f946"))
(((background dark)) (:background "gold")))
"Face for days on which a task is due."
:group 'org-habit
:group 'org-faces)
(defface org-habit-alert-future-face
'((((background light)) (:background "#fafca9"))
(((background dark)) (:background "darkgoldenrod")))
"Face for days on which a task is due."
:group 'org-habit
:group 'org-faces)
(defface org-habit-overdue-face
'((((background light)) (:background "#f9372d"))
(((background dark)) (:background "firebrick")))
"Face for days on which a task is overdue."
:group 'org-habit
:group 'org-faces)
(defface org-habit-overdue-future-face
'((((background light)) (:background "#fc9590"))
(((background dark)) (:background "darkred")))
"Face for days on which a task is overdue."
:group 'org-habit
:group 'org-faces)
(defun org-habit-duration-to-days (ts)
(if (string-match "\\([0-9]+\\)\\([dwmy]\\)" ts)
;; lead time is specified.
(floor (* (string-to-number (match-string 1 ts))
(cdr (assoc (match-string 2 ts)
'(("d" . 1) ("w" . 7)
("m" . 30.4) ("y" . 365.25))))))
(error "Invalid duration string: %s" ts)))
(defun org-is-habit-p (&optional epom)
"Is the task at EPOM or point a habit?
EPOM is an element, marker, or buffer position."
(string= "habit" (org-entry-get epom "STYLE" 'selective)))
(defun org-habit-parse-todo (&optional pom)
"Parse the TODO surrounding point for its habit-related data.
Returns a list with the following elements:
0: Scheduled date for the habit (may be in the past)
1: \".+\"-style repeater for the schedule, in days
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))
(cl-assert (org-is-habit-p (point)))
(let* ((scheduled (org-get-scheduled-time (point)))
(scheduled-repeat (org-get-repeat (org-entry-get (point) "SCHEDULED")))
(end (org-entry-end-position))
(habit-entry (org-no-properties (nth 4 (org-heading-components))))
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))
(unless scheduled-repeat
(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)
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)
(setq dr-days (org-habit-duration-to-days
(match-string-no-properties 1 scheduled-repeat)))
(if (<= dr-days sr-days)
(error "Habit %s deadline repeat period is less than or equal to scheduled (%s)"
habit-entry scheduled-repeat))
(setq deadline (+ scheduled (- dr-days sr-days))))
(org-back-to-heading t)
(let* ((maxdays (+ org-habit-preceding-days org-habit-following-days))
(reversed org-log-states-order-reversed)
(search (if reversed 're-search-forward 're-search-backward))
(limit (if reversed end (point)))
(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 re limit t))
(push (time-to-days
(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 sr-type))))
(defsubst org-habit-scheduled (habit)
(nth 0 habit))
(defsubst org-habit-scheduled-repeat (habit)
(nth 1 habit))
(defsubst org-habit-deadline (habit)
(let ((deadline (nth 2 habit)))
(or deadline
(if (nth 3 habit)
(+ (org-habit-scheduled habit)
(1- (org-habit-scheduled-repeat habit)))
(org-habit-scheduled habit)))))
(defsubst org-habit-deadline-repeat (habit)
(or (nth 3 habit)
(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-urgency (habit &optional moment)
"Determine the relative urgency of a habit.
This must take into account not just urgency, but consistency as well."
(let ((pri 1000)
(now (if moment (time-to-days moment) (org-today)))
(scheduled (org-habit-scheduled habit))
(deadline (org-habit-deadline habit)))
;; add 10 for every day past the scheduled date, and subtract for every
;; day before it
(setq pri (+ pri (* (- now scheduled) 10)))
;; add 50 if the deadline is today
(if (and (/= scheduled deadline)
(= now deadline))
(setq pri (+ pri 50)))
;; add 100 for every day beyond the deadline date, and subtract 10 for
;; every day before it
(let ((slip (- now (1- deadline))))
(if (> slip 0)
(setq pri (+ pri (* slip 100)))
(setq pri (+ pri (* slip 10)))))
pri))
(defun org-habit-get-faces (habit &optional now-days scheduled-days donep)
"Return faces for HABIT relative to NOW-DAYS and SCHEDULED-DAYS.
NOW-DAYS defaults to the current time's days-past-the-epoch if nil.
SCHEDULED-DAYS defaults to the habit's actual scheduled days if nil.
Habits are assigned colors on the following basis:
Blue Task is before the scheduled date.
Green Task is on or after scheduled date, but before the
end of the schedule's repeat period.
Yellow If the task has a deadline, then it is after schedule's
repeat period, but before the deadline.
Orange The task has reached the deadline day, or if there is
no deadline, the end of the schedule's repeat period.
Red The task has gone beyond the deadline day or the
schedule's repeat period."
(let* ((scheduled (or scheduled-days (org-habit-scheduled habit)))
(s-repeat (org-habit-scheduled-repeat habit))
(d-repeat (org-habit-deadline-repeat habit))
(deadline (if scheduled-days
(+ scheduled-days (- d-repeat s-repeat))
(org-habit-deadline habit)))
(m-days (or now-days (time-to-days nil))))
(cond
((< m-days scheduled)
'(org-habit-clear-face . org-habit-clear-future-face))
((< m-days deadline)
'(org-habit-ready-face . org-habit-ready-future-face))
((= m-days deadline)
(if donep
'(org-habit-ready-face . org-habit-ready-future-face)
'(org-habit-alert-face . org-habit-alert-future-face)))
((and org-habit-show-done-always-green donep)
'(org-habit-ready-face . org-habit-ready-future-face))
(t '(org-habit-overdue-face . org-habit-overdue-future-face)))))
(defun org-habit-build-graph (habit starting current ending)
"Build a graph for the given HABIT, from STARTING to ENDING.
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* ((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)) ?\s))
(index 0)
last-done-date)
(while (and done-dates (< (car done-dates) start))
(setq last-done-date (car done-dates)
done-dates (cdr done-dates)))
(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)))
(if (and all-done-dates (= (car all-done-dates) start))
;; This is the very first done of this habit.
'(org-habit-ready-face . org-habit-ready-future-face)
'(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)
(cond
(donep
(aset graph index org-habit-completed-glyph)
(setq markedp t)
(while (and done-dates (= start (car done-dates)))
(setq last-done-date (car done-dates))
(setq done-dates (cdr done-dates))))
(todayp
(aset graph index org-habit-today-glyph)))
(setq face (if (or in-the-past-p todayp)
(car faces)
(cdr faces)))
(when (and in-the-past-p
(not (eq face 'org-habit-overdue-face))
(not markedp))
(setq face (cdr faces)))
(put-text-property index (1+ index) 'face face graph)
(put-text-property index (1+ index)
'help-echo
(concat (format-time-string
(org-time-stamp-format)
(time-add starting (days-to-time (- start (time-to-days starting)))))
(if donep " DONE" ""))
graph))
(setq start (1+ start)
index (1+ index)))
graph))
(defun org-habit-insert-consistency-graphs (&optional line)
"Insert consistency graph for any habitual tasks."
(let ((inhibit-read-only t)
(buffer-invisibility-spec '(org-link))
(moment (time-subtract nil (* 3600 org-extend-today-until))))
(save-excursion
(goto-char (if line (line-beginning-position) (point-min)))
(while (not (eobp))
(let ((habit (get-text-property (point) 'org-habit-p))
(invisible-prop (get-text-property (point) 'invisible)))
(when habit
(move-to-column org-habit-graph-column t)
(delete-char (min (+ 1 org-habit-preceding-days
org-habit-following-days)
(- (line-end-position) (point))))
(insert-before-markers
(org-habit-build-graph
habit
(time-subtract moment (days-to-time org-habit-preceding-days))
moment
(time-add moment (days-to-time org-habit-following-days))))
;; Inherit invisible state of hidden entries.
(when invisible-prop
(put-text-property
(- (point) org-habit-graph-column) (point)
'invisible invisible-prop))))
(forward-line)))))
(defun org-habit-toggle-habits ()
"Toggle display of habits in an agenda buffer."
(interactive)
(org-agenda-check-type t 'agenda)
(setq org-habit-show-habits (not org-habit-show-habits))
(org-agenda-redo)
(org-agenda-set-mode-name)
(message "Habits turned %s"
(if org-habit-show-habits "on" "off")))
(defun org-habit-toggle-display-in-agenda (arg)
"Toggle display of habits in agenda.
With ARG toggle display of all vs. undone scheduled habits.
See `org-habit-show-all-today'."
(interactive "P")
(if (not arg)
(org-habit-toggle-habits)
(org-agenda-check-type t 'agenda)
(setq org-habit-show-all-today (not org-habit-show-all-today))
(when org-habit-show-habits (org-agenda-redo))))
(org-defkey org-agenda-mode-map "K" 'org-habit-toggle-display-in-agenda)
(provide 'org-habit)
;;; org-habit.el ends here
org-mode-9.7.29+dfsg/lisp/org-id.el 0000664 0000000 0000000 00000101472 15004304337 0016730 0 ustar 00root root 0000000 0000000 ;;; org-id.el --- Global identifiers for Org entries -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2008-2025 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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 <https://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;; 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.
;; Identifiers consist of a prefix (given by the variable
;; `org-id-prefix') and a unique part that can be created by a number
;; of different methods, see the variable `org-id-method'. Org has a
;; builtin method that uses a compact encoding of the creation time of
;; the ID, with microsecond accuracy. This virtually guarantees
;; globally unique identifiers, even if several people are creating
;; IDs at the same time in files that will eventually be used
;; together.
;;
;; By default Org uses UUIDs as global unique identifiers.
;;
;; This file defines the following API:
;;
;; org-id-get-create
;; Create an ID for the entry at point if it does not yet have one.
;; Returns the ID (old or new). This function can be used
;; interactively, with prefix argument the creation of a new ID is
;; forced, even if there was an old one.
;;
;; org-id-get
;; Get the ID property of an entry. Using appropriate arguments
;; to the function, it can also create the ID for this entry.
;;
;; org-id-goto
;; Command to go to a specific ID, this command can be used
;; interactively.
;;
;; org-id-get-with-outline-path-completion
;; Retrieve the ID of an entry, using outline path completion.
;; This function can work for multiple files.
;;
;; org-id-get-with-outline-drilling
;; Retrieve the ID of an entry, using outline path completion.
;; This function only works for the current file.
;;
;; org-id-find
;; Find the location of an entry with specific id.
;;
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'org)
(require 'org-element-ast)
(require 'org-refile)
(require 'ol)
(declare-function message-make-fqdn "message" ())
(declare-function org-goto-location "org-goto" (&optional _buf help))
;; Declared inside `org-element-with-disabled-cache' macro.
(declare-function org-element--cache-active-p "org-element.el" (&optional called-from-cache-change-func-p))
;;; Customization
(defgroup org-id nil
"Options concerning global entry identifiers in Org mode."
:tag "Org ID"
:group 'org)
(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:
t Create an ID if needed to make a link to the current entry.
create-if-interactive
If `org-store-link' is called directly (interactively, as a user
command), do create an ID to support the link. But when doing the
job for capture, only use the ID if it already exists. The
purpose of this setting is to avoid proliferation of unwanted
IDs, just because you happen to be in an Org file when you
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 `\\[org-store-link]' first.
create-if-interactive-and-no-custom-id
Like create-if-interactive, but do not create an ID if there is
a CUSTOM_ID property defined in the entry.
use-existing
Use existing ID, do not create one.
nil Never use an ID to make a link, instead link using a text search for
the headline text."
:group 'org-link-store
:group 'org-id
:version "24.3"
:type '(choice
(const :tag "Create ID to make link" t)
(const :tag "Create if storing link interactively"
create-if-interactive)
(const :tag "Create if storing link interactively and no CUSTOM_ID is present"
create-if-interactive-and-no-custom-id)
(const :tag "Only use existing" use-existing)
(const :tag "Do not use ID to create link" nil)))
(defcustom org-id-link-consider-parent-id nil
"Non-nil means storing a link to an Org entry considers inherited IDs.
When this option is non-nil and `org-id-link-use-context' is
enabled, ID properties inherited from parent entries will be
considered when storing an ID link. If no ID is found in this
way, a new one may be created as normal (see
`org-id-link-to-org-use-id').
For example, given this org file:
* Parent
:PROPERTIES:
:ID: abc
:END:
** Child 1
** Child 2
With `org-id-link-consider-parent-id' and
`org-id-link-use-context' both enabled, storing a link with point
at \"Child 1\" will produce a link \"<id:abc::*Child 1>\". This
allows linking to uniquely-named sub-entries within a parent
entry with an ID, without requiring every sub-entry to have its
own ID."
:group 'org-link-store
:group 'org-id
:package-version '(Org . "9.7")
:type 'boolean)
(defcustom org-id-link-use-context t
"Non-nil means enables search string context in org-id links.
Search strings are added by `org-id-store-link' when both the
general option `org-link-context-for-files' and the org-id option
`org-id-link-use-context' are non-nil."
:group 'org-link-store
:group 'org-id
:package-version '(Org . "9.7")
:type 'boolean)
(defcustom org-id-uuid-program "uuidgen"
"The uuidgen program."
:group 'org-id
:type 'string)
(defcustom org-id-ts-format "%Y%m%dT%H%M%S.%6N"
"Timestamp format for IDs generated using `ts' `org-id-method'.
The format should be suitable to pass as an argument to `format-time-string'.
Defaults to ISO8601 timestamps without separators and without
timezone, local time and precision down to 1e-6 seconds."
:type 'string
:package-version '(Org . "9.5"))
(defcustom org-id-method 'uuid
"The method that should be used to create new IDs.
An ID will consist of the optional prefix specified in `org-id-prefix',
and a unique part created by the method this variable specifies.
Allowed values are:
org Org's own internal method, using an encoding of the current time to
microsecond accuracy, and optionally the current domain of the
computer. See the variable `org-id-include-domain'.
uuid Create random (version 4) UUIDs. If the program defined in
`org-id-uuid-program' is available it is used to create the ID.
Otherwise an internal functions is used.
ts Create ID's based on timestamps as specified in `org-id-ts-format'."
:group 'org-id
:type '(choice
(const :tag "Org's internal method" org)
(const :tag "external: uuidgen" uuid)
(const :tag "Timestamp with format `org-id-ts-format'" ts)))
(defcustom org-id-prefix nil
"The prefix for IDs.
This may be a string, or it can be nil to indicate that no prefix is required.
When a string, the string should have no space characters as IDs are expected
to have no space characters in them."
:group 'org-id
:type '(choice
(const :tag "No prefix")
(string :tag "Prefix")))
(defcustom org-id-include-domain nil
"Non-nil means add the domain name to new IDs.
This ensures global uniqueness of IDs, and is also suggested by
the relevant RFCs. This is relevant only if `org-id-method' is
`org' or `ts'. When uuidgen is used, the domain will never be added.
The default is to not use this because we have no really good way to get
the true domain, and Org entries will normally not be shared with enough
people to make this necessary."
:group 'org-id
:type 'boolean)
(defcustom org-id-track-globally t
"Non-nil means track IDs through files, so that links work globally.
This work by maintaining a hash table for IDs and writing this table
to disk when exiting Emacs. Because of this, it works best if you use
a single Emacs process, not many.
When nil, IDs are not tracked. Links to IDs will still work within
a buffer, but not if the entry is located in another file.
IDs can still be used if the entry with the id is in the same file as
the link."
:group 'org-id
:type 'boolean)
(defcustom org-id-locations-file (locate-user-emacs-file ".org-id-locations")
"The file for remembering in which file an ID was defined.
This variable is only relevant when `org-id-track-globally' is set."
:group 'org-id
:type 'file)
(defcustom org-id-locations-file-relative nil
"Determine if `org-id-locations' should be stored as relative links.
Non-nil means that links to locations are stored as links
relative to the location of where `org-id-locations-file' is
stored.
Nil means to store absolute paths to files.
This customization is useful when folders are shared across
systems but mounted at different roots. Relative path to
`org-id-locations-file' still has to be maintained across
systems."
:group 'org-id
:type 'boolean
:package-version '(Org . "9.3"))
(defvar org-id-locations nil
"List of files with IDs in those files.")
(defvar org-id--locations-checksum nil
"Last checksum corresponding to ID files and their modifications.")
(defvar org-id-files nil
"List of files that contain IDs.")
(defcustom org-id-extra-files 'org-agenda-text-search-extra-files
"Files to be searched for IDs, besides the agenda files.
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 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
:type
'(choice
(symbol :tag "Variable")
(repeat :tag "List of files"
(file))))
(defcustom org-id-search-archives t
"Non-nil means search also the archive files of agenda files for entries.
This is a possibility to reduce overhead, but it means that entries moved
to the archives can no longer be found by ID.
This variable is only relevant when `org-id-track-globally' is set."
:group 'org-id
:type 'boolean)
;;; The API functions
;;;###autoload
(defun org-id-get-create (&optional force)
"Create an ID for the current entry and return it.
If the entry already has an ID, just return it.
With optional argument FORCE, force the creation of a new ID."
(interactive "P")
(when force
(org-entry-put (point) "ID" nil))
(org-id-get (point) 'create))
;;;###autoload
(defun org-id-copy ()
"Copy the ID of the entry at point to the kill ring.
Create an ID if necessary."
(interactive)
(org-kill-new (org-id-get nil 'create)))
(defvar org-id-overriding-file-name nil
"Tell `org-id-get' to use this as the file name when creating an ID.
This is useful when working with contents in a temporary buffer
that will be copied back to the original.")
;;;###autoload
(defun org-id-get (&optional epom create prefix inherit)
"Get the ID of the entry at EPOM.
EPOM is an element, marker, or buffer position. If EPOM is nil,
refer to the entry at point.
If INHERIT is non-nil, ID properties inherited from parent
entries are considered. Otherwise, only ID properties on the
entry itself are considered.
When CREATE is nil, return the ID of the entry if found,
otherwise nil. When CREATE is non-nil, create an ID if none has
been found, and return the new ID. PREFIX will be passed through
to `org-id-new'."
(let ((id (org-entry-get epom "ID" (and inherit t))))
(cond
((and id (stringp id) (string-match "\\S-" id))
id)
(create
(setq id (org-id-new prefix))
(org-entry-put epom "ID" id)
(org-with-point-at epom
(org-id-add-location id
(or org-id-overriding-file-name
(buffer-file-name (buffer-base-buffer)))))
id))))
;;;###autoload
(defun org-id-get-with-outline-path-completion (&optional targets)
"Use `outline-path-completion' to retrieve the ID of an entry.
TARGETS may be a setting for `org-refile-targets' to define
eligible headlines. When omitted, all headlines in the current
file are eligible. This function returns the ID of the entry.
If necessary, the ID is created."
(let* ((org-refile-targets (or targets '((nil . (:maxlevel . 10)))))
(org-refile-use-outline-path
(if (caar org-refile-targets) 'file t))
(org-refile-target-verify-function nil)
(spos (org-refile-get-location "Entry"))
(pom (and spos (move-marker (make-marker) (or (nth 3 spos) 1)
(get-file-buffer (nth 1 spos))))))
(prog1 (org-id-get pom 'create)
(move-marker pom nil))))
;;;###autoload
(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-goto-location'.
It returns the ID of the entry. If necessary, the ID is created."
(let* ((spos (org-goto-location))
(pom (and spos (move-marker (make-marker) (car spos)))))
(prog1 (org-id-get pom 'create)
(move-marker pom nil))))
;;;###autoload
(defun org-id-goto (id)
"Switch to the buffer containing the entry with id ID.
Move the cursor to that entry in that buffer."
(interactive "sID: ")
(let ((m (org-id-find id 'marker)))
(unless m
(error "Cannot find entry with ID \"%s\"" id))
(pop-to-buffer-same-window (marker-buffer m))
(goto-char m)
(move-marker m nil)
(org-fold-show-context)))
;;;###autoload
(defun org-id-find (id &optional markerp)
"Return the location of the entry with the id ID.
The return value is a cons cell (file-name . position), or nil
if there is no entry with that ID.
With optional argument MARKERP, return the position as a new marker."
(cond
((symbolp id) (setq id (symbol-name id)))
((numberp id) (setq id (number-to-string id))))
(let ((file (org-id-find-id-file id))
org-agenda-new-buffers where)
(when file
(setq where (org-id-find-id-in-file id file markerp)))
(unless where
(org-id-update-id-locations nil t)
(setq file (org-id-find-id-file id))
(when file
(setq where (org-id-find-id-in-file id file markerp))))
where))
;;; Internal functions
;; Creating new IDs
;;;###autoload
(defun org-id-new (&optional prefix)
"Create a new globally unique ID.
An ID consists of two parts separated by a colon:
- a prefix
- a unique part that will be created according to `org-id-method'.
PREFIX can specify the prefix, the default is given by the variable
`org-id-prefix'. However, if PREFIX is the symbol `none', don't use any
prefix even if `org-id-prefix' specifies one.
So a typical ID could look like \"Org:4nd91V40HI\"."
(let* ((prefix (if (eq prefix 'none)
""
(concat (or prefix org-id-prefix) ":")))
unique)
(if (equal prefix ":") (setq prefix ""))
(cond
((memq org-id-method '(uuidgen uuid))
(setq unique (org-trim (shell-command-to-string org-id-uuid-program)))
(unless (org-uuidgen-p unique)
(setq unique (org-id-uuid))))
((eq org-id-method 'org)
(let* ((etime (org-reverse-string (org-id-time-to-b36)))
(postfix (when org-id-include-domain
(require 'message)
(concat "@" (message-make-fqdn)))))
(setq unique (concat etime postfix))))
((eq org-id-method 'ts)
(let ((ts (format-time-string org-id-ts-format))
(postfix (when org-id-include-domain
(require 'message)
(concat "@" (message-make-fqdn)))))
(setq unique (concat ts postfix))))
(t (error "Invalid `org-id-method'")))
(concat prefix unique)))
(defun org-id-int-to-b36-one-digit (integer)
"Convert INTEGER between 0 and 61 into a single character 0..9, A..Z, a..z."
(cond
((< integer 10) (+ ?0 integer))
((< integer 36) (+ ?a integer -10))
(t (error "Larger that 35"))))
(defun org-id-b36-to-int-one-digit (i)
"Convert character 0..9, A..Z, a..z into a number 0..61.
The input I may be a character, or a single-letter string."
(and (stringp i) (setq i (string-to-char i)))
(cond
((and (>= i ?0) (<= i ?9)) (- i ?0))
((and (>= i ?a) (<= i ?z)) (+ (- i ?a) 10))
(t (error "Invalid b36 letter"))))
(defun org-id-int-to-b36 (integer &optional length)
"Convert an INTEGER to a base-36 number represented as a string.
The returned string is padded with leading zeros to LENGTH if necessary."
(let ((s "")
(i integer))
(while (> i 0)
(setq s (concat (char-to-string
(org-id-int-to-b36-one-digit (mod i 36))) s)
i (/ i 36)))
(setq length (max 1 (or length 1)))
(if (< (length s) length)
(setq s (concat (make-string (- length (length s)) ?0) s)))
s))
(defun org-id-b36-to-int (string)
"Convert a base-36 STRING into the corresponding integer."
(let ((r 0))
(mapc (lambda (i) (setq r (+ (* r 36) (org-id-b36-to-int-one-digit i))))
string)
r))
(defun org-id-time-to-b36 (&optional time)
"Encode TIME as a 12-digit string.
This string holds the time to micro-second accuracy, and can be decoded
using `org-id-decode'."
;; FIXME: If TIME represents N seconds after the epoch, then
;; this encoding assumes 0 <= N < 110075314176 = (* (expt 36 4) 65536),
;; i.e., that TIME is from 1970-01-01 00:00:00 to 5458-02-23 20:09:36 UTC.
(setq time (org-time-convert-to-list nil))
(concat (org-id-int-to-b36 (nth 0 time) 4)
(org-id-int-to-b36 (nth 1 time) 4)
(org-id-int-to-b36 (nth 2 time) 4)))
(defun org-id-decode (id)
"Split ID into the prefix and the time value that was used to create it.
The return value is (prefix . time) where PREFIX is nil or a string,
and TIME is a Lisp time value (HI LO USEC)."
(let (prefix time parts)
(setq parts (org-split-string id ":"))
(if (= 2 (length parts))
(setq prefix (car parts) time (nth 1 parts))
(setq prefix nil time (nth 0 parts)))
(setq time (org-reverse-string time))
(setq time (list (org-id-b36-to-int (substring time 0 4))
(org-id-b36-to-int (substring time 4 8))
(org-id-b36-to-int (substring time 8 12))))
(cons prefix time)))
;; Storing ID locations (files)
;;;###autoload
(defun org-id-update-id-locations (&optional files silent)
"Scan relevant files for IDs.
Store the relation between files and corresponding IDs.
This will scan all agenda files, all associated archives, all open Org
files, and all files currently mentioned in `org-id-locations'.
When FILES is given, scan also these files.
If SILENT is non-nil, messages are suppressed."
(interactive)
(unless org-id-track-globally
(error "Please turn on `org-id-track-globally' if you want to track IDs"))
(let* ((files
(delete-dups
(mapcar #'file-truename
(cl-remove-if-not
;; Default `org-id-extra-files' value contains
;; `agenda-archives' symbol.
#'stringp
(append
;; Agenda files and all associated archives.
(org-agenda-files t org-id-search-archives)
;; Explicit extra files.
(if (symbolp org-id-extra-files)
(symbol-value org-id-extra-files)
org-id-extra-files)
;; All files known to have IDs.
org-id-files
;; All Org files open in Emacs.
(mapcar #'buffer-file-name (org-buffer-list 'files t))
;; Additional files from function call.
files)))))
(nfiles (length files))
(id-regexp
(rx (seq bol (0+ (any "\t ")) ":ID:" (1+ " ") (not (any " ")))))
(seen-ids (make-hash-table :test #'equal))
(ndup 0)
(i 0)
(checksum
(mapcar
(lambda (f)
(when (file-exists-p f)
(list f (file-attribute-modification-time (file-attributes f)))))
(sort (copy-sequence files) #'string<))))
(unless (equal checksum org-id--locations-checksum) ; Files have changed since the last update.
(setq org-id-locations nil)
(with-temp-buffer
(delay-mode-hooks
(org-mode)
(dolist (file files)
(when (file-exists-p file)
(unless silent
(cl-incf i)
(message "Finding ID locations (%d/%d files): %s" i nfiles file))
(insert-file-contents file nil nil nil 'replace)
(let ((ids nil)
node
(case-fold-search t))
(org-with-point-at 1
(while (re-search-forward id-regexp nil t)
(setq node (org-element-at-point))
(when (org-element-type-p node 'node-property)
(push (org-element-property :value node) ids)))
(when ids
(push (cons (abbreviate-file-name file) ids)
org-id-locations)
(dolist (id ids)
(cond
((not (gethash id seen-ids)) (puthash id t seen-ids))
(silent nil)
(t
(message "Duplicate ID %S" id)
(cl-incf ndup)))))))))))
(setq org-id-files (mapcar #'car org-id-locations))
(org-id-locations-save)
;; Now convert to a hash table.
(setq org-id-locations (org-id-alist-to-hash org-id-locations))
(setq org-id--locations-checksum checksum)
(when (and (not silent) (> ndup 0))
(warn "WARNING: %d duplicate IDs found, check *Messages* buffer" ndup))
(message "%d files scanned, %d files contains IDs, and %d IDs found."
nfiles (length org-id-files) (hash-table-count org-id-locations)))
org-id-locations))
(defun org-id-locations-save ()
"Save `org-id-locations' in `org-id-locations-file'."
(when (and org-id-track-globally org-id-locations)
(let ((out (if (hash-table-p org-id-locations)
(org-id-hash-to-alist org-id-locations)
org-id-locations)))
(when (and org-id-locations-file-relative out)
(setq out (mapcar
(lambda (item)
(if (file-name-absolute-p (car item))
(cons (file-relative-name
(car item) (file-name-directory
org-id-locations-file))
(cdr item))
item))
out)))
(with-temp-file org-id-locations-file
(let ((print-level nil)
(print-length nil))
(print out (current-buffer)))))))
(defun org-id-locations-load ()
"Read the data from `org-id-locations-file'."
(setq org-id-locations nil)
(when org-id-track-globally
(with-temp-buffer
(condition-case nil
(progn
(insert-file-contents org-id-locations-file)
(setq org-id-locations (read (current-buffer)))
(let ((loc (file-name-directory org-id-locations-file)))
(mapc (lambda (item)
(unless (file-name-absolute-p (car item))
(setf (car item) (expand-file-name (car item) loc))))
org-id-locations)))
(error
(message "Could not read `org-id-locations' from %s, setting it to nil"
org-id-locations-file))))
(setq org-id-files (mapcar 'car org-id-locations))
(setq org-id-locations (org-id-alist-to-hash org-id-locations))))
(defun org-id-add-location (id file)
"Add the ID with location FILE to the database of ID locations."
;; Only if global tracking is on, and when the buffer has a file
(unless file
(error "`org-id-get' expects a file-visiting buffer"))
(let ((afile (abbreviate-file-name file)))
(when (and org-id-track-globally id)
(unless org-id-locations (org-id-locations-load))
(puthash id afile org-id-locations)
(unless (member afile org-id-files)
(add-to-list 'org-id-files afile)))))
(unless noninteractive
(add-hook 'kill-emacs-hook 'org-id-locations-save))
(defun org-id-hash-to-alist (hash)
"Turn an org-id HASH into an alist.
This is to be able to write it to a file."
(let (res x)
(maphash
(lambda (k v)
(if (setq x (assoc v res))
(setcdr x (cons k (cdr x)))
(push (list v k) res)))
hash)
res))
(defun org-id-alist-to-hash (list)
"Turn an org-id location LIST into a hash table."
(let ((res (make-hash-table
:test 'equal
:size (apply '+ (mapcar 'length list))))
f)
(mapc
(lambda (x)
(setq f (car x))
(mapc (lambda (i) (puthash i f res)) (cdr x)))
list)
res))
(defun org-id-paste-tracker (txt &optional buffer-or-file)
"Update any ids in TXT and assign BUFFER-OR-FILE to them."
(when org-id-track-globally
(save-match-data
(setq buffer-or-file (or buffer-or-file (current-buffer)))
(when (bufferp buffer-or-file)
(setq buffer-or-file (or (buffer-base-buffer buffer-or-file)
buffer-or-file))
(setq buffer-or-file (buffer-file-name buffer-or-file)))
(when buffer-or-file
(let ((fname (abbreviate-file-name buffer-or-file))
(s 0))
(while (string-match "^[ \t]*:ID:[ \t]+\\([^ \t\n\r]+\\)" txt s)
(setq s (match-end 0))
(org-id-add-location (match-string 1 txt) fname)))))))
;; Finding entries with specified id
;;;###autoload
(defun org-id-find-id-file (id)
"Query the id database for the file in which ID is located."
(unless org-id-locations (org-id-locations-load))
(or (and org-id-locations
(hash-table-p org-id-locations)
(gethash id org-id-locations))
;; Fall back on current buffer
(buffer-file-name (or (buffer-base-buffer (current-buffer))
(current-buffer)))))
(defun org-id-find-id-in-file (id file &optional markerp)
"Return the position of the entry ID in FILE.
If that files does not exist, or if it does not contain this ID,
return nil.
The position is returned as a cons cell (file-name . position). With
optional argument MARKERP, return the position as a new marker."
(cond
((not file) nil)
((not (file-exists-p file)) nil)
(t
(let* ((visiting (find-buffer-visiting file))
(buffer (or visiting
(if markerp (find-file-noselect file)
(org-get-buffer-create " *Org ID temp*" t)))))
(unwind-protect
(with-current-buffer buffer
(unless (derived-mode-p 'org-mode) (org-mode))
(unless (or visiting markerp)
(buffer-disable-undo)
;; FIXME: In Emacs 27, `insert-file-contents' seemingly
;; does not trigger modification hooks in some
;; scenarios. This is manifested in test failures due
;; to element cache losing track of the modifications.
(org-element-cache-reset)
(insert-file-contents file nil nil nil 'replace))
(let ((pos (org-find-entry-with-id id)))
(cond
((null pos) nil)
(markerp (move-marker (make-marker) pos buffer))
(t (cons file pos)))))
;; Clean temporarily buffer if we don't need to keep it.
(unless (or visiting markerp)
(with-current-buffer buffer (erase-buffer))))))))
;; id link type
(defun org-id--get-id-to-store-link (&optional create)
"Get or create the relevant ID for storing a link.
Optional argument CREATE is passed to `org-id-get'.
Inherited IDs are only considered when
`org-id-link-consider-parent-id', `org-id-link-use-context' and
`org-link-context-for-files' are all enabled, since inherited IDs
are confusing without the additional search string context.
Note that this function resets the
`org-entry-property-inherited-from' marker: it will either point
to nil (if the id was not inherited) or to the point it was
inherited from."
(let* ((inherit-id (and org-id-link-consider-parent-id
org-id-link-use-context
org-link-context-for-files)))
(move-marker org-entry-property-inherited-from nil)
(org-id-get nil create nil inherit-id)))
;;;###autoload
(defun org-id-store-link ()
"Store a link to the current entry, using its ID.
The link description is based on the heading, or if before the
first heading, the title keyword if available, or else the
filename.
When `org-link-context-for-files' and `org-id-link-use-context'
are non-nil, add a search string to the link. The link
description is then based on the search string target.
When in addition `org-id-link-consider-parent-id' is non-nil, the
ID can be inherited from a parent entry, with the search string
used to still link to the current location."
(interactive)
(when (and (buffer-file-name (buffer-base-buffer))
(derived-mode-p 'org-mode))
;; Get the precise target first, in case looking for an id causes
;; a properties drawer to be added at the current location.
(let* ((precise-target (and org-link-context-for-files
org-id-link-use-context
(org-link-precise-link-target)))
(link (concat "id:" (org-id--get-id-to-store-link 'create)))
(id-location (or (and org-entry-property-inherited-from
(marker-position org-entry-property-inherited-from))
(save-excursion (org-back-to-heading-or-point-min t) (point))))
(case-fold-search nil)
(desc (save-excursion
(goto-char id-location)
(cond ((org-before-first-heading-p)
(let ((keywords (org-collect-keywords '("TITLE"))))
(if keywords
(cadr (assoc "TITLE" keywords))
(file-name-nondirectory
(buffer-file-name (buffer-base-buffer))))))
((looking-at org-complex-heading-regexp)
(if (match-end 4)
(match-string 4)
(match-string 0)))
(t link)))))
;; Precise targets should be after id-location to avoid
;; duplicating the current headline as a search string
(when (and precise-target
(> (nth 2 precise-target) id-location))
(setq link (concat link "::" (nth 0 precise-target)))
(setq desc (nth 1 precise-target)))
(org-link-store-props :link link :description desc :type "id")
link)))
;;;###autoload
(defun org-id-store-link-maybe (&optional interactive?)
"Store a link to the current entry using its ID if enabled.
The value of `org-id-link-to-org-use-id' determines whether an ID
link should be stored, using `org-id-store-link'.
Assume the function is called interactively if INTERACTIVE? is
non-nil."
(when (and (buffer-file-name (buffer-base-buffer))
(derived-mode-p 'org-mode)
(or (eq org-id-link-to-org-use-id t)
(and interactive?
(or (eq org-id-link-to-org-use-id 'create-if-interactive)
(and (eq org-id-link-to-org-use-id
'create-if-interactive-and-no-custom-id)
(not (org-entry-get nil "CUSTOM_ID")))))
;; 'use-existing
(and org-id-link-to-org-use-id
(org-id--get-id-to-store-link))))
(org-id-store-link)))
(defun org-id-open (link _)
"Go to the entry indicated by id link LINK.
The link can include a search string after \"::\", which is
passed to `org-link-search'.
For backwards compatibility with IDs that contain \"::\", if no
match is found for the ID, the full link string including \"::\"
will be tried as an ID."
(let* ((option (and (string-match "::\\(.*\\)\\'" link)
(match-string 1 link)))
(id (if (not option) link
(substring link 0 (match-beginning 0))))
m cmd)
(org-mark-ring-push)
(setq m (org-id-find id 'marker))
(when (and (not m) option)
;; Backwards compatibility: if id is not found, try treating
;; whole link as an id.
(setq m (org-id-find link 'marker))
(when m
(setq option nil)))
(unless m
(error "Cannot find entry with ID \"%s\"" id))
;; Use a buffer-switching command in analogy to finding files
(setq cmd
(or
(cdr
(assq
(cdr (assq 'file org-link-frame-setup))
'((find-file . switch-to-buffer)
(find-file-other-window . switch-to-buffer-other-window)
(find-file-other-frame . switch-to-buffer-other-frame))))
'switch-to-buffer-other-window))
(if (not (equal (current-buffer) (marker-buffer m)))
(funcall cmd (marker-buffer m)))
(goto-char m)
(move-marker m nil)
(when option
(save-restriction
(unless (org-before-first-heading-p)
(org-narrow-to-subtree))
(org-link-search option nil nil
(org-element-lineage (org-element-at-point) 'headline t))))
(org-fold-show-context)))
(org-link-set-parameters "id"
:follow #'org-id-open
:store #'org-id-store-link-maybe)
(provide 'org-id)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; org-id.el ends here
org-mode-9.7.29+dfsg/lisp/org-indent.el 0000664 0000000 0000000 00000042436 15004304337 0017621 0 ustar 00root root 0000000 0000000 ;;; org-indent.el --- Dynamic indentation for Org -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2025 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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 <https://www.gnu.org/licenses/>.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;; This is an implementation of dynamic virtual indentation. It works
;; by adding text properties to a buffer to make sure lines are
;; indented according to outline structure.
;;
;; The process is synchronous, toggled at every buffer modification.
;; Though, the initialization (indentation of text already in the
;; buffer), which can take a few seconds in large buffers, happens on
;; idle time.
;;
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'org-macs)
(require 'org-compat)
(require 'org)
(require 'cl-lib)
(declare-function org-inlinetask-get-task-level "org-inlinetask" ())
(declare-function org-inlinetask-in-task-p "org-inlinetask" ())
(declare-function org-list-item-body-column "org-list" (item))
(defvar org-inlinetask-show-first-star)
(defgroup org-indent nil
"Options concerning dynamic virtual outline indentation."
:tag "Org Indent"
:group 'org)
(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
"Timer running the initialize agent.")
(defvar org-indent-agentized-buffers nil
"List of buffers watched by the initialize agent.")
(defvar org-indent-agent-resume-timer nil
"Timer to reschedule agent after switching to other idle processes.")
(defvar org-indent-agent-active-delay '(0 2 0)
"Time to run agent before switching to other idle processes.
Delay used when the buffer to initialize is current.")
(defvar org-indent-agent-passive-delay '(0 0 400000)
"Time to run agent before switching to other idle processes.
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
"Position of initialization before interrupt.
This is used locally in each buffer being initialized.")
(defvar org-indent-modified-headline-flag nil
"Non-nil means the last deletion operated on a headline.
It is modified by `org-indent-notify-modified-headline'.")
(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."
:group 'org-indent
:type 'character)
(defcustom org-indent-mode-turns-off-org-adapt-indentation t
"Non-nil means setting `org-indent-mode' will turn off indentation adaptation.
For details see the variable `org-adapt-indentation'."
:group 'org-indent
:type 'boolean)
(defcustom org-indent-mode-turns-on-hiding-stars t
"Non-nil means setting `org-indent-mode' will turn on `org-hide-leading-stars'."
:group 'org-indent
:type 'boolean)
(defcustom org-indent-indentation-per-level 2
"Indentation per level in number of characters."
:group 'org-indent
:type 'integer)
(defcustom org-indent-post-buffer-init-functions nil
"Hook run after org-indent finishes initializing a buffer.
The function(s) in this hook must accept a single argument representing
the initialized buffer."
:group 'org-indent
:package-version '(Org . "9.7")
:type 'hook)
(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)
(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))
(when (> org-indent-indentation-per-level 0)
(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
(cond ((<= n 1) "")
((bound-and-true-p org-inlinetask-show-first-star)
(concat org-indent-inlinetask-first-star
(substring heading-prefix 1)))
(t (org-add-props heading-prefix nil 'face 'org-indent)))))
;; Text line prefixes.
(aset org-indent--text-line-prefixes
n
(org-add-props
(concat (make-string (+ n indentation) ?\s)
(and (> n 0)
(char-to-string org-indent-boundary-char)))
nil 'face 'org-indent))))))
(defsubst org-indent-remove-properties (beg end)
"Remove indentations between BEG and END."
(with-silent-modifications
(remove-text-properties beg end '(line-prefix nil wrap-prefix nil))))
;;;###autoload
(define-minor-mode org-indent-mode
"When active, indent text according to outline structure.
Internally this works by adding `line-prefix' and `wrap-prefix'
properties, after each buffer modification, on the modified zone.
The process is synchronous. Though, initial indentation of
buffer, which can take a few seconds on large buffers, is done
during idle time."
:lighter " Ind"
(cond
(org-indent-mode
;; mode was turned on.
(setq-local indent-tabs-mode nil)
(setq-local org-indent--initial-marker (copy-marker 1))
(when org-indent-mode-turns-off-org-adapt-indentation
;; Don't turn off `org-adapt-indentation' when its value is
;; 'headline-data, just indent headline data specially.
(or (eq org-adapt-indentation 'headline-data)
(setq-local org-adapt-indentation nil)))
(when org-indent-mode-turns-on-hiding-stars
(setq-local org-hide-leading-stars t))
(org-indent--compute-prefixes)
(if (boundp 'filter-buffer-substring-functions)
(add-hook 'filter-buffer-substring-functions
(lambda (fun start end delete)
(org-indent-remove-properties-from-string
(funcall fun start end delete)))
nil t)
;; Emacs >= 24.4.
(add-function :filter-return (local 'filter-buffer-substring-function)
#'org-indent-remove-properties-from-string))
(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
;; buffer submitted, also start the agent. Current buffer is
;; pushed in both cases to avoid a race condition.
(if org-indent-agentized-buffers
(push (current-buffer) org-indent-agentized-buffers)
(push (current-buffer) org-indent-agentized-buffers)
(setq org-indent-agent-timer
(run-with-idle-timer 0.2 t #'org-indent-initialize-agent))))
(t
;; Mode was turned off (or we refused to turn it on)
(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 (local-variable-p 'org-hide-leading-stars)
(kill-local-variable 'org-hide-leading-stars))
(if (boundp 'filter-buffer-substring-functions)
(remove-hook 'filter-buffer-substring-functions
(lambda (fun start end delete)
(org-indent-remove-properties-from-string
(funcall fun start end delete))))
(remove-function (local 'filter-buffer-substring-function)
#'org-indent-remove-properties-from-string))
(remove-hook 'after-change-functions 'org-indent-refresh-maybe 'local)
(remove-hook 'before-change-functions
'org-indent-notify-modified-headline 'local)
(org-with-wide-buffer
(org-indent-remove-properties (point-min) (point-max)))
(and font-lock-mode (org-restart-font-lock))
(redraw-display))))
(defun org-indent-indent-buffer ()
"Add indentation properties to the accessible part of the buffer."
(interactive)
(if (not (derived-mode-p 'org-mode))
(error "Not in Org mode")
(message "Setting buffer indentation. It may take a few seconds...")
(org-indent-remove-properties (point-min) (point-max))
(org-indent-add-properties (point-min) (point-max))
(message "Indentation of buffer set.")))
(defun org-indent-remove-properties-from-string (string)
"Remove indentation properties from STRING."
(remove-text-properties 0 (length string)
'(line-prefix nil wrap-prefix nil) string)
string)
(defun org-indent-initialize-agent ()
"Start or resume current buffer initialization.
Only buffers in `org-indent-agentized-buffers' trigger an action.
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
(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))
;; Current buffer is agentized: start/resume initialization
;; somewhat aggressively.
((memq (current-buffer) org-indent-agentized-buffers)
(org-indent-initialize-buffer (current-buffer)
org-indent-agent-active-delay))
;; Else, start/resume initialization of the last agentized buffer,
;; softly.
(t (org-indent-initialize-buffer (car org-indent-agentized-buffers)
org-indent-agent-passive-delay))))
(defun org-indent-initialize-buffer (buffer delay)
"Set virtual indentation for the buffer BUFFER, asynchronously.
Give hand to other idle processes if it takes longer than DELAY,
a time value."
(with-current-buffer buffer
(when org-indent-mode
(org-with-wide-buffer
(let ((interruptp
;; Always nil unless interrupted.
(catch 'interrupt
(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)
;; Job is complete: un-agentize buffer.
(unless interruptp
(setq org-indent-agentized-buffers
(delq buffer org-indent-agentized-buffers))
(run-hook-with-args 'org-indent-post-buffer-init-functions buffer)))))))
(defun org-indent-set-line-properties (level indentation &optional heading)
"Set prefix properties on current line an move to next one.
LEVEL is the current level of heading. INDENTATION is the
expected indentation when wrapping line.
When optional argument HEADING is non-nil, assume line is at
a heading. Moreover, if it 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 (line-beginning-position) (line-beginning-position 2)
`(line-prefix ,line wrap-prefix ,wrap)))
(forward-line))
(defun org-indent-add-properties (beg end &optional delay)
"Add indentation properties between BEG and END.
When DELAY is non-nil, it must be a time value. In that case,
the process is asynchronous and can be interrupted, either by
user request, or after DELAY. This is done by throwing the
`interrupt' tag along with the buffer position where the process
stopped."
(save-match-data
(org-with-wide-buffer
(goto-char beg)
(forward-line 0)
;; Initialize prefix at BEG, according to current entry's level.
(let* ((case-fold-search t)
(limited-re (org-get-limited-outline-regexp))
(level (or (org-current-level) 0))
(time-limit (and delay (time-add nil delay))))
;; For each line, set `line-prefix' and `wrap-prefix'
;; properties depending on the type of line (headline, inline
;; task, item or other).
(with-silent-modifications
(while (and (<= (point) end) (not (eobp)))
(cond
;; When in asynchronous mode, check if interrupt is
;; required.
((and delay (input-pending-p)) (throw 'interrupt (point)))
;; In asynchronous mode, take a break of
;; `org-indent-agent-resume-delay' every DELAY to avoid
;; blocking any other idle timer or process output.
((and delay (time-less-p time-limit nil))
(setq org-indent-agent-resume-timer
(run-with-idle-timer
(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))
(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)
(org-indent-set-line-properties
level (org-list-item-body-column (point))))
;; Regular line.
(t
(org-indent-set-line-properties
level
(current-indentation)
;; When adapt indentation is 'headline-data, use
;; `org-indent--heading-line-prefixes' for setting
;; headline data indentation.
(and (eq org-adapt-indentation 'headline-data)
(or (org-at-planning-p)
(org-at-clock-log-p)
(looking-at-p org-property-start-re)
(looking-at-p org-property-end-re)
(looking-at-p org-property-re))))))))))))
(defun org-indent-notify-modified-headline (beg end)
"Set `org-indent-modified-headline-flag' depending on context.
BEG and END are the positions of the beginning and end of the
range of deleted text.
This function is meant to be called by `before-change-functions'.
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
(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 _)
"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.
This function is meant to be called by `after-change-functions'."
(when org-indent-mode
(save-match-data
;; If a headline was modified or inserted, set properties until
;; next headline.
(org-with-wide-buffer
(if (or org-indent-modified-headline-flag
(save-excursion
(goto-char beg)
(forward-line 0)
(re-search-forward
(org-with-limited-levels org-outline-regexp-bol)
(save-excursion
(goto-char end)
;; Extend to headline if END is within its
;; headline stars.
(line-end-position))
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)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; org-indent.el ends here
org-mode-9.7.29+dfsg/lisp/org-inlinetask.el 0000664 0000000 0000000 00000031471 15004304337 0020476 0 ustar 00root root 0000000 0000000 ;;; org-inlinetask.el --- Tasks Independent of Outline Hierarchy -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2025 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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 <https://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;; 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
;; specially by the visibility cycling.
;;
;; Visibility cycling exempts these nodes from cycling. So whenever
;; their parent is opened, so are these tasks. This will only work
;; with `org-cycle', so if you are also using other commands to
;; show/hide entries, you will occasionally find these tasks to behave
;; like all other outline nodes, seemingly splitting the text of the
;; parent into children.
;;
;; Special fontification of inline tasks, so that they can be
;; immediately recognized. From the stars of the headline, only last
;; two will be visible, the others will be hidden using the `org-hide'
;; face.
;;
;; An inline task is identified solely by a minimum outline level,
;; given by the variable `org-inlinetask-min-level', default 15.
;;
;; If you need to have a time planning line (DEADLINE etc), drawers,
;; for example LOGBOOK of PROPERTIES, or even normal text as part of
;; the inline task, you must add an "END" headline with the same
;; number of stars.
;;
;; As an example, here are two valid inline tasks:
;;
;; **************** TODO A small task
;;
;; and
;;
;; **************** TODO Another small task
;; DEADLINE: <2009-03-30 Mon>
;; :PROPERTIES:
;; :SOMETHING: another thing
;; :END:
;; And here is some extra text
;; **************** END
;;
;; Also, if you want to use refiling and archiving for inline tasks,
;; The END line must be present to make things work properly.
;;
;; Note that you should not try to use inline tasks within plain list,
;; visibility cycling is known to be problematic when doing so.
;;
;; This package installs one new command:
;;
;; C-c C-x t Insert a new inline task with END line
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'org)
(defgroup org-inlinetask nil
"Options concerning inline tasks in Org mode."
:tag "Org Inline Tasks"
:group 'org-structure)
(defcustom org-inlinetask-min-level 15
"Minimum level a headline must have before it is treated as an inline task.
Don't set it to something higher than `29' or clocking will break since this
is the hardcoded maximum number of stars `org-clock-sum' will work with.
It is strongly recommended that you set `org-cycle-max-level' not at all,
or to a number smaller than this one. See `org-cycle-max-level'
docstring for more details."
:group 'org-inlinetask
:type '(choice
(const :tag "Off" nil)
(integer)))
(defcustom org-inlinetask-show-first-star nil
"Non-nil means display the first star of an inline task as additional marker.
When nil, the first star is not shown."
:tag "Org Inline Tasks"
:group 'org-structure
:type 'boolean)
(defvar org-odd-levels-only)
(defvar org-keyword-time-regexp)
(defvar org-complex-heading-regexp)
(defvar org-property-end-re)
(defcustom org-inlinetask-default-state nil
"Non-nil means make inline tasks have a TODO keyword initially.
This should be the state `org-inlinetask-insert-task' should use by
default, or nil if no state should be assigned."
:group 'org-inlinetask
:version "24.1"
:type '(choice
(const :tag "No state" nil)
(string :tag "Specific state")))
(defun org-inlinetask-insert-task (&optional no-state)
"Insert an inline task.
If prefix arg NO-STATE is set, ignore `org-inlinetask-default-state'.
If there is a region wrap it inside the inline task."
(interactive "P")
;; Error when inside an inline task, except if point was at its very
;; beginning, in which case the new inline task will be inserted
;; before this one.
(when (and (org-inlinetask-in-task-p)
(not (and (org-inlinetask-at-task-p) (bolp))))
(user-error "Cannot nest inline tasks"))
(or (bolp) (newline))
(let* ((indent (if org-odd-levels-only
(1- (* 2 org-inlinetask-min-level))
org-inlinetask-min-level))
(indent-string (concat (make-string indent ?*) " "))
(rbeg (if (org-region-active-p) (region-beginning) (point)))
(rend (if (org-region-active-p) (region-end) (point))))
(goto-char rend)
(insert "\n" indent-string "END\n")
(goto-char rbeg)
(unless (bolp) (insert "\n"))
(insert indent-string
(if (or no-state (not org-inlinetask-default-state))
""
(concat org-inlinetask-default-state " "))
(if (= rend rbeg) "" "\n"))
(unless (= rend rbeg) (end-of-line 0))))
(define-key org-mode-map "\C-c\C-xt" 'org-inlinetask-insert-task)
(defun org-inlinetask-outline-regexp ()
"Return string matching an inline task heading.
The number of levels is controlled by `org-inlinetask-min-level'."
(let ((nstars (if org-odd-levels-only
(1- (* org-inlinetask-min-level 2))
org-inlinetask-min-level)))
(format "^\\(\\*\\{%d,\\}\\)[ \t]+" nstars)))
(defun org-inlinetask-end-p ()
"Return a non-nil value if point is on inline task's END part."
(let ((case-fold-search t))
(org-match-line (concat (org-inlinetask-outline-regexp) "END[ \t]*$"))))
(defun org-inlinetask-at-task-p ()
"Return non-nil if point is at beginning of an inline task."
(and (org-match-line (concat (org-inlinetask-outline-regexp) "\\(.*\\)"))
(not (org-inlinetask-end-p))))
(defun org-inlinetask-in-task-p ()
"Return non-nil if point is inside an inline task."
(save-excursion
(forward-line 0)
(let ((case-fold-search t))
(or (looking-at-p (concat (org-inlinetask-outline-regexp) "\\(?:.*\\)"))
(and (re-search-forward "^\\*+[ \t]+" nil t)
(org-inlinetask-end-p))))))
(defun org-inlinetask-goto-beginning ()
"Go to the beginning of the inline task at point."
(end-of-line)
(let ((case-fold-search t)
(inlinetask-re (org-inlinetask-outline-regexp)))
(re-search-backward inlinetask-re nil t)
(when (org-inlinetask-end-p)
(re-search-backward inlinetask-re nil t))))
(defun org-inlinetask-goto-end ()
"Go to the end of the inline task at point.
Return point."
(save-match-data
(forward-line 0)
(let ((case-fold-search t)
(inlinetask-re (org-inlinetask-outline-regexp)))
(cond
((org-inlinetask-end-p)
(forward-line))
((looking-at-p inlinetask-re)
(forward-line)
(cond
((org-inlinetask-end-p) (forward-line))
((looking-at-p inlinetask-re))
((org-inlinetask-in-task-p)
(re-search-forward inlinetask-re nil t)
(forward-line))
(t nil)))
(t
(re-search-forward inlinetask-re nil t)
(forward-line)))))
(point))
(defun org-inlinetask-get-task-level ()
"Get the level of the inline task around.
This assumes the point is inside an inline task."
(save-excursion
(end-of-line)
(re-search-backward (org-inlinetask-outline-regexp) nil t)
(- (match-end 1) (match-beginning 1))))
(defun org-inlinetask-promote ()
"Promote the inline task at point.
If the task has an end part, promote it. Also, prevents level from
going below `org-inlinetask-min-level'."
(interactive)
(if (not (org-inlinetask-in-task-p))
(user-error "Not in an inline task")
(save-excursion
(let* ((lvl (org-inlinetask-get-task-level))
(next-lvl (org-get-valid-level lvl -1))
(diff (- next-lvl lvl))
(down-task (concat (make-string next-lvl ?*)))
beg)
(if (< next-lvl org-inlinetask-min-level)
(user-error "Cannot promote an inline task at minimum level")
(org-inlinetask-goto-beginning)
(setq beg (point))
(replace-match down-task nil t nil 1)
(org-inlinetask-goto-end)
(if (and (eobp) (looking-back "END\\s-*" (line-beginning-position)))
(forward-line 0)
(forward-line -1))
(unless (= (point) beg)
(looking-at (org-inlinetask-outline-regexp))
(replace-match down-task nil t nil 1)
(when (eq org-adapt-indentation t)
(goto-char beg)
(org-fixup-indentation diff))))))))
(defun org-inlinetask-demote ()
"Demote the inline task at point.
If the task has an end part, also demote it."
(interactive)
(if (not (org-inlinetask-in-task-p))
(user-error "Not in an inline task")
(save-excursion
(let* ((lvl (org-inlinetask-get-task-level))
(next-lvl (org-get-valid-level lvl 1))
(diff (- next-lvl lvl))
(down-task (concat (make-string next-lvl ?*)))
beg)
(org-inlinetask-goto-beginning)
(setq beg (point))
(replace-match down-task nil t nil 1)
(org-inlinetask-goto-end)
(if (and (eobp) (looking-back "END\\s-*" (line-beginning-position)))
(forward-line 0)
(forward-line -1))
(unless (= (point) beg)
(looking-at (org-inlinetask-outline-regexp))
(replace-match down-task nil t nil 1)
(when (eq org-adapt-indentation t)
(goto-char beg)
(org-fixup-indentation diff)))))))
(defvar org-indent-indentation-per-level) ; defined in org-indent.el
(defface org-inlinetask '((t :inherit shadow))
"Face for inlinetask headlines."
:group 'org-faces)
(defun org-inlinetask-fontify (limit)
"Fontify the inline tasks down to LIMIT."
(let* ((nstars (if org-odd-levels-only
(1- (* 2 (or org-inlinetask-min-level 200)))
(or org-inlinetask-min-level 200)))
(re (concat "^\\(\\*\\)\\(\\*\\{"
(format "%d" (- nstars 3))
",\\}\\)\\(\\*\\* .*\\)"))
;; Virtual indentation will add the warning face on the first
;; star. Thus, in that case, only hide it.
(start-face (if (and (bound-and-true-p org-indent-mode)
(> org-indent-indentation-per-level 1))
'org-hide
'org-warning)))
(while (re-search-forward re limit t)
(if org-inlinetask-show-first-star
(add-text-properties (match-beginning 1) (match-end 1)
`(face ,start-face font-lock-fontified t)))
(add-text-properties (match-beginning
(if org-inlinetask-show-first-star 2 1))
(match-end 2)
'(face org-hide font-lock-fontified t))
(add-text-properties (match-beginning 3) (match-end 3)
'(face org-inlinetask font-lock-fontified t)))))
(defun org-inlinetask-toggle-visibility (&optional state)
"Toggle visibility of inline task at point.
When optional argument STATE is `fold', fold unconditionally.
When STATE is `unfold', unfold unconditionally."
(let ((end (save-excursion
(org-inlinetask-goto-end)
(if (bolp) (1- (point)) (point))))
(start (save-excursion
(org-inlinetask-goto-beginning)
(line-end-position))))
(cond
;; Nothing to show/hide.
((= end start))
;; Inlinetask was folded: expand it.
((and (not (eq state 'fold))
(or (eq state 'unfold)
(org-fold-get-folding-spec 'headline (1+ start))))
(org-fold-region start end nil 'headline))
(t (org-fold-region start end t 'headline)))))
(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 'fold)
(org-inlinetask-goto-end)))))
(`children
(save-excursion
(while
(or (org-inlinetask-at-task-p)
(and (outline-next-heading) (org-inlinetask-at-task-p)))
(org-inlinetask-toggle-visibility 'fold)
(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 "")))
(add-hook 'org-font-lock-hook 'org-inlinetask-fontify)
(add-hook 'org-cycle-hook 'org-inlinetask-hide-tasks)
(provide 'org-inlinetask)
;;; org-inlinetask.el ends here
org-mode-9.7.29+dfsg/lisp/org-keys.el 0000664 0000000 0000000 00000123153 15004304337 0017307 0 ustar 00root root 0000000 0000000 ;;; org-keys.el --- Key bindings for Org mode -*- lexical-binding: t; -*-
;; Copyright (C) 2018-2025 Free Software Foundation, Inc.
;; Author: Nicolas Goaziou <mail@nicolasgoaziou.fr>
;; Maintainer: Ihor Radchenko <yantar92 at posteo dot net>
;; 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;; This library adds bindings for Org mode buffers. It also
;; implements both Speed keys and Babel speed keys. See manual for
;; details.
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'cl-lib)
(defvar org-outline-regexp)
(require 'oc)
(declare-function org-add-note "org" ())
(declare-function org-agenda "org" (&optional arg org-keys restriction))
(declare-function org-agenda-file-to-front "org" (&optional to-end))
(declare-function org-agenda-remove-restriction-lock "org" (&optional noupdate))
(declare-function org-agenda-set-restriction-lock "org" (&optional type))
(declare-function org-archive-subtree "org" (&optional find-done))
(declare-function org-archive-subtree-default "org" ())
(declare-function org-archive-subtree-default-with-confirmation "org" ())
(declare-function org-archive-to-archive-sibling "org" ())
(declare-function org-at-heading-p "org" (&optional ignored))
(declare-function org-attach "org" ())
(declare-function org-backward-element "org" ())
(declare-function org-backward-heading-same-level "org" (arg &optional invisible-ok))
(declare-function org-backward-paragraph "org" ())
(declare-function org-backward-sentence "org" (&optional arg))
(declare-function org-beginning-of-line "org" (&optional n))
(declare-function org-clock-cancel "org" ())
(declare-function org-clock-display "org" (&optional arg))
(declare-function org-clock-goto "org" (&optional select))
(declare-function org-clock-in "org" (&optional select start-time))
(declare-function org-clock-in-last "org" (&optional arg))
(declare-function org-clock-out "org" (&optional switch-to-state fail-quietly at-time))
(declare-function org-clone-subtree-with-time-shift "org" (n &optional shift))
(declare-function org-columns "org" (&optional global columns-fmt-string))
(declare-function org-comment-dwim "org" (arg))
(declare-function org-copy-special "org" ())
(declare-function org-copy-visible "org" (beg end))
(declare-function org-ctrl-c-ctrl-c "org" (&optional arg))
(declare-function org-ctrl-c-minus "org" ())
(declare-function org-ctrl-c-ret "org" ())
(declare-function org-ctrl-c-star "org" ())
(declare-function org-ctrl-c-tab "org" (&optional arg))
(declare-function org-cut-special "org" ())
(declare-function org-cut-subtree "org" (&optional n))
(declare-function org-cycle "org-cycle" (&optional arg))
(declare-function org-cycle-agenda-files "org-cycle" ())
(declare-function org-date-from-calendar "org" ())
(declare-function org-dynamic-block-insert-dblock "org" (&optional arg))
(declare-function org-dblock-update "org" (&optional arg))
(declare-function org-deadline "org" (arg1 &optional time))
(declare-function org-decrease-number-at-point "org" (&optional inc))
(declare-function org-delete-backward-char "org" (n))
(declare-function org-delete-char "org" (n))
(declare-function org-delete-indentation "org" (&optional arg))
(declare-function org-demote-subtree "org" ())
(declare-function org-display-outline-path "org" (&optional file current separator just-return-string))
(declare-function org-down-element "org" ())
(declare-function org-edit-special "org" (&optional arg))
(declare-function org-element-at-point "org-element" (&optional pom cached-only))
(declare-function org-element-type-p "org-element-ast" (node types))
(declare-function org-emphasize "org" (&optional char))
(declare-function org-end-of-line "org" (&optional n))
(declare-function org-entry-put "org" (pom property value))
(declare-function org-eval-in-calendar "org" (form &optional keepdate))
(declare-function org-calendar-goto-today-or-insert-dot "org" ())
(declare-function org-calendar-goto-today "org" ())
(declare-function org-calendar-backward-month "org" ())
(declare-function org-calendar-forward-month "org" ())
(declare-function org-calendar-backward-year "org" ())
(declare-function org-calendar-forward-year "org" ())
(declare-function org-calendar-backward-week "org" ())
(declare-function org-calendar-forward-week "org" ())
(declare-function org-calendar-backward-day "org" ())
(declare-function org-calendar-forward-day "org" ())
(declare-function org-calendar-view-entries "org" ())
(declare-function org-calendar-scroll-month-left "org" ())
(declare-function org-calendar-scroll-month-right "org" ())
(declare-function org-calendar-scroll-three-months-left "org" ())
(declare-function org-calendar-scroll-three-months-right "org" ())
(declare-function org-evaluate-time-range "org" (&optional to-buffer))
(declare-function org-export-dispatch "org" (&optional arg))
(declare-function org-feed-goto-inbox "org" (feed))
(declare-function org-feed-update-all "org" ())
(declare-function org-fill-paragraph "org" (&optional justify region))
(declare-function org-find-file-at-mouse "org" (ev))
(declare-function org-footnote-action "org" (&optional special))
(declare-function org-cycle-force-archived "org-cycle" ())
(declare-function org-force-self-insert "org" (n))
(declare-function org-forward-element "org" ())
(declare-function org-forward-heading-same-level "org" (arg &optional invisible-ok))
(declare-function org-forward-paragraph "org" ())
(declare-function org-forward-sentence "org" (&optional arg))
(declare-function org-goto "org" (&optional alternative-interface))
(declare-function org-goto-calendar "org" (&optional arg))
(declare-function org-inc-effort "org" ())
(declare-function org-increase-number-at-point "org" (&optional inc))
(declare-function org-info-find-node "org" (&optional nodename))
(declare-function org-insert-all-links "org" (arg &optional pre post))
(declare-function org-insert-drawer "org" (&optional arg drawer))
(declare-function org-insert-heading-respect-content "org" (&optional invisible-ok))
(declare-function org-insert-last-stored-link "org" (arg))
(declare-function org-insert-link "org" (&optional complete-file link-location default-description))
(declare-function org-insert-structure-template "org" (type))
(declare-function org-insert-todo-heading "org" (arg &optional force-heading))
(declare-function org-insert-todo-heading-respect-content "org" (&optional force-state))
(declare-function org-kill-line "org" (&optional arg))
(declare-function org-kill-note-or-show-branches "org" ())
(declare-function org-list-make-subtree "org" ())
(declare-function org-mark-element "org" ())
(declare-function org-mark-ring-goto "org" (&optional n))
(declare-function org-mark-ring-push "org" (&optional pos buffer))
(declare-function org-mark-subtree "org" (&optional up))
(declare-function org-match-sparse-tree "org" (&optional todo-only match))
(declare-function org-meta-return "org" (&optional arg))
(declare-function org-metadown "org" (&optional _arg))
(declare-function org-metaleft "org" (&optional _))
(declare-function org-metaright "org" (&optional _arg))
(declare-function org-metaup "org" (&optional _arg))
(declare-function org-narrow-to-block "org" ())
(declare-function org-narrow-to-element "org" ())
(declare-function org-narrow-to-subtree "org" (&optional element))
(declare-function org-next-block "org" (arg &optional backward block-regexp))
(declare-function org-next-link "org" (&optional search-backward))
(declare-function org-next-visible-heading "org" (arg))
(declare-function org-open-at-mouse "org" (ev))
(declare-function org-open-at-point "org" (&optional arg reference-buffer))
(declare-function org-open-line "org" (n))
(declare-function org-paste-special "org" (arg))
(declare-function org-plot/gnuplot "org-plot" (&optional params))
(declare-function org-previous-block "org" (arg &optional block-regexp))
(declare-function org-previous-link "org" ())
(declare-function org-previous-visible-heading "org" (arg))
(declare-function org-priority "org" (&optional action show))
(declare-function org-promote-subtree "org" ())
(declare-function org-redisplay-inline-images "org" ())
(declare-function org-refile "org-refile" (&optional arg1 default-buffer rfloc msg))
(declare-function org-refile-copy "org-refile" ())
(declare-function org-refile-reverse "org-refile" (&optional arg default-buffer rfloc msg))
(declare-function org-reftex-citation "org" ())
(declare-function org-reload "org" (&optional arg1))
(declare-function org-remove-file "org" (&optional file))
(declare-function org-resolve-clocks "org" (&optional only-dangling-p prompt-fn last-valid))
(declare-function org-return "org" (&optional indent))
(declare-function org-return-and-maybe-indent "org" ())
(declare-function org-fold-reveal "org-fold" (&optional siblings))
(declare-function org-schedule "org" (arg &optional time))
(declare-function org-self-insert-command "org" (N))
(declare-function org-set-effort "org" (&optional increment value))
(declare-function org-set-property "org" (property value))
(declare-function org-set-property-and-value "org" (use-last))
(declare-function org-set-tags-command "org" (&optional arg))
(declare-function org-shiftcontroldown "org" (&optional n))
(declare-function org-shiftcontrolleft "org" ())
(declare-function org-shiftcontrolright "org" ())
(declare-function org-shiftcontrolup "org" (&optional n))
(declare-function org-shiftdown "org" (&optional arg))
(declare-function org-shiftleft "org" (&optional arg))
(declare-function org-shiftmetadown "org" (&optional _arg))
(declare-function org-shiftmetaleft "org" ())
(declare-function org-shiftmetaright "org" ())
(declare-function org-shiftmetaup "org" (&optional arg))
(declare-function org-shiftright "org" (&optional arg))
(declare-function org-shifttab "org" (&optional arg))
(declare-function org-shiftup "org" (&optional arg))
(declare-function org-fold-show-all "org-fold" (&optional types))
(declare-function org-fold-show-children "org-fold" (&optional level))
(declare-function org-fold-show-subtree "org-fold" ())
(declare-function org-sort "org" (&optional with-case))
(declare-function org-sparse-tree "org" (&optional arg type))
(declare-function org-table-copy-down "org" (n))
(declare-function org-table-create-or-convert-from-region "org" (arg))
(declare-function org-table-create-with-table\.el "org-table" ())
(declare-function org-table-edit-field "org" (arg))
(declare-function org-table-eval-formula "org" (&optional arg equation suppress-align suppress-const suppress-store suppress-analysis))
(declare-function org-table-field-info "org" (arg))
(declare-function org-table-rotate-recalc-marks "org" (&optional newchar))
(declare-function org-table-sum "org" (&optional beg end nlast))
(declare-function org-table-toggle-coordinate-overlays "org" ())
(declare-function org-table-toggle-formula-debugger "org" ())
(declare-function org-timestamp "org" (arg &optional inactive))
(declare-function org-timestamp-inactive "org" (&optional arg))
(declare-function org-timer "org" (&optional restart no-insert))
(declare-function org-timer-item "org" (&optional arg))
(declare-function org-timer-pause-or-continue "org" (&optional stop))
(declare-function org-timer-set-timer "org" (&optional opt))
(declare-function org-timer-start "org" (&optional offset))
(declare-function org-timer-stop "org" ())
(declare-function org-todo "org" (&optional arg1))
(declare-function org-toggle-archive-tag "org" (&optional find-done))
(declare-function org-toggle-checkbox "org" (&optional toggle-presence))
(declare-function org-toggle-radio-button "org" (&optional arg))
(declare-function org-toggle-comment "org" ())
(declare-function org-toggle-fixed-width "org" ())
(declare-function org-toggle-inline-images "org" (&optional include-linked beg end))
(declare-function org-latex-preview "org" (&optional arg))
(declare-function org-toggle-narrow-to-subtree "org" ())
(declare-function org-toggle-ordered-property "org" ())
(declare-function org-toggle-pretty-entities "org" ())
(declare-function org-toggle-tags-groups "org" ())
(declare-function org-toggle-timestamp-overlays "org" ())
(declare-function org-transpose-element "org" ())
(declare-function org-transpose-words "org" ())
(declare-function org-tree-to-indirect-buffer "org" (&optional arg))
(declare-function org-up-element "org" ())
(declare-function org-update-statistics-cookies "org" (all))
(declare-function org-yank "org" (&optional arg))
(declare-function orgtbl-ascii-plot "org-table" (&optional ask))
;;; Variables
(defvar org-mode-map (make-sparse-keymap)
"Keymap for Org mode.")
(defvaralias 'org-CUA-compatible 'org-replace-disputed-keys)
(defcustom org-replace-disputed-keys nil
"Non-nil means use alternative key bindings for some keys.
Org mode uses S-<cursor> keys for changing timestamps and priorities.
These keys are also used by other packages like Shift Select mode,
CUA mode or Windmove. If you want to use Org mode together with
one of these other modes, or more generally if you would like to
move some Org mode commands to other keys, set this variable and
configure the keys with the variable `org-disputed-keys'.
This option is only relevant at load-time of Org mode, and must be set
*before* org.el is loaded. Changing it requires a restart of Emacs to
become effective."
:group 'org-startup
:type 'boolean
:safe #'booleanp)
(defcustom org-use-extra-keys nil
"Non-nil means use extra key sequence definitions for certain commands.
This happens automatically if `display-graphic-p' returns nil. This
variable lets you do the same manually. You must set it before
loading Org."
:group 'org-startup
:type 'boolean
:safe #'booleanp)
(defcustom org-disputed-keys
'(([(shift up)] . [(meta p)])
([(shift down)] . [(meta n)])
([(shift left)] . [(meta -)])
([(shift right)] . [(meta +)])
([(control shift right)] . [(meta shift +)])
([(control shift left)] . [(meta shift -)]))
"Keys for which Org mode and other modes compete.
This is an alist, cars are the default keys, second element specifies
the alternative to use when `org-replace-disputed-keys' is t.
Keys can be specified in any syntax supported by `define-key'.
The value of this option takes effect only at Org mode startup,
therefore you'll have to restart Emacs to apply it after changing."
:group 'org-startup
:type 'alist)
(defcustom org-mouse-1-follows-link
(if (boundp 'mouse-1-click-follows-link) mouse-1-click-follows-link t)
"Non-nil means Mouse-1 on a link will follow the link.
A longer mouse click will still set point. Needs to be set
before org.el is loaded."
:group 'org-link-follow
:version "26.1"
:package-version '(Org . "8.3")
:type '(choice
(const :tag "A double click follows the link" double)
(const :tag "Unconditionally follow the link with mouse-1" t)
(integer :tag "mouse-1 click does not follow the link if longer than N ms" 450)))
(defcustom org-tab-follows-link nil
"Non-nil means on links TAB will follow the link.
Needs to be set before Org is loaded.
This really should not be used, it does not make sense, and the
implementation is bad."
:group 'org-link-follow
:type 'boolean)
(defcustom org-follow-link-hook nil
"Hook that is run after a link has been followed."
:group 'org-link-follow
:type 'hook)
(defcustom org-return-follows-link nil
"Non-nil means on links RET will open links, timestamps, and citations.
In tables, the special behavior of RET has precedence."
:group 'org-link-follow
:type 'boolean
:safe #'booleanp)
;;; Functions
;;;; Base functions
(defun org-key (key)
"Select KEY according to `org-replace-disputed-keys' and `org-disputed-keys'.
Or return the original if not disputed."
(when org-replace-disputed-keys
(let* ((nkey (key-description key))
(x (cl-find-if (lambda (x) (equal (key-description (car x)) nkey))
org-disputed-keys)))
(setq key (if x (cdr x) key))))
key)
(defun org-defkey (keymap key def)
"Define KEY, possibly translated, as returned by `org-key' in KEYMAP to DEF."
(define-key keymap (org-key key) def))
(defun org-remap (map &rest commands)
"In MAP, remap the functions given in COMMANDS.
COMMANDS is a list of alternating OLDDEF NEWDEF command names."
(let (new old)
(while commands
(setq old (pop commands) new (pop commands))
(org-defkey map (vector 'remap old) new))))
;;; Mouse map
(defvar org-mouse-map (make-sparse-keymap))
(org-defkey org-mouse-map [mouse-2] 'org-open-at-mouse)
(org-defkey org-mouse-map [mouse-3] 'org-find-file-at-mouse)
(when org-mouse-1-follows-link
(org-defkey org-mouse-map [follow-link] 'mouse-face))
(when org-tab-follows-link
(org-defkey org-mouse-map (kbd "TAB") #'org-open-at-point))
;;; Read date map
(defvar org-read-date-minibuffer-local-map
(let* ((map (make-sparse-keymap)))
(set-keymap-parent map minibuffer-local-map)
(org-defkey map (kbd ".") #'org-calendar-goto-today-or-insert-dot)
(org-defkey map (kbd "C-.") #'org-calendar-goto-today)
(org-defkey map (kbd "M-S-<left>") #'org-calendar-backward-month)
(org-defkey map (kbd "ESC S-<left>") #'org-calendar-backward-month)
(org-defkey map (kbd "M-S-<right>") #'org-calendar-forward-month)
(org-defkey map (kbd "ESC S-<right>") #'org-calendar-forward-month)
(org-defkey map (kbd "M-S-<up>") #'org-calendar-backward-year)
(org-defkey map (kbd "ESC S-<up>") #'org-calendar-backward-year)
(org-defkey map (kbd "M-S-<down>") #'org-calendar-forward-year)
(org-defkey map (kbd "ESC S-<down>") #'org-calendar-forward-year)
(org-defkey map (kbd "S-<up>") #'org-calendar-backward-week)
(org-defkey map (kbd "S-<down>") #'org-calendar-forward-week)
(org-defkey map (kbd "S-<left>") #'org-calendar-backward-day)
(org-defkey map (kbd "S-<right>") #'org-calendar-forward-day)
(org-defkey map (kbd "!") #'org-calendar-view-entries)
(org-defkey map (kbd ">") #'org-calendar-scroll-month-left)
(org-defkey map (kbd "<") #'org-calendar-scroll-month-right)
(org-defkey map (kbd "C-v") #'org-calendar-scroll-three-months-left)
(org-defkey map (kbd "M-v") #'org-calendar-scroll-three-months-right)
map)
"Keymap for minibuffer commands when using `org-read-date'.")
;;; Global bindings
;;;; Outline functions
(define-key org-mode-map [menu-bar headings] 'undefined)
(define-key org-mode-map [menu-bar hide] 'undefined)
(define-key org-mode-map [menu-bar show] 'undefined)
(define-key org-mode-map [remap outline-mark-subtree] #'org-mark-subtree)
(define-key org-mode-map [remap outline-show-subtree] #'org-fold-show-subtree)
(define-key org-mode-map [remap outline-forward-same-level]
#'org-forward-heading-same-level)
(define-key org-mode-map [remap outline-backward-same-level]
#'org-backward-heading-same-level)
(define-key org-mode-map [remap outline-show-branches]
#'org-kill-note-or-show-branches)
(define-key org-mode-map [remap outline-promote] #'org-promote-subtree)
(define-key org-mode-map [remap outline-demote] #'org-demote-subtree)
(define-key org-mode-map [remap outline-insert-heading] #'org-ctrl-c-ret)
(define-key org-mode-map [remap outline-next-visible-heading]
#'org-next-visible-heading)
(define-key org-mode-map [remap outline-previous-visible-heading]
#'org-previous-visible-heading)
(define-key org-mode-map [remap outline-show-children] #'org-fold-show-children)
;;;; Make `C-c C-x' a prefix key
(org-defkey org-mode-map (kbd "C-c C-x") (make-sparse-keymap))
;;;; TAB key with modifiers
(org-defkey org-mode-map (kbd "TAB") #'org-cycle)
(org-defkey org-mode-map (kbd "C-c C-<tab>") #'org-cycle-force-archived)
;; Override text-mode binding to expose `complete-symbol' for
;; pcomplete functionality.
(org-defkey org-mode-map (kbd "M-TAB") nil)
(org-defkey org-mode-map (kbd "ESC TAB") nil)
(org-defkey org-mode-map (kbd "S-TAB") #'org-shifttab)
(define-key org-mode-map (kbd "<backtab>") #'org-shifttab)
;;;; RET/<return> key with modifiers
(org-defkey org-mode-map (kbd "S-<return>") #'org-table-copy-down)
(org-defkey org-mode-map (kbd "S-RET") #'org-table-copy-down)
(org-defkey org-mode-map (kbd "M-S-<return>") #'org-insert-todo-heading)
(org-defkey org-mode-map (kbd "M-S-RET") #'org-insert-todo-heading)
(org-defkey org-mode-map (kbd "M-RET") #'org-meta-return)
;;;; Cursor keys with modifiers
(org-defkey org-mode-map (kbd "M-<left>") #'org-metaleft)
(org-defkey org-mode-map (kbd "ESC <left>") #'org-metaleft)
(org-defkey org-mode-map (kbd "M-<right>") #'org-metaright)
(org-defkey org-mode-map (kbd "ESC <right>") #'org-metaright)
(org-defkey org-mode-map (kbd "M-<up>") #'org-metaup)
(org-defkey org-mode-map (kbd "ESC <up>") #'org-metaup)
(org-defkey org-mode-map (kbd "M-<down>") #'org-metadown)
(org-defkey org-mode-map (kbd "ESC <down>") #'org-metadown)
(org-defkey org-mode-map (kbd "C-M-S-<right>") #'org-increase-number-at-point)
(org-defkey org-mode-map (kbd "C-M-S-<left>") #'org-decrease-number-at-point)
(org-defkey org-mode-map (kbd "M-S-<left>") #'org-shiftmetaleft)
(org-defkey org-mode-map (kbd "ESC S-<left>") #'org-shiftmetaleft)
(org-defkey org-mode-map (kbd "M-S-<right>") #'org-shiftmetaright)
(org-defkey org-mode-map (kbd "ESC S-<right>") #'org-shiftmetaright)
(org-defkey org-mode-map (kbd "M-S-<up>") #'org-shiftmetaup)
(org-defkey org-mode-map (kbd "ESC S-<up>") #'org-shiftmetaup)
(org-defkey org-mode-map (kbd "M-S-<down>") #'org-shiftmetadown)
(org-defkey org-mode-map (kbd "ESC S-<down>") #'org-shiftmetadown)
(org-defkey org-mode-map (kbd "S-<up>") #'org-shiftup)
(org-defkey org-mode-map (kbd "S-<down>") #'org-shiftdown)
(org-defkey org-mode-map (kbd "S-<left>") #'org-shiftleft)
(org-defkey org-mode-map (kbd "S-<right>") #'org-shiftright)
(org-defkey org-mode-map (kbd "C-S-<right>") #'org-shiftcontrolright)
(org-defkey org-mode-map (kbd "C-S-<left>") #'org-shiftcontrolleft)
(org-defkey org-mode-map (kbd "C-S-<up>") #'org-shiftcontrolup)
(org-defkey org-mode-map (kbd "C-S-<down>") #'org-shiftcontroldown)
;;;; Extra keys for TTY access.
;; We only set them when really needed because otherwise the
;; menus don't show the simple keys
(when (or org-use-extra-keys (not (display-graphic-p)))
(org-defkey org-mode-map (kbd "C-c C-x c") #'org-table-copy-down)
(org-defkey org-mode-map (kbd "C-c C-x m") #'org-meta-return)
(org-defkey org-mode-map (kbd "C-c C-x M") #'org-insert-todo-heading)
(org-defkey org-mode-map (kbd "C-c C-x s") #'org-insert-structure-template)
(org-defkey org-mode-map (kbd "C-c C-x RET") #'org-meta-return)
(org-defkey org-mode-map (kbd "ESC RET") #'org-meta-return)
(org-defkey org-mode-map (kbd "ESC <left>") #'org-metaleft)
(org-defkey org-mode-map (kbd "C-c C-x l") #'org-metaleft)
(org-defkey org-mode-map (kbd "ESC <right>") #'org-metaright)
(org-defkey org-mode-map (kbd "C-c C-x r") #'org-metaright)
(org-defkey org-mode-map (kbd "C-c C-x u") #'org-metaup)
(org-defkey org-mode-map (kbd "C-c C-x d") #'org-metadown)
(org-defkey org-mode-map (kbd "C-c C-x L") #'org-shiftmetaleft)
(org-defkey org-mode-map (kbd "C-c C-x R") #'org-shiftmetaright)
(org-defkey org-mode-map (kbd "C-c C-x U") #'org-shiftmetaup)
(org-defkey org-mode-map (kbd "C-c C-x D") #'org-shiftmetadown)
(org-defkey org-mode-map (kbd "C-c <up>") #'org-shiftup)
(org-defkey org-mode-map (kbd "C-c <down>") #'org-shiftdown)
(org-defkey org-mode-map (kbd "C-c <left>") #'org-shiftleft)
(org-defkey org-mode-map (kbd "C-c <right>") #'org-shiftright)
(org-defkey org-mode-map (kbd "C-c C-x <right>") #'org-shiftcontrolright)
(org-defkey org-mode-map (kbd "C-c C-x <left>") #'org-shiftcontrolleft))
;;;; Narrowing bindings
(org-defkey org-mode-map (kbd "C-x n s") #'org-narrow-to-subtree)
(org-defkey org-mode-map (kbd "C-x n b") #'org-narrow-to-block)
(org-defkey org-mode-map (kbd "C-x n e") #'org-narrow-to-element)
;;;; Remap usual Emacs bindings
(org-remap org-mode-map
'self-insert-command 'org-self-insert-command
'delete-char 'org-delete-char
'delete-backward-char 'org-delete-backward-char
'kill-line 'org-kill-line
'open-line 'org-open-line
'yank 'org-yank
'comment-dwim 'org-comment-dwim
'move-beginning-of-line 'org-beginning-of-line
'move-end-of-line 'org-end-of-line
'forward-paragraph 'org-forward-paragraph
'backward-paragraph 'org-backward-paragraph
'backward-sentence 'org-backward-sentence
'forward-sentence 'org-forward-sentence
'fill-paragraph 'org-fill-paragraph
'delete-indentation 'org-delete-indentation
'transpose-words 'org-transpose-words)
;;;; All the other keys
(org-defkey org-mode-map (kbd "|") #'org-force-self-insert)
(org-defkey org-mode-map (kbd "C-c C-r") #'org-fold-reveal)
(org-defkey org-mode-map (kbd "C-M-t") #'org-transpose-element)
(org-defkey org-mode-map (kbd "M-}") #'org-forward-element)
(org-defkey org-mode-map (kbd "ESC }") #'org-forward-element)
(org-defkey org-mode-map (kbd "M-{") #'org-backward-element)
(org-defkey org-mode-map (kbd "ESC {") #'org-backward-element)
(org-defkey org-mode-map (kbd "C-c C-^") #'org-up-element)
(org-defkey org-mode-map (kbd "C-c C-_") #'org-down-element)
(org-defkey org-mode-map (kbd "C-c C-f") #'org-forward-heading-same-level)
(org-defkey org-mode-map (kbd "C-c C-b") #'org-backward-heading-same-level)
(org-defkey org-mode-map (kbd "C-c M-f") #'org-next-block)
(org-defkey org-mode-map (kbd "C-c M-b") #'org-previous-block)
(org-defkey org-mode-map (kbd "C-c $") #'org-archive-subtree)
(org-defkey org-mode-map (kbd "C-c C-x C-s") #'org-archive-subtree)
(org-defkey org-mode-map (kbd "C-c C-x C-a") #'org-archive-subtree-default)
(org-defkey org-mode-map (kbd "C-c C-x d") #'org-insert-drawer)
(org-defkey org-mode-map (kbd "C-c C-x a") #'org-toggle-archive-tag)
(org-defkey org-mode-map (kbd "C-c C-x A") #'org-archive-to-archive-sibling)
(org-defkey org-mode-map (kbd "C-c C-x b") #'org-tree-to-indirect-buffer)
(org-defkey org-mode-map (kbd "C-c C-x q") #'org-toggle-tags-groups)
(org-defkey org-mode-map (kbd "C-c C-j") #'org-goto)
(org-defkey org-mode-map (kbd "C-c C-t") #'org-todo)
(org-defkey org-mode-map (kbd "C-c C-q") #'org-set-tags-command)
(org-defkey org-mode-map (kbd "C-c C-s") #'org-schedule)
(org-defkey org-mode-map (kbd "C-c C-d") #'org-deadline)
(org-defkey org-mode-map (kbd "C-c ;") #'org-toggle-comment)
(org-defkey org-mode-map (kbd "C-c C-w") #'org-refile)
(org-defkey org-mode-map (kbd "C-c M-w") #'org-refile-copy)
(org-defkey org-mode-map (kbd "C-c C-M-w") #'org-refile-reverse)
(org-defkey org-mode-map (kbd "C-c /") #'org-sparse-tree) ;minor-mode reserved
(org-defkey org-mode-map (kbd "C-c \\") #'org-match-sparse-tree) ;minor-mode r.
(org-defkey org-mode-map (kbd "C-c RET") #'org-ctrl-c-ret)
(org-defkey org-mode-map (kbd "C-c C-x c") #'org-clone-subtree-with-time-shift)
(org-defkey org-mode-map (kbd "C-c C-x v") #'org-copy-visible)
(org-defkey org-mode-map (kbd "C-<return>") #'org-insert-heading-respect-content)
(org-defkey org-mode-map (kbd "C-S-<return>") #'org-insert-todo-heading-respect-content)
(org-defkey org-mode-map (kbd "C-c C-x C-n") #'org-next-link)
(org-defkey org-mode-map (kbd "C-c C-x C-p") #'org-previous-link)
(org-defkey org-mode-map (kbd "C-c C-l") #'org-insert-link)
(org-defkey org-mode-map (kbd "C-c M-l") #'org-insert-last-stored-link)
(org-defkey org-mode-map (kbd "C-c C-M-l") #'org-insert-all-links)
(org-defkey org-mode-map (kbd "C-c C-o") #'org-open-at-point)
(org-defkey org-mode-map (kbd "C-c %") #'org-mark-ring-push)
(org-defkey org-mode-map (kbd "C-c &") #'org-mark-ring-goto)
(org-defkey org-mode-map (kbd "C-c C-z") #'org-add-note) ;alternative binding
(org-defkey org-mode-map (kbd "C-c .") #'org-timestamp) ;minor-mode reserved
(org-defkey org-mode-map (kbd "C-c !") #'org-timestamp-inactive) ;minor-mode r.
(org-defkey org-mode-map (kbd "C-c ,") #'org-priority) ;minor-mode reserved
(org-defkey org-mode-map (kbd "C-c C-y") #'org-evaluate-time-range)
(org-defkey org-mode-map (kbd "C-c >") #'org-goto-calendar)
(org-defkey org-mode-map (kbd "C-c <") #'org-date-from-calendar)
(org-defkey org-mode-map (kbd "C-,") #'org-cycle-agenda-files)
(org-defkey org-mode-map (kbd "C-'") #'org-cycle-agenda-files)
(org-defkey org-mode-map (kbd "C-c [") #'org-agenda-file-to-front)
(org-defkey org-mode-map (kbd "C-c ]") #'org-remove-file)
(org-defkey org-mode-map (kbd "C-c C-x <") #'org-agenda-set-restriction-lock)
(org-defkey org-mode-map (kbd "C-c C-x >") #'org-agenda-remove-restriction-lock)
(org-defkey org-mode-map (kbd "C-c -") #'org-ctrl-c-minus)
(org-defkey org-mode-map (kbd "C-c *") #'org-ctrl-c-star)
(org-defkey org-mode-map (kbd "C-c TAB") #'org-ctrl-c-tab)
(org-defkey org-mode-map (kbd "C-c ^") #'org-sort)
(org-defkey org-mode-map (kbd "C-c C-c") #'org-ctrl-c-ctrl-c)
(org-defkey org-mode-map (kbd "C-c C-k") #'org-kill-note-or-show-branches)
(org-defkey org-mode-map (kbd "C-c #") #'org-update-statistics-cookies)
(org-defkey org-mode-map (kbd "RET") #'org-return)
(org-defkey org-mode-map (kbd "C-j") #'org-return-and-maybe-indent)
(org-defkey org-mode-map (kbd "C-c ?") #'org-table-field-info)
(org-defkey org-mode-map (kbd "C-c +") #'org-table-sum)
(org-defkey org-mode-map (kbd "C-c =") #'org-table-eval-formula)
(org-defkey org-mode-map (kbd "C-c '") #'org-edit-special)
(org-defkey org-mode-map (kbd "C-c `") #'org-table-edit-field)
(org-defkey org-mode-map (kbd "C-c \" a") #'orgtbl-ascii-plot)
(org-defkey org-mode-map (kbd "C-c \" g") #'org-plot/gnuplot)
(org-defkey org-mode-map (kbd "C-c |") #'org-table-create-or-convert-from-region)
(org-defkey org-mode-map (kbd "C-#") #'org-table-rotate-recalc-marks)
(org-defkey org-mode-map (kbd "C-c ~") #'org-table-create-with-table.el)
(org-defkey org-mode-map (kbd "C-c C-a") #'org-attach)
(org-defkey org-mode-map (kbd "C-c }") #'org-table-toggle-coordinate-overlays)
(org-defkey org-mode-map (kbd "C-c {") #'org-table-toggle-formula-debugger)
(org-defkey org-mode-map (kbd "C-c C-e") #'org-export-dispatch)
(org-defkey org-mode-map (kbd "C-c :") #'org-toggle-fixed-width)
(org-defkey org-mode-map (kbd "C-c C-x C-f") #'org-emphasize)
(org-defkey org-mode-map (kbd "C-c C-x f") #'org-footnote-action)
(org-defkey org-mode-map (kbd "C-c @") #'org-mark-subtree)
(org-defkey org-mode-map (kbd "M-h") #'org-mark-element)
(org-defkey org-mode-map (kbd "ESC h") #'org-mark-element)
(org-defkey org-mode-map (kbd "C-c C-*") #'org-list-make-subtree)
(org-defkey org-mode-map (kbd "C-c C-x C-w") #'org-cut-special)
(org-defkey org-mode-map (kbd "C-c C-x M-w") #'org-copy-special)
(org-defkey org-mode-map (kbd "C-c C-x C-y") #'org-paste-special)
(org-defkey org-mode-map (kbd "C-c C-x C-t") #'org-toggle-timestamp-overlays)
(org-defkey org-mode-map (kbd "C-c C-x C-i") #'org-clock-in)
(org-defkey org-mode-map (kbd "C-c C-x C-x") #'org-clock-in-last)
(org-defkey org-mode-map (kbd "C-c C-x C-z") #'org-resolve-clocks)
(org-defkey org-mode-map (kbd "C-c C-x C-o") #'org-clock-out)
(org-defkey org-mode-map (kbd "C-c C-x C-j") #'org-clock-goto)
(org-defkey org-mode-map (kbd "C-c C-x C-q") #'org-clock-cancel)
(org-defkey org-mode-map (kbd "C-c C-x C-d") #'org-clock-display)
(org-defkey org-mode-map (kbd "C-c C-x x") #'org-dynamic-block-insert-dblock)
(org-defkey org-mode-map (kbd "C-c C-x C-u") #'org-dblock-update)
(org-defkey org-mode-map (kbd "C-c C-x C-l") #'org-latex-preview)
(org-defkey org-mode-map (kbd "C-c C-x C-v") #'org-toggle-inline-images)
(org-defkey org-mode-map (kbd "C-c C-x C-M-v") #'org-redisplay-inline-images)
(org-defkey org-mode-map (kbd "C-c C-x \\") #'org-toggle-pretty-entities)
(org-defkey org-mode-map (kbd "C-c C-x C-b") #'org-toggle-checkbox)
(org-defkey org-mode-map (kbd "C-c C-x C-r") #'org-toggle-radio-button)
(org-defkey org-mode-map (kbd "C-c C-x p") #'org-set-property)
(org-defkey org-mode-map (kbd "C-c C-x P") #'org-set-property-and-value)
(org-defkey org-mode-map (kbd "C-c C-x e") #'org-set-effort)
(org-defkey org-mode-map (kbd "C-c C-x E") #'org-inc-effort)
(org-defkey org-mode-map (kbd "C-c C-x o") #'org-toggle-ordered-property)
(org-defkey org-mode-map (kbd "C-c C-,") #'org-insert-structure-template)
(org-defkey org-mode-map (kbd "C-c C-x .") #'org-timer)
(org-defkey org-mode-map (kbd "C-c C-x -") #'org-timer-item)
(org-defkey org-mode-map (kbd "C-c C-x 0") #'org-timer-start)
(org-defkey org-mode-map (kbd "C-c C-x _") #'org-timer-stop)
(org-defkey org-mode-map (kbd "C-c C-x ;") #'org-timer-set-timer)
(org-defkey org-mode-map (kbd "C-c C-x ,") #'org-timer-pause-or-continue)
(org-defkey org-mode-map (kbd "C-c C-x C-c") #'org-columns)
(org-defkey org-mode-map (kbd "C-c C-x !") #'org-reload)
(org-defkey org-mode-map (kbd "C-c C-x g") #'org-feed-update-all)
(org-defkey org-mode-map (kbd "C-c C-x G") #'org-feed-goto-inbox)
(org-defkey org-mode-map (kbd "C-c C-x @") #'org-cite-insert)
(org-defkey org-mode-map (kbd "C-c C-x [") #'org-reftex-citation)
(org-defkey org-mode-map (kbd "C-c C-x I") #'org-info-find-node)
;;; Speed keys
(defcustom org-use-speed-commands nil
"Non-nil means activate single letter commands at beginning of a headline.
This may also be a function to test for appropriate locations where speed
commands should be active.
For example, to activate speed commands when the point is on any
star at the beginning of the headline, you can do this:
(setq org-use-speed-commands
(lambda () (and (looking-at org-outline-regexp) (looking-back \"^\\**\"))))"
:group 'org-structure
:type '(choice
(const :tag "Never" nil)
(const :tag "At beginning of headline stars" t)
(function)))
(defcustom org-speed-command-hook
'(org-speed-command-activate org-babel-speed-command-activate)
"Hook for activating speed commands at strategic locations.
Hook functions are called in sequence until a valid handler is
found.
Each hook takes a single argument, a user-pressed command key
which is also a `self-insert-command' from the global map.
Within the hook, examine the cursor position and the command key
and return nil or a valid handler as appropriate. Handler could
be one of an interactive command, a function, or a form.
Set `org-use-speed-commands' to non-nil value to enable this
hook. The default setting is `org-speed-command-activate'."
:group 'org-structure
:version "24.1"
:type 'hook)
(defcustom org-speed-commands
'(("Outline Navigation")
("n" . (org-speed-move-safe 'org-next-visible-heading))
("p" . (org-speed-move-safe 'org-previous-visible-heading))
("f" . (org-speed-move-safe 'org-forward-heading-same-level))
("b" . (org-speed-move-safe 'org-backward-heading-same-level))
("F" . org-next-block)
("B" . org-previous-block)
("u" . (org-speed-move-safe 'outline-up-heading))
("j" . org-goto)
("g" . (org-refile '(4)))
("Outline Visibility")
("c" . org-cycle)
("C" . org-shifttab)
(" " . org-display-outline-path)
("s" . org-toggle-narrow-to-subtree)
("k" . org-cut-subtree)
("=" . org-columns)
("Outline Structure Editing")
("U" . org-metaup)
("D" . org-metadown)
("r" . org-metaright)
("l" . org-metaleft)
("R" . org-shiftmetaright)
("L" . org-shiftmetaleft)
("i" . (progn (forward-char 1) (call-interactively 'org-insert-heading-respect-content)))
("^" . org-sort)
("w" . org-refile)
("a" . org-archive-subtree-default-with-confirmation)
("@" . org-mark-subtree)
("#" . org-toggle-comment)
("Clock Commands")
("I" . org-clock-in)
("O" . org-clock-out)
("Meta Data Editing")
("t" . org-todo)
("," . (org-priority))
("0" . (org-priority ?\ ))
("1" . (org-priority ?A))
("2" . (org-priority ?B))
("3" . (org-priority ?C))
(":" . org-set-tags-command)
("e" . org-set-effort)
("E" . org-inc-effort)
("W" . (lambda (m) (interactive "sMinutes before warning: ") (org-entry-put (point) "APPT_WARNTIME" m)))
("Agenda Views etc")
("v" . org-agenda)
("/" . org-sparse-tree)
("Misc")
("o" . org-open-at-point)
("?" . org-speed-command-help)
("<" . (org-agenda-set-restriction-lock 'subtree))
(">" . (org-agenda-remove-restriction-lock)))
"Alist of speed commands.
The car of each entry is a string with a single letter, which
must be assigned to `self-insert-command' in the global map.
The cdr is either a command to be called interactively, a
function to be called, or a form to be evaluated.
An entry that is just a list with a single string will be
interpreted as a descriptive headline that will be added when
listing the speed commands in the Help buffer using the `?' speed
command."
:group 'org-structure
:package-version '(Org . "9.5")
:type '(repeat :value ("k" . ignore)
(choice :value ("k" . ignore)
(list :tag "Descriptive Headline" (string :tag "Headline"))
(cons :tag "Letter and Command"
(string :tag "Command letter")
(choice
(function)
(sexp))))))
(defun org--print-speed-command (speed-command)
"Print information about SPEED-COMMAND in help buffer.
SPEED-COMMAND is an element of `org-speed-commands'."
(if (> (length (car speed-command)) 1)
(progn
(princ "\n")
(princ (car speed-command))
(princ "\n")
(princ (make-string (length (car speed-command)) ?-))
(princ "\n"))
(princ (car speed-command))
(princ " ")
(if (symbolp (cdr speed-command))
(princ (symbol-name (cdr speed-command)))
(prin1 (cdr speed-command)))
(princ "\n")))
(defun org-speed-command-help ()
"Show the available speed commands."
(interactive)
(unless org-use-speed-commands
(user-error "Speed commands are not activated, customize `org-use-speed-commands'"))
(with-output-to-temp-buffer "*Help*"
(princ "Speed commands\n==============\n")
(mapc #'org--print-speed-command org-speed-commands))
(with-current-buffer "*Help*"
(setq truncate-lines t)))
(defun org-speed-move-safe (cmd)
"Execute CMD, but make sure that the cursor always ends up in a headline.
If not, return to the original position and throw an error."
(interactive)
(let ((pos (point)))
(call-interactively cmd)
(unless (and (bolp) (org-at-heading-p))
(goto-char pos)
(error "Boundary reached while executing %s" cmd))))
(defun org-speed-command-activate (keys)
"Hook for activating single-letter speed commands.
KEYS is the keys vector as returned by `this-command-keys-vector'.
See `org-speed-commands' for configuring them."
(when (or (and (bolp) (looking-at org-outline-regexp))
(and (functionp org-use-speed-commands)
(funcall org-use-speed-commands)))
(cdr (assoc keys org-speed-commands))))
;;; Babel speed keys
(defvar org-babel-key-prefix "\C-c\C-v"
"The key prefix for Babel interactive key-bindings.
See `org-babel-key-bindings' for the list of interactive Babel
functions which are assigned key bindings, and see
`org-babel-map' for the actual babel keymap.")
(defvar org-babel-map (make-sparse-keymap)
"The keymap for interactive Babel functions.")
(defvar org-babel-key-bindings
'(("p" . org-babel-previous-src-block)
("\C-p" . org-babel-previous-src-block)
("n" . org-babel-next-src-block)
("\C-n" . org-babel-next-src-block)
("e" . org-babel-execute-maybe)
("\C-e" . org-babel-execute-maybe)
("o" . org-babel-open-src-block-result)
("\C-o" . org-babel-open-src-block-result)
("\C-v" . org-babel-expand-src-block)
("v" . org-babel-expand-src-block)
("u" . org-babel-goto-src-block-head)
("\C-u" . org-babel-goto-src-block-head)
("g" . org-babel-goto-named-src-block)
("r" . org-babel-goto-named-result)
("\C-r" . org-babel-goto-named-result)
("\C-b" . org-babel-execute-buffer)
("b" . org-babel-execute-buffer)
("\C-s" . org-babel-execute-subtree)
("s" . org-babel-execute-subtree)
("\C-d" . org-babel-demarcate-block)
("d" . org-babel-demarcate-block)
("\C-t" . org-babel-tangle)
("t" . org-babel-tangle)
("\C-f" . org-babel-tangle-file)
("f" . org-babel-tangle-file)
("\C-c" . org-babel-check-src-block)
("c" . org-babel-check-src-block)
("\C-j" . org-babel-insert-header-arg)
("j" . org-babel-insert-header-arg)
("\C-l" . org-babel-load-in-session)
("l" . org-babel-load-in-session)
("\C-i" . org-babel-lob-ingest)
("i" . org-babel-lob-ingest)
("\C-I" . org-babel-view-src-block-info)
("I" . org-babel-view-src-block-info)
("\C-z" . org-babel-switch-to-session)
("z" . org-babel-switch-to-session-with-code)
("\C-a" . org-babel-sha1-hash)
("a" . org-babel-sha1-hash)
("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
with keys. Each element of this list will add an entry to the
`org-babel-map' using the letter key which is the `car' of the
a-list placed behind the generic `org-babel-key-prefix'.")
(define-key org-mode-map org-babel-key-prefix org-babel-map)
(pcase-dolist (`(,key . ,def) org-babel-key-bindings)
(define-key org-babel-map key def))
(defun org-babel-speed-command-activate (keys)
"Hook for activating single-letter code block commands.
KEYS is the keys vector as returned by `this-command-keys-vector'."
(when (and (bolp)
(let ((case-fold-search t)) (looking-at "[ \t]*#\\+begin_src"))
(org-element-type-p (org-element-at-point) 'src-block))
(cdr (assoc keys org-babel-key-bindings))))
;;;###autoload
(defun org-babel-describe-bindings ()
"Describe all keybindings behind `org-babel-key-prefix'."
(interactive)
(describe-bindings org-babel-key-prefix))
(provide 'org-keys)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; org-keys.el ends here
org-mode-9.7.29+dfsg/lisp/org-lint.el 0000664 0000000 0000000 00000207522 15004304337 0017305 0 ustar 00root root 0000000 0000000 ;;; org-lint.el --- Linting for Org documents -*- lexical-binding: t; -*-
;; Copyright (C) 2015-2025 Free Software Foundation, Inc.
;; Author: Nicolas Goaziou <mail@nicolasgoaziou.fr>
;; Keywords: outlines, hypermedia, calendar, text
;; 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;; This library implements linting for Org syntax. The process is
;; started by calling `org-lint' command, which see.
;; New checkers are added by `org-lint-add-checker' function.
;; Internally, all checks are listed in `org-lint--checkers'.
;; Results are displayed in a special "*Org Lint*" buffer with
;; a dedicated major mode, derived from `tabulated-list-mode'.
;; In addition to the usual key-bindings inherited from it, "C-j" and
;; "TAB" display problematic line reported under point whereas "RET"
;; jumps to it. Also, "h" hides all reports similar to the current
;; one. Additionally, "i" removes them from subsequent reports.
;; Checks currently implemented report the following:
;; - duplicates CUSTOM_ID properties,
;; - duplicate NAME values,
;; - duplicate targets,
;; - duplicate footnote definitions,
;; - orphaned affiliated keywords,
;; - obsolete affiliated keywords,
;; - deprecated export block syntax,
;; - deprecated Babel header syntax,
;; - missing language in source blocks,
;; - missing backend in export blocks,
;; - invalid Babel call blocks,
;; - NAME values with a colon,
;; - wrong babel headers,
;; - invalid value in babel headers,
;; - misuse of CATEGORY keyword,
;; - "coderef" links with unknown destination,
;; - "custom-id" links with unknown destination,
;; - "fuzzy" links with unknown destination,
;; - "id" links with unknown destination,
;; - links to non-existent local files,
;; - SETUPFILE keywords with non-existent file parameter,
;; - INCLUDE keywords with misleading link parameter,
;; - obsolete markup in INCLUDE keyword,
;; - unknown items in OPTIONS keyword,
;; - spurious macro arguments or invalid macro templates,
;; - special properties in properties drawers,
;; - obsolete syntax for properties drawers,
;; - invalid duration in EFFORT property,
;; - invalid ID property with a double colon,
;; - missing definition for footnote references,
;; - missing reference for footnote definitions,
;; - non-footnote definitions in footnote section,
;; - probable invalid keywords,
;; - invalid blocks,
;; - mismatched repeaters in planning info line,
;; - misplaced planning info line,
;; - probable incomplete drawers,
;; - probable indented diary-sexps,
;; - obsolete QUOTE section,
;; - obsolete "file+application" link,
;; - obsolete escape syntax in links,
;; - spurious colons in tags,
;; - invalid bibliography file,
;; - missing "print_bibliography" keyword,
;; - invalid value for "cite_export" keyword,
;; - incomplete citation object.
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'cl-lib)
(require 'ob)
(require 'oc)
(require 'ol)
(require 'org-attach)
(require 'org-macro)
(require 'org-fold)
(require 'ox)
(require 'seq)
;;; Checkers structure
(cl-defstruct (org-lint-checker (:copier nil))
name summary function trust categories)
(defvar org-lint--checkers nil
"List of all available checkers.
This list is populated by `org-lint-add-checker' function.")
;;;###autoload
(defun org-lint-add-checker (name summary fun &rest props)
"Add a new checker for linter.
NAME is a unique check identifier, as a non-nil symbol. SUMMARY
is a short description of the check, as a string.
The check is done calling the function FUN with one mandatory
argument, the parse tree describing the current Org buffer. Such
function calls are wrapped within a `save-excursion' and point is
always at `point-min'. Its return value has to be an
alist (POSITION MESSAGE) where POSITION refer to the buffer
position of the error, as an integer, and MESSAGE is a one-line
string describing the error.
Optional argument PROPS provides additional information about the
checker. Currently, two properties are supported:
`:categories'
Categories relative to the check, as a list of symbol. They
are used for filtering when calling `org-lint'. Checkers
not explicitly associated to a category are collected in the
`default' one.
`:trust'
The trust level one can have in the check. It is either
`low' or `high', depending on the heuristics implemented and
the nature of the check. This has an indicative value only
and is displayed along reports."
(declare (indent 1))
;; Sanity checks.
(pcase name
(`nil (error "Name field is mandatory for checkers"))
((pred symbolp) nil)
(_ (error "Invalid type for name field")))
(unless (functionp fun)
(error "Checker field is expected to be a valid function"))
;; Install checker in `org-lint--checkers'; uniquify by name.
(setq org-lint--checkers
(cons (apply #'make-org-lint-checker
:name name
:summary summary
:function fun
props)
(seq-remove (lambda (c) (eq name (org-lint-checker-name c)))
org-lint--checkers))))
;;; Reports UI
(defvar org-lint--report-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map tabulated-list-mode-map)
(define-key map (kbd "RET") 'org-lint--jump-to-source)
(define-key map (kbd "TAB") 'org-lint--show-source)
(define-key map (kbd "C-j") 'org-lint--show-source)
(define-key map (kbd "h") 'org-lint--hide-checker)
(define-key map (kbd "i") 'org-lint--ignore-checker)
map)
"Local keymap for `org-lint--report-mode' buffers.")
(define-derived-mode org-lint--report-mode tabulated-list-mode "OrgLint"
"Major mode used to display reports emitted during linting.
\\{org-lint--report-mode-map}"
(setf tabulated-list-format
`[("Line" 6
(lambda (a b)
(< (string-to-number (aref (cadr a) 0))
(string-to-number (aref (cadr b) 0))))
:right-align t)
("Trust" 5 t)
("Warning" 0 t)])
(tabulated-list-init-header))
(defun org-lint--generate-reports (buffer checkers)
"Generate linting report for BUFFER.
CHECKERS is the list of checkers used.
Return an alist (ID [LINE TRUST DESCRIPTION CHECKER]), suitable
for `tabulated-list-printer'."
(with-current-buffer buffer
(save-excursion
(goto-char (point-min))
(let ((ast (org-element-parse-buffer nil nil 'defer))
(id 0)
(last-line 1)
(last-pos 1))
;; Insert unique ID for each report. Replace buffer positions
;; with line numbers.
(mapcar
(lambda (report)
(list
(cl-incf id)
(apply #'vector
(cons
(progn
(goto-char (car report))
(forward-line 0)
(prog1 (propertize
(number-to-string
(cl-incf last-line
(count-lines last-pos (point))))
'org-lint-marker (car report))
(setf last-pos (point))))
(cdr report)))))
;; Insert trust level in generated reports. Also sort them
;; by buffer position in order to optimize lines computation.
(sort (cl-mapcan
(lambda (c)
(let ((trust (symbol-name (org-lint-checker-trust c))))
(mapcar
(lambda (report)
(list (copy-marker (car report)) trust (nth 1 report) c))
(save-excursion
(funcall (org-lint-checker-function c)
ast)))))
checkers)
#'car-less-than-car))))))
(defvar-local org-lint--source-buffer nil
"Source buffer associated to current report buffer.")
(defvar-local org-lint--local-checkers nil
"List of checkers used to build current report.")
(defun org-lint--refresh-reports ()
(setq tabulated-list-entries
(org-lint--generate-reports org-lint--source-buffer
org-lint--local-checkers))
(tabulated-list-print))
(defun org-lint--current-line ()
"Return current report line, as a number."
(string-to-number (aref (tabulated-list-get-entry) 0)))
(defun org-lint--current-marker ()
"Return current report marker."
(get-text-property 0 'org-lint-marker (aref (tabulated-list-get-entry) 0)))
(defun org-lint--current-checker (&optional entry)
"Return current report checker.
When optional argument ENTRY is non-nil, use this entry instead
of current one."
(aref (if entry (nth 1 entry) (tabulated-list-get-entry)) 3))
(defun org-lint--display-reports (source checkers)
"Display linting reports for buffer SOURCE.
CHECKERS is the list of checkers used."
(let ((buffer (get-buffer-create "*Org Lint*")))
(with-current-buffer buffer
(org-lint--report-mode)
(setf org-lint--source-buffer source)
(setf org-lint--local-checkers checkers)
(org-lint--refresh-reports)
(add-hook 'tabulated-list-revert-hook #'org-lint--refresh-reports nil t))
(pop-to-buffer buffer)))
(defun org-lint--jump-to-source ()
"Move to source line that generated the report at point."
(interactive)
(let ((mk (org-lint--current-marker)))
(switch-to-buffer-other-window org-lint--source-buffer)
(unless (<= (point-min) mk (point-max)) (widen))
(goto-char mk)
(org-fold-show-set-visibility 'local)
(recenter)))
(defun org-lint--show-source ()
"Show source line that generated the report at point."
(interactive)
(let ((buffer (current-buffer)))
(org-lint--jump-to-source)
(switch-to-buffer-other-window buffer)))
(defun org-lint--hide-checker ()
"Hide all reports from checker that generated the report at point."
(interactive)
(let ((c (org-lint--current-checker)))
(setf tabulated-list-entries
(cl-remove-if (lambda (e) (equal c (org-lint--current-checker e)))
tabulated-list-entries))
(tabulated-list-print)))
(defun org-lint--ignore-checker ()
"Ignore all reports from checker that generated the report at point.
Checker will also be ignored in all subsequent reports."
(interactive)
(setf org-lint--local-checkers
(remove (org-lint--current-checker) org-lint--local-checkers))
(org-lint--hide-checker))
;;; Main function
;;;###autoload
(defun org-lint (&optional arg)
"Check current Org buffer for syntax mistakes.
By default, run all checkers. With a `\\[universal-argument]' prefix ARG, \
select one
category of checkers only. With a `\\[universal-argument] \
\\[universal-argument]' prefix, run one precise
checker by its name.
ARG can also be a list of checker names, as symbols, to run."
(interactive "P")
(unless (derived-mode-p 'org-mode) (user-error "Not in an Org buffer"))
(when (called-interactively-p 'any)
(message "Org linting process starting..."))
(let ((checkers
(pcase arg
(`nil org-lint--checkers)
(`(4)
(let ((category
(completing-read
"Checker category: "
(mapcar #'org-lint-checker-categories org-lint--checkers)
nil t)))
(cl-remove-if-not
(lambda (c)
(assoc-string category (org-lint-checker-categories c)))
org-lint--checkers)))
(`(16)
(list
(let ((name (completing-read
"Checker name: "
(mapcar #'org-lint-checker-name org-lint--checkers)
nil t)))
(catch 'exit
(dolist (c org-lint--checkers)
(when (string= (org-lint-checker-name c) name)
(throw 'exit c)))))))
((pred consp)
(cl-remove-if-not (lambda (c) (memq (org-lint-checker-name c) arg))
org-lint--checkers))
(_ (user-error "Invalid argument `%S' for `org-lint'" arg)))))
(if (not (called-interactively-p 'any))
(org-lint--generate-reports (current-buffer) checkers)
(org-lint--display-reports (current-buffer) checkers)
(message "Org linting process completed"))))
;;; Checker functions
(defun org-lint--collect-duplicates
(ast type extract-key extract-position build-message)
"Helper function to collect duplicates in parse tree AST.
EXTRACT-KEY is a function extracting key. It is called with
a single argument: the element or object. Comparison is done
with `equal'.
EXTRACT-POSITION is a function returning position for the report.
It is called with two arguments, the object or element, and the
key.
BUILD-MESSAGE is a function creating the report message. It is
called with one argument, the key used for comparison."
(let* (keys
originals
reports
(make-report
(lambda (position value)
(push (list position (funcall build-message value)) reports))))
(org-element-map ast type
(lambda (datum)
(let ((key (funcall extract-key datum)))
(cond
((not key))
((assoc key keys) (cl-pushnew (assoc key keys) originals)
(funcall make-report (funcall extract-position datum key) key))
(t (push (cons key (funcall extract-position datum key)) keys))))))
(dolist (e originals reports) (funcall make-report (cdr e) (car e)))))
(defun org-lint-misplaced-heading (ast)
"Check for accidentally misplaced heading lines.
Example:
** Heading 1
** Heading 2** Oops heading 3
** Heading 4"
(org-with-point-at ast
(goto-char (point-min))
(let (result)
;; Heuristics for 2+ level heading not at bol.
(while (re-search-forward (rx (not (any "*\n\r ,")) ;; Not a bol; not escaped ,** heading; not " *** words"
"*" (1+ "*") " ") nil t)
;; Limit false-positive rate by only complaining about
;; ** Heading** Heading and
;; ** Oops heading
;; Paragraph** Oops heading
(when (org-element-type-p
(org-element-at-point)
'(paragraph headline))
(push (list (match-beginning 0) "Possibly misplaced heading line") result)))
result)))
(defun org-lint-duplicate-custom-id (ast)
(org-lint--collect-duplicates
ast
'node-property
(lambda (property)
(and (org-string-equal-ignore-case
"CUSTOM_ID" (org-element-property :key property))
(org-element-property :value property)))
(lambda (property _) (org-element-begin property))
(lambda (key) (format "Duplicate CUSTOM_ID property \"%s\"" key))))
(defun org-lint-duplicate-name (ast)
(org-lint--collect-duplicates
ast
org-element-all-elements
(lambda (datum) (org-element-property :name datum))
(lambda (datum name)
(goto-char (org-element-begin datum))
(re-search-forward
(format "^[ \t]*#\\+[A-Za-z]+:[ \t]*%s[ \t]*$" (regexp-quote name)))
(match-beginning 0))
(lambda (key) (format "Duplicate NAME \"%s\"" key))))
(defun org-lint-duplicate-target (ast)
(org-lint--collect-duplicates
ast
'target
(lambda (target) (split-string (org-element-property :value target)))
(lambda (target _) (org-element-begin target))
(lambda (key)
(format "Duplicate target <<%s>>" (mapconcat #'identity key " ")))))
(defun org-lint-duplicate-footnote-definition (ast)
(org-lint--collect-duplicates
ast
'footnote-definition
(lambda (definition) (org-element-property :label definition))
(lambda (definition _) (org-element-post-affiliated definition))
(lambda (key) (format "Duplicate footnote definition \"%s\"" key))))
(defun org-lint-orphaned-affiliated-keywords (ast)
;; Ignore orphan RESULTS keywords, which could be generated from
;; a source block returning no value.
(let ((keywords (cl-set-difference org-element-affiliated-keywords
'("RESULT" "RESULTS")
:test #'equal)))
(org-element-map ast 'keyword
(lambda (k)
(let ((key (org-element-property :key k)))
(and (or (let ((case-fold-search t))
(string-match-p "\\`ATTR_[-_A-Za-z0-9]+\\'" key))
(member key keywords))
(list (org-element-post-affiliated k)
(format "Orphaned affiliated keyword: \"%s\"" key))))))))
(defun org-lint-regular-keyword-before-affiliated (ast)
(org-element-map ast 'keyword
(lambda (keyword)
(when (= (org-element-post-blank keyword) 0)
(let ((next-element (org-with-point-at (org-element-end keyword)
(org-element-at-point))))
(when (< (org-element-begin next-element) (org-element-post-affiliated next-element))
;; A keyword followed without blank lines by an element with affiliated keywords.
;; The keyword may be confused with affiliated keywords.
(list (org-element-begin keyword)
(format "Independent keyword %s may be confused with affiliated keywords below"
(org-element-property :key keyword)))))))))
(defun org-lint-obsolete-affiliated-keywords (_)
(let ((regexp (format "^[ \t]*#\\+%s:"
(regexp-opt '("DATA" "LABEL" "RESNAME" "SOURCE"
"SRCNAME" "TBLNAME" "RESULT" "HEADERS")
t)))
reports)
(while (re-search-forward regexp nil t)
(let ((key (upcase (match-string-no-properties 1))))
(when (< (point)
(org-element-post-affiliated (org-element-at-point)))
(push
(list (line-beginning-position)
(format
"Obsolete affiliated keyword: \"%s\". Use \"%s\" instead"
key
(pcase key
("HEADERS" "HEADER")
("RESULT" "RESULTS")
(_ "NAME"))))
reports))))
reports))
(defun org-lint-deprecated-export-blocks (ast)
(let ((deprecated '("ASCII" "BEAMER" "HTML" "LATEX" "MAN" "MARKDOWN" "MD"
"ODT" "ORG" "TEXINFO")))
(org-element-map ast 'special-block
(lambda (b)
(let ((type (org-element-property :type b)))
(when (member-ignore-case type deprecated)
(list
(org-element-post-affiliated b)
(format
"Deprecated syntax for export block. Use \"BEGIN_EXPORT %s\" \
instead"
type))))))))
(defun org-lint-deprecated-header-syntax (ast)
(let* ((deprecated-babel-properties
;; DIR is also used for attachments.
(delete "dir"
(mapcar (lambda (arg) (downcase (symbol-name (car arg))))
org-babel-common-header-args-w-values)))
(deprecated-re
(format "\\`%s[ \t]" (regexp-opt deprecated-babel-properties t))))
(org-element-map ast '(keyword node-property)
(lambda (datum)
(let ((key (org-element-property :key datum)))
(pcase (org-element-type datum)
(`keyword
(let ((value (org-element-property :value datum)))
(and (string= key "PROPERTY")
(string-match deprecated-re value)
(list (org-element-begin datum)
(format "Deprecated syntax for \"%s\". \
Use header-args instead"
(match-string-no-properties 1 value))))))
(`node-property
(and (member-ignore-case key deprecated-babel-properties)
(list
(org-element-begin datum)
(format "Deprecated syntax for \"%s\". \
Use :header-args: instead"
key))))))))))
(defun org-lint-missing-language-in-src-block (ast)
(org-element-map ast 'src-block
(lambda (b)
(unless (org-element-property :language b)
(list (org-element-post-affiliated b)
"Missing language in source block")))))
(defun org-lint-suspicious-language-in-src-block (ast)
(org-element-map ast 'src-block
(lambda (b)
(when-let* ((lang (org-element-property :language b)))
(unless (or (functionp (intern (format "org-babel-execute:%s" lang)))
;; No babel backend, but there is corresponding
;; major mode.
(fboundp (org-src-get-lang-mode lang)))
(list (org-element-property :post-affiliated b)
(format "Unknown source block language: '%s'" lang)))))))
(defun org-lint-missing-backend-in-export-block (ast)
(org-element-map ast 'export-block
(lambda (b)
(unless (org-element-property :type b)
(list (org-element-post-affiliated b)
"Missing backend in export block")))))
(defun org-lint-invalid-babel-call-block (ast)
(org-element-map ast 'babel-call
(lambda (b)
(cond
((not (org-element-property :call b))
(list (org-element-post-affiliated b)
"Invalid syntax in babel call block"))
((let ((h (org-element-property :end-header b)))
(and h (string-match-p "\\`\\[.*\\]\\'" h)))
(list
(org-element-post-affiliated b)
"Babel call's end header must not be wrapped within brackets"))))))
(defun org-lint-deprecated-category-setup (ast)
(org-element-map ast 'keyword
(let (category-flag)
(lambda (k)
(cond
((not (string= (org-element-property :key k) "CATEGORY")) nil)
(category-flag
(list (org-element-post-affiliated k)
"Spurious CATEGORY keyword. Set :CATEGORY: property instead"))
(t (setf category-flag t) nil))))))
(defun org-lint-invalid-coderef-link (ast)
(let ((info (list :parse-tree ast)))
(org-element-map ast 'link
(lambda (link)
(let ((ref (org-element-property :path link)))
(and (equal (org-element-property :type link) "coderef")
(not (ignore-errors (org-export-resolve-coderef ref info)))
(list (org-element-begin link)
(format "Unknown coderef \"%s\"" ref))))))))
(defun org-lint-invalid-custom-id-link (ast)
(let ((info (list :parse-tree ast)))
(org-element-map ast 'link
(lambda (link)
(and (equal (org-element-property :type link) "custom-id")
(not (ignore-errors (org-export-resolve-id-link link info)))
(list (org-element-begin link)
(format "Unknown custom ID \"%s\""
(org-element-property :path link))))))))
(defun org-lint-invalid-fuzzy-link (ast)
(let ((info (list :parse-tree ast)))
(org-element-map ast 'link
(lambda (link)
(and (equal (org-element-property :type link) "fuzzy")
(not (ignore-errors (org-export-resolve-fuzzy-link link info)))
(list (org-element-begin link)
(format "Unknown fuzzy location \"%s\""
(let ((path (org-element-property :path link)))
(if (string-prefix-p "*" path)
(substring path 1)
path)))))))))
(defun org-lint-invalid-id-link (ast)
(let ((id-locations-updated nil))
(org-element-map ast 'link
(lambda (link)
(let ((id (org-element-property :path link)))
(and (equal (org-element-property :type link) "id")
(progn
(unless id-locations-updated
(org-id-update-id-locations nil t)
(setq id-locations-updated t))
t)
;; The locations are up-to-date with file changes after
;; the call to `org-id-update-id-locations'. We do not
;; need to double-check if recorded ID is still present
;; in the file.
(not (org-id-find-id-file id))
(list (org-element-begin link)
(format "Unknown ID \"%s\"" id))))))))
(defun org-lint-confusing-brackets (ast)
(org-element-map ast 'link
(lambda (link)
(org-with-wide-buffer
(when (eq (char-after (org-element-end link)) ?\])
(list (org-element-begin link)
(format "Trailing ']' after link end")))))))
(defun org-lint-brackets-inside-description (ast)
(org-element-map ast 'link
(lambda (link)
(when (org-element-contents-begin link)
(org-with-point-at link
(goto-char (org-element-contents-begin link))
(let ((count 0))
(while (re-search-forward (rx (or ?\] ?\[)) (org-element-contents-end link) t)
(if (equal (match-string 0) "[") (cl-incf count) (cl-decf count)))
(when (> count 0)
(list (org-element-begin link)
(format "No closing ']' matches '[' in link description: %s"
(buffer-substring-no-properties
(org-element-contents-begin link)
(org-element-contents-end link)))))))))))
(defun org-lint-special-property-in-properties-drawer (ast)
(org-element-map ast 'node-property
(lambda (p)
(let ((key (org-element-property :key p)))
(and (member-ignore-case key org-special-properties)
(list (org-element-begin p)
(format
"Special property \"%s\" found in a properties drawer"
key)))))))
(defun org-lint-obsolete-properties-drawer (ast)
(org-element-map ast 'drawer
(lambda (d)
(when (equal (org-element-property :drawer-name d) "PROPERTIES")
(let ((headline? (org-element-lineage d 'headline))
(before
(mapcar #'org-element-type
(assq d (reverse (org-element-contents
(org-element-parent d)))))))
(list (org-element-post-affiliated d)
(if (or (and headline? (member before '(nil (planning))))
(and (null headline?) (member before '(nil (comment)))))
"Incorrect contents for PROPERTIES drawer"
"Incorrect location for PROPERTIES drawer")))))))
(defun org-lint-invalid-effort-property (ast)
(org-element-map ast 'node-property
(lambda (p)
(when (equal "EFFORT" (org-element-property :key p))
(let ((value (org-element-property :value p)))
(and (org-string-nw-p value)
(not (org-duration-p value))
(list (org-element-begin p)
(format "Invalid effort duration format: %S" value))))))))
(defun org-lint-invalid-id-property (ast)
(org-element-map ast 'node-property
(lambda (p)
(when (equal "ID" (org-element-property :key p))
(let ((value (org-element-property :value p)))
(and (org-string-nw-p value)
(string-match-p "::" value)
(list (org-element-begin p)
(format "IDs should not include \"::\": %S" value))))))))
(defun org-lint-link-to-local-file (ast)
(org-element-map ast 'link
(lambda (l)
(let ((type (org-element-property :type l)))
(pcase type
((or "attachment" "file")
(let* ((path (org-element-property :path l))
(path (if (and (equal type "attachment")
(string-match "::\\(.*\\)\\'" path))
(substring path 0 (match-beginning 0))
path))
(file (if (string= type "file")
path
(org-with-point-at (org-element-begin l)
(org-attach-expand path)))))
(setq file (substitute-env-in-file-name file))
(and (not (file-remote-p file))
(not (file-exists-p file))
(list (org-element-begin l)
(format (if (org-element-lineage l 'link)
"Link to non-existent image file %S \
in description"
"Link to non-existent local file %S")
file)))))
(_ nil))))))
(defun org-lint-non-existent-setupfile-parameter (ast)
(org-element-map ast 'keyword
(lambda (k)
(when (equal (org-element-property :key k) "SETUPFILE")
(let ((file (org-unbracket-string
"\"" "\""
(org-element-property :value k))))
(and (not (org-url-p file))
(not (file-remote-p file))
(not (file-exists-p file))
(list (org-element-begin k)
(format "Non-existent setup file %S" file))))))))
(defun org-lint-wrong-include-link-parameter (ast)
(org-element-map ast 'keyword
(lambda (k)
(when (equal (org-element-property :key k) "INCLUDE")
(let* ((value (org-element-property :value k))
(path
(and (string-match "^\\(\".+?\"\\|\\S-+\\)[ \t]*" value)
(save-match-data
(org-strip-quotes (match-string 1 value))))))
(if (not path)
(list (org-element-post-affiliated k)
"Missing location argument in INCLUDE keyword")
(let* ((file (org-string-nw-p
(if (string-match "::\\(.*\\)\\'" path)
(substring path 0 (match-beginning 0))
path)))
(search (and (not (equal file path))
(org-string-nw-p (match-string 1 path)))))
(unless (org-url-p file)
(if (and file
(not (file-remote-p file))
(not (file-exists-p file)))
(list (org-element-post-affiliated k)
"Non-existent file argument in INCLUDE keyword")
(let* ((visiting (if file (find-buffer-visiting file)
(current-buffer)))
(buffer (or visiting (find-file-noselect file)))
(org-link-search-must-match-exact-headline t))
(unwind-protect
(with-current-buffer buffer
(org-with-wide-buffer
(when (and search
(not (ignore-errors
(org-link-search search nil t))))
(list (org-element-post-affiliated k)
(format
"Invalid search part \"%s\" in INCLUDE keyword"
search)))))
(unless visiting (kill-buffer buffer)))))))))))))
(defun org-lint-obsolete-include-markup (ast)
(let ((regexp (format "\\`\\(?:\".+\"\\|\\S-+\\)[ \t]+%s"
(regexp-opt
'("ASCII" "BEAMER" "HTML" "LATEX" "MAN" "MARKDOWN" "MD"
"ODT" "ORG" "TEXINFO")
t))))
(org-element-map ast 'keyword
(lambda (k)
(when (equal (org-element-property :key k) "INCLUDE")
(let ((case-fold-search t)
(value (org-element-property :value k)))
(when (string-match regexp value)
(let ((markup (match-string-no-properties 1 value)))
(list (org-element-post-affiliated k)
(format "Obsolete markup \"%s\" in INCLUDE keyword. \
Use \"export %s\" instead"
markup
markup))))))))))
(defun org-lint-unknown-options-item (ast)
(let ((allowed (delq nil
(append
(mapcar (lambda (o) (nth 2 o)) org-export-options-alist)
(cl-mapcan
(lambda (b)
(mapcar (lambda (o) (nth 2 o))
(org-export-backend-options b)))
org-export-registered-backends))))
reports)
(org-element-map ast 'keyword
(lambda (k)
(when (string= (org-element-property :key k) "OPTIONS")
(let ((value (org-element-property :value k))
(start 0))
(while (string-match "\\(.+?\\):\\((.*?)\\|\\S-+\\)?[ \t]*"
value
start)
(setf start (match-end 0))
(let ((item (match-string 1 value)))
(unless (member item allowed)
(push (list (org-element-post-affiliated k)
(format "Unknown OPTIONS item \"%s\"" item))
reports))
(unless (match-string 2 value)
(push (list (org-element-post-affiliated k)
(format "Missing value for option item %S" item))
reports))))))))
reports))
(defun org-lint-export-option-keywords (ast)
"Check for options keyword properties without EXPORT in AST."
(require 'ox)
(let (options reports common-options options-alist)
(dolist (opt org-export-options-alist)
(when (stringp (nth 1 opt))
(cl-pushnew (nth 1 opt) common-options :test #'equal)))
(dolist (backend org-export-registered-backends)
(dolist (opt (org-export-backend-options backend))
(when (stringp (nth 1 opt))
(cl-pushnew (or (org-export-backend-name backend) 'anonymous)
(alist-get (nth 1 opt) options-alist nil nil #'equal))
(cl-pushnew (nth 1 opt) options :test #'equal))))
(setq options-alist (nreverse options-alist))
(org-element-map ast 'node-property
(lambda (node)
(let ((prop (org-element-property :key node)))
(when (and (or (member prop options) (member prop common-options))
(not (member prop org-default-properties)))
(push (list (org-element-post-affiliated node)
(format "Potentially misspelled %sexport option \"%s\"%s. Consider \"EXPORT_%s\"."
(when (member prop common-options)
"global ")
prop
(if-let* ((backends
(and (not (member prop common-options))
(cdr (assoc-string prop options-alist)))))
(format
" in %S export %s"
(if (= 1 (length backends)) (car backends) backends)
(if (> (length backends) 1) "backends" "backend"))
"")
prop))
reports)))))
reports))
(defun org-lint-invalid-macro-argument-and-template (ast)
(let* ((reports nil)
(extract-placeholders
(lambda (template)
(let ((start 0)
args)
(while (string-match "\\$\\([1-9][0-9]*\\)" template start)
(setf start (match-end 0))
(push (string-to-number (match-string 1 template)) args))
(sort (org-uniquify args) #'<))))
(check-arity
(lambda (arity macro)
(let* ((name (org-element-property :key macro))
(pos (org-element-begin macro))
(args (org-element-property :args macro))
(l (length args)))
(cond
((< l (1- (car arity)))
(push (list pos (format "Missing arguments in macro %S" name))
reports))
((< l (car arity))
(push (list pos (format "Missing argument in macro %S" name))
reports))
((> l (1+ (cdr arity)))
(push (let ((spurious-args (nthcdr (cdr arity) args)))
(list pos
(format "Spurious arguments in macro %S: %s"
name
(mapconcat #'org-trim spurious-args ", "))))
reports))
((> l (cdr arity))
(push (list pos
(format "Spurious argument in macro %S: %s"
name
(org-last args)))
reports))
(t nil))))))
;; Check arguments for macro templates.
(org-element-map ast 'keyword
(lambda (k)
(when (string= (org-element-property :key k) "MACRO")
(let* ((value (org-element-property :value k))
(name (and (string-match "^\\S-+" value)
(match-string 0 value)))
(template (and name
(org-trim (substring value (match-end 0))))))
(cond
((not name)
(push (list (org-element-post-affiliated k)
"Missing name in MACRO keyword")
reports))
((not (org-string-nw-p template))
(push (list (org-element-post-affiliated k)
"Missing template in macro \"%s\"" name)
reports))
(t
(unless (let ((args (funcall extract-placeholders template)))
(equal (number-sequence 1 (or (org-last args) 0)) args))
(push (list (org-element-post-affiliated k)
(format "Unused placeholders in macro \"%s\""
name))
reports))))))))
;; Check arguments for macros.
(org-macro-initialize-templates)
(let ((templates (append
(mapcar (lambda (m) (cons m "$1"))
'("author" "date" "email" "title" "results"))
org-macro-templates)))
(org-element-map ast 'macro
(lambda (macro)
(let* ((name (org-element-property :key macro))
(template (cdr (assoc-string name templates t))))
(pcase template
(`nil
(push (list (org-element-begin macro)
(format "Undefined macro %S" name))
reports))
((guard (string= name "keyword"))
(funcall check-arity '(1 . 1) macro))
((guard (string= name "modification-time"))
(funcall check-arity '(1 . 2) macro))
((guard (string= name "n"))
(funcall check-arity '(0 . 2) macro))
((guard (string= name "property"))
(funcall check-arity '(1 . 2) macro))
((guard (string= name "time"))
(funcall check-arity '(1 . 1) macro))
((pred functionp)) ;ignore (eval ...) templates
(_
(let* ((arg-numbers (funcall extract-placeholders template))
(arity (if (null arg-numbers)
'(0 . 0)
(let ((m (apply #'max arg-numbers)))
(cons m m)))))
(funcall check-arity arity macro))))))))
reports))
(defun org-lint-undefined-footnote-reference (ast)
(let ((definitions
(org-element-map ast '(footnote-definition footnote-reference)
(lambda (f)
(and (or (org-element-type-p f 'footnote-definition)
(eq 'inline (org-element-property :type f)))
(org-element-property :label f))))))
(org-element-map ast 'footnote-reference
(lambda (f)
(let ((label (org-element-property :label f)))
(and (eq 'standard (org-element-property :type f))
(not (member label definitions))
(list (org-element-begin f)
(format "Missing definition for footnote [%s]"
label))))))))
(defun org-lint-unreferenced-footnote-definition (ast)
(let ((references (org-element-map ast 'footnote-reference
(lambda (f) (org-element-property :label f)))))
(org-element-map ast 'footnote-definition
(lambda (f)
(let ((label (org-element-property :label f)))
(and label
(not (member label references))
(list (org-element-post-affiliated f)
(format "No reference for footnote definition [%s]"
label))))))))
(defun org-lint-mismatched-planning-repeaters (ast)
(org-element-map ast 'planning
(lambda (e)
(let* ((scheduled (org-element-property :scheduled e))
(deadline (org-element-property :deadline e))
(scheduled-repeater-type (org-element-property
:repeater-type scheduled))
(deadline-repeater-type (org-element-property
:repeater-type deadline))
(scheduled-repeater-value (org-element-property
:repeater-value scheduled))
(deadline-repeater-value (org-element-property
:repeater-value deadline)))
(when (and scheduled deadline
(memq scheduled-repeater-type '(cumulate catch-up))
(memq deadline-repeater-type '(cumulate catch-up))
(> scheduled-repeater-value 0)
(> deadline-repeater-value 0)
(not
(and
(eq scheduled-repeater-type deadline-repeater-type)
(eq (org-element-property :repeater-unit scheduled)
(org-element-property :repeater-unit deadline))
(eql scheduled-repeater-value deadline-repeater-value))))
(list
(org-element-property :begin e)
"Different repeaters in SCHEDULED and DEADLINE timestamps."))))))
(defun org-lint-misplaced-planning-info (_)
(let ((case-fold-search t)
reports)
(while (re-search-forward org-planning-line-re nil t)
(unless (org-element-type-p
(org-element-at-point)
'(comment-block example-block export-block planning
src-block verse-block))
(push (list (line-beginning-position) "Misplaced planning info line")
reports)))
reports))
(defun org-lint-incomplete-drawer (_)
(let (reports)
(while (re-search-forward org-drawer-regexp nil t)
(let ((name (org-trim (match-string-no-properties 0)))
(element (org-element-at-point)))
(pcase (org-element-type element)
(`drawer
;; Find drawer opening lines within non-empty drawers.
(let ((end (org-element-contents-end element)))
(when end
(while (re-search-forward org-drawer-regexp end t)
(let ((n (org-trim (match-string-no-properties 0))))
(push (list (line-beginning-position)
(format "Possible misleading drawer entry %S" n))
reports))))
(goto-char (org-element-end element))))
(`property-drawer
(goto-char (org-element-end element)))
((or `comment-block `example-block `export-block `src-block
`verse-block)
nil)
(_
;; Find drawer opening lines outside of any drawer.
(push (list (line-beginning-position)
(format "Possible incomplete drawer %S" name))
reports)))))
reports))
(defun org-lint-indented-diary-sexp (_)
(let (reports)
(while (re-search-forward "^[ \t]+%%(" nil t)
(unless (org-element-type-p
(org-element-at-point)
'(comment-block diary-sexp example-block export-block
src-block verse-block))
(push (list (line-beginning-position) "Possible indented diary-sexp")
reports)))
reports))
(defun org-lint-invalid-block (_)
(let ((case-fold-search t)
(regexp "^[ \t]*#\\+\\(BEGIN\\|END\\)\\(?::\\|_[^[:space:]]*\\)?[ \t]*")
reports)
(while (re-search-forward regexp nil t)
(let ((name (org-trim (buffer-substring-no-properties
(line-beginning-position) (line-end-position)))))
(cond
((and (string-prefix-p "END" (match-string 1) t)
(not (eolp)))
(push (list (line-beginning-position)
(format "Invalid block closing line \"%s\"" name))
reports))
((not (org-element-type-p
(org-element-at-point)
'(center-block comment-block dynamic-block example-block
export-block quote-block special-block
src-block verse-block)))
(push (list (line-beginning-position)
(format "Possible incomplete block \"%s\""
name))
reports)))))
reports))
(defun org-lint-invalid-keyword-syntax (_)
(let ((regexp "^[ \t]*#\\+\\([^[:space:]:]*\\)\\(?: \\|$\\)")
(exception-re
(format "[ \t]*#\\+%s\\(\\[.*\\]\\)?:\\(?: \\|$\\)"
(regexp-opt org-element-dual-keywords)))
reports)
(while (re-search-forward regexp nil t)
(let ((name (match-string-no-properties 1)))
(unless (or (string-prefix-p "BEGIN" name t)
(string-prefix-p "END" name t)
(save-excursion
(forward-line 0)
(let ((case-fold-search t)) (looking-at exception-re))))
(push (list (match-beginning 0)
(format "Possible missing colon in keyword \"%s\"" name))
reports))))
reports))
(defun org-lint-invalid-image-alignment (ast)
(apply
#'nconc
(org-element-map ast 'paragraph
(lambda (p)
(let ((center-re ":center[[:space:]]+\\(\\S-+\\)")
(align-re ":align[[:space:]]+\\(\\S-+\\)")
(keyword-string
(car-safe (org-element-property :attr_org p)))
reports)
(when keyword-string
(when (and (string-match align-re keyword-string)
(not (member (match-string 1 keyword-string)
'("left" "center" "right"))))
(push
(list (org-element-begin p)
(format
"\"%s\" not a supported value for #+ATTR_ORG keyword attribute \":align\"."
(match-string 1 keyword-string)))
reports))
(when (and (string-match center-re keyword-string)
(not (equal (match-string 1 keyword-string) "t")))
(push
(list (org-element-begin p)
(format
"\"%s\" not a supported value for #+ATTR_ORG keyword attribute \":center\"."
(match-string 1 keyword-string)))
reports)))
reports)))))
(defun org-lint-extraneous-element-in-footnote-section (ast)
(org-element-map ast 'headline
(lambda (h)
(and (org-element-property :footnote-section-p h)
(org-element-map (org-element-contents h)
(cl-remove-if
(lambda (e)
(memq e '(comment comment-block footnote-definition
property-drawer section)))
org-element-all-elements)
(lambda (e)
(not (and (org-element-type-p e 'headline)
(org-element-property :commentedp e))))
nil t '(footnote-definition property-drawer))
(list (org-element-begin h)
"Extraneous elements in footnote section are not exported")))))
(defun org-lint-quote-section (ast)
(org-element-map ast '(headline inlinetask)
(lambda (h)
(let ((title (org-element-property :raw-value h)))
(and (or (string-prefix-p "QUOTE " title)
(string-prefix-p (concat org-comment-string " QUOTE ") title))
(list (org-element-begin h)
"Deprecated QUOTE section"))))))
(defun org-lint-file-application (ast)
(org-element-map ast 'link
(lambda (l)
(let ((app (org-element-property :application l)))
(and app
(list (org-element-begin l)
(format "Deprecated \"file+%s\" link type" app)))))))
(defun org-lint-percent-encoding-link-escape (ast)
(org-element-map ast 'link
(lambda (l)
(when (eq 'bracket (org-element-property :format l))
(let* ((uri (org-element-property :path l))
(start 0)
(obsolete-flag
(catch :obsolete
(while (string-match "%\\(..\\)?" uri start)
(setq start (match-end 0))
(unless (member (match-string 1 uri) '("25" "5B" "5D" "20"))
(throw :obsolete nil)))
(string-match-p "%" uri))))
(when obsolete-flag
(list (org-element-begin l)
"Link escaped with obsolete percent-encoding syntax")))))))
(defun org-lint-wrong-header-argument (ast)
(let* ((reports)
(verify
(lambda (datum language headers)
(let ((allowed
;; If LANGUAGE is specified, restrict allowed
;; headers to both LANGUAGE-specific and default
;; ones. Otherwise, accept headers from any loaded
;; language.
(append
org-babel-header-arg-names
(cl-mapcan
(lambda (l)
(let ((v (intern (format "org-babel-header-args:%s" l))))
(and (boundp v) (mapcar #'car (symbol-value v)))))
(if language (list language)
(mapcar #'car org-babel-load-languages))))))
(dolist (header headers)
(let ((h (symbol-name (car header)))
(p (or (org-element-post-affiliated datum)
(org-element-begin datum))))
(cond
((not (string-prefix-p ":" h))
(push
(list p
(format "Missing colon in header argument \"%s\"" h))
reports))
((assoc-string (substring h 1) allowed))
(t (push (list p (format "Unknown header argument \"%s\"" h))
reports)))))))))
(org-element-map ast '(babel-call inline-babel-call inline-src-block keyword
node-property src-block)
(lambda (datum)
(pcase (org-element-type datum)
((or `babel-call `inline-babel-call)
(funcall verify
datum
nil
(cl-mapcan #'org-babel-parse-header-arguments
(list
(org-element-property :inside-header datum)
(org-element-property :end-header datum)))))
(`inline-src-block
(funcall verify
datum
(org-element-property :language datum)
(org-babel-parse-header-arguments
(org-element-property :parameters datum))))
(`keyword
(when (string= (org-element-property :key datum) "PROPERTY")
(let ((value (org-element-property :value datum)))
(when (or (string-match "\\`header-args\\(?::\\(\\S-+\\)\\)?\\+ *"
value)
(string-match "\\`header-args\\(?::\\(\\S-+\\)\\)? *"
value))
(funcall verify
datum
(match-string 1 value)
(org-babel-parse-header-arguments
(substring value (match-end 0))))))))
(`node-property
(let ((key (org-element-property :key datum)))
(when (let ((case-fold-search t))
(or (string-match "\\`HEADER-ARGS\\(?::\\(\\S-+\\)\\)?\\+"
key)
(string-match "\\`HEADER-ARGS\\(?::\\(\\S-+\\)\\)?"
key)))
(funcall verify
datum
(match-string 1 key)
(org-babel-parse-header-arguments
(org-element-property :value datum))))))
(`src-block
(funcall verify
datum
(org-element-property :language datum)
(cl-mapcan #'org-babel-parse-header-arguments
(cons (org-element-property :parameters datum)
(org-element-property :header datum))))))))
reports))
(defun org-lint-empty-header-argument (ast)
(let* (reports)
(org-element-map ast '(babel-call inline-babel-call inline-src-block src-block)
(lambda (datum)
(let ((headers
(pcase (org-element-type datum)
((or `babel-call `inline-babel-call)
(cl-mapcan
(lambda (header) (org-babel-parse-header-arguments header 'no-eval))
(list
(org-element-property :inside-header datum)
(org-element-property :end-header datum))))
(`inline-src-block
(org-babel-parse-header-arguments
(org-element-property :parameters datum)
'no-eval))
(`src-block
(cl-mapcan
(lambda (header) (org-babel-parse-header-arguments header 'no-eval))
(cons (org-element-property :parameters datum)
(org-element-property :header datum)))))))
(dolist (header headers)
(when (not (cdr header))
(push
(list
(or (org-element-post-affiliated datum)
(org-element-begin datum))
(format "Empty value in header argument \"%s\"" (symbol-name (car header))))
reports))))))
reports))
(defun org-lint-wrong-header-value (ast)
(let (reports)
(org-element-map ast
'(babel-call inline-babel-call inline-src-block src-block)
(lambda (datum)
(let* ((type (org-element-type datum))
(language (org-element-property :language datum))
(allowed-header-values
(append (and language
(let ((v (intern (concat "org-babel-header-args:"
language))))
(and (boundp v) (symbol-value v))))
org-babel-common-header-args-w-values))
(datum-header-values
(org-babel-parse-header-arguments
(org-trim
(pcase type
(`src-block
(mapconcat
#'identity
(cons (org-element-property :parameters datum)
(org-element-property :header datum))
" "))
(`inline-src-block
(or (org-element-property :parameters datum) ""))
(_
(concat
(org-element-property :inside-header datum)
" "
(org-element-property :end-header datum))))))))
(dolist (header datum-header-values)
(let ((allowed-values
(cdr (assoc-string (substring (symbol-name (car header)) 1)
allowed-header-values))))
(unless (memq allowed-values '(:any nil))
(let ((values (cdr header))
groups-alist)
(dolist (v (if (stringp values) (split-string values)
(list values)))
(let ((valid-value nil))
(catch 'exit
(dolist (group allowed-values)
(cond
((not (funcall
(if (stringp v) #'assoc-string #'assoc)
v group))
(when (memq :any group)
(setf valid-value t)
(push (cons group v) groups-alist)))
((assq group groups-alist)
(push
(list
(or (org-element-post-affiliated datum)
(org-element-begin datum))
(format
"Forbidden combination in header \"%s\": %s, %s"
(car header)
(cdr (assq group groups-alist))
v))
reports)
(throw 'exit nil))
(t (push (cons group v) groups-alist)
(setf valid-value t))))
(unless valid-value
(push
(list
(or (org-element-post-affiliated datum)
(org-element-begin datum))
(format "Unknown value \"%s\" for header \"%s\""
v
(car header)))
reports))))))))))))
reports))
(defun org-lint-named-result (ast)
(org-element-map ast org-element-all-elements
(lambda (el)
(when-let* ((result (org-element-property :results el))
(result-name (org-element-property :name el))
(origin-block
(if (org-string-nw-p (car result))
(condition-case _
(org-export-resolve-link (car result) `(:parse-tree ,ast))
(org-link-broken nil))
(org-export-get-previous-element el nil))))
(when (org-element-type-p origin-block 'src-block)
(list (org-element-begin el)
(format "Links to \"%s\" will not be valid during export unless the parent source block has :exports results or both" result-name)))))))
(defun org-lint-spurious-colons (ast)
(org-element-map ast '(headline inlinetask)
(lambda (h)
(when (member "" (org-element-property :tags h))
(list (org-element-begin h)
"Tags contain a spurious colon")))))
(defun org-lint-non-existent-bibliography (ast)
(org-element-map ast 'keyword
(lambda (k)
(when (equal "BIBLIOGRAPHY" (org-element-property :key k))
(let ((file (org-strip-quotes (org-element-property :value k))))
(and (not (file-remote-p file))
(not (file-exists-p file))
(list (org-element-begin k)
(format "Non-existent bibliography %S" file))))))))
(defun org-lint-missing-print-bibliography (ast)
(and (org-element-map ast 'citation #'identity nil t)
(not (org-element-map ast 'keyword
(lambda (k)
(equal "PRINT_BIBLIOGRAPHY" (org-element-property :key k)))
nil t))
(list
(list (point-max) "Possibly missing \"PRINT_BIBLIOGRAPHY\" keyword"))))
(defun org-lint-invalid-cite-export-declaration (ast)
(org-element-map ast 'keyword
(lambda (k)
(when (equal "CITE_EXPORT" (org-element-property :key k))
(let ((value (org-element-property :value k))
(source (org-element-begin k)))
(if (equal value "")
(list source "Missing export processor name")
(condition-case _
(pcase (org-cite-read-processor-declaration value)
(`(,(and (pred symbolp) name)
,(pred string-or-null-p)
,(pred string-or-null-p))
(unless (or (org-cite-get-processor name)
(progn
(org-cite-try-load-processor name)
(org-cite-get-processor name)))
(list source (format "Unknown cite export processor %S" name))))
(_
(list source "Invalid cite export processor declaration")))
(error
(list source "Invalid cite export processor declaration")))))))))
(defun org-lint-incomplete-citation (ast)
(org-element-map ast 'plain-text
(lambda (text)
(and (string-match-p org-element-citation-prefix-re text)
;; XXX: The code below signals the error at the beginning
;; of the paragraph containing the faulty object. It is
;; not very accurate but may be enough for now.
(list (org-element-contents-begin
(org-element-parent text))
"Possibly incomplete citation markup")))))
(defun org-lint-item-number (ast)
(org-element-map ast 'item
(lambda (item)
(unless (org-element-property :counter item)
(when-let* ((bullet (org-element-property :bullet item))
(bullet-number
(cond
((string-match "[A-Za-z]" bullet)
(- (string-to-char (upcase (match-string 0 bullet)))
64))
((string-match "[0-9]+" bullet)
(string-to-number (match-string 0 bullet)))))
(true-number
(org-list-get-item-number
(org-element-begin item)
(org-element-property :structure item)
(org-list-prevs-alist (org-element-property :structure item))
(org-list-parents-alist (org-element-property :structure item)))))
(unless (equal bullet-number (car (last true-number)))
(list
(org-element-begin item)
(format "Bullet counter \"%s\" is not the same with item position %d. Consider adding manual [@%d] counter."
bullet (car (last true-number)) bullet-number))))))))
(defun org-lint-LaTeX-$ (ast)
"Report semi-obsolete $...$ LaTeX fragments.
AST is the buffer parse tree."
(org-element-map ast 'latex-fragment
(lambda (fragment)
(and (string-match-p "^[$][^$]" (org-element-property :value fragment))
(list (org-element-begin fragment)
"Potentially confusing LaTeX fragment format. Prefer using more reliable \\(...\\)")))))
(defun org-lint-LaTeX-$-ambiguous (_)
"Report LaTeX fragment-like text.
AST is the buffer parse tree."
(org-with-wide-buffer
(let ((ambiguous-latex-re (rx "$." digit))
report context)
(while (re-search-forward ambiguous-latex-re nil t)
(setq context (org-element-context))
(when (or (eq 'latex-fragment (org-element-type context))
(memq 'latex-fragment (org-element-restriction context)))
(push
(list
(point)
"$ symbol potentially matching LaTeX fragment boundary. Consider using \\dollar entity.")
report)))
report)))
(defun org-lint-timestamp-syntax (ast)
"Report malformed timestamps.
AST is the buffer parse tree."
(org-element-map ast 'timestamp
(lambda (timestamp)
(let ((expected (org-element-interpret-data timestamp))
(actual (buffer-substring-no-properties
(org-element-property :begin timestamp)
(org-element-property :end timestamp))))
(unless (equal expected actual)
(list (org-element-property :begin timestamp)
(format "Potentially malformed timestamp %s. Parsed as: %s" actual expected)))))))
(defun org-lint-inactive-planning (ast)
"Report inactive timestamp in SCHEDULED/DEADLINE.
AST is the buffer parse tree."
(org-element-map ast 'planning
(lambda (planning)
(let ((scheduled (org-element-property :scheduled planning))
(deadline (org-element-property :deadline planning)))
(cond
((memq (org-element-property :type scheduled) '(inactive inactive-range))
(list (org-element-begin planning) "Inactive timestamp in SCHEDULED will not appear in agenda."))
((memq (org-element-property :type deadline) '(inactive inactive-range))
(list (org-element-begin planning) "Inactive timestamp in DEADLINE will not appear in agenda."))
(t nil))))))
(defvar org-beamer-frame-environment) ; defined in ox-beamer.el
(defun org-lint-beamer-frame (ast)
"Check for occurrences of begin or end frame."
(require 'ox-beamer)
(org-with-point-at ast
(goto-char (point-min))
(let (result)
(while (re-search-forward
(concat "\\\\\\(begin\\|end\\){" org-beamer-frame-environment "}") nil t)
(push (list (match-beginning 0) "Beamer frame name may cause error when exporting. Consider customizing `org-beamer-frame-environment'.") result))
result)))
;;; Checkers declaration
(org-lint-add-checker 'misplaced-heading
"Report accidentally misplaced heading lines."
#'org-lint-misplaced-heading :trust 'low)
(org-lint-add-checker 'duplicate-custom-id
"Report duplicates CUSTOM_ID properties"
#'org-lint-duplicate-custom-id
:categories '(link))
(org-lint-add-checker 'duplicate-name
"Report duplicate NAME values"
#'org-lint-duplicate-name
:categories '(babel 'link))
(org-lint-add-checker 'duplicate-target
"Report duplicate targets"
#'org-lint-duplicate-target
:categories '(link))
(org-lint-add-checker 'duplicate-footnote-definition
"Report duplicate footnote definitions"
#'org-lint-duplicate-footnote-definition
:categories '(footnote))
(org-lint-add-checker 'orphaned-affiliated-keywords
"Report orphaned affiliated keywords"
#'org-lint-orphaned-affiliated-keywords
:trust 'low)
(org-lint-add-checker 'combining-keywords-with-affiliated
"Report independent keywords preceding affiliated keywords."
#'org-lint-regular-keyword-before-affiliated
:trust 'low)
(org-lint-add-checker 'obsolete-affiliated-keywords
"Report obsolete affiliated keywords"
#'org-lint-obsolete-affiliated-keywords
:categories '(obsolete))
(org-lint-add-checker 'deprecated-export-blocks
"Report deprecated export block syntax"
#'org-lint-deprecated-export-blocks
:trust 'low :categories '(obsolete export))
(org-lint-add-checker 'deprecated-header-syntax
"Report deprecated Babel header syntax"
#'org-lint-deprecated-header-syntax
:trust 'low :categories '(obsolete babel))
(org-lint-add-checker 'missing-language-in-src-block
"Report missing language in source blocks"
#'org-lint-missing-language-in-src-block
:categories '(babel))
(org-lint-add-checker 'suspicious-language-in-src-block
"Report suspicious language in source blocks"
#'org-lint-suspicious-language-in-src-block
:trust 'low :categories '(babel))
(org-lint-add-checker 'missing-backend-in-export-block
"Report missing backend in export blocks"
#'org-lint-missing-backend-in-export-block
:categories '(export))
(org-lint-add-checker 'invalid-babel-call-block
"Report invalid Babel call blocks"
#'org-lint-invalid-babel-call-block
:categories '(babel))
(org-lint-add-checker 'wrong-header-argument
"Report wrong babel headers"
#'org-lint-wrong-header-argument
:categories '(babel))
(org-lint-add-checker 'wrong-header-value
"Report invalid value in babel headers"
#'org-lint-wrong-header-value
:categories '(babel) :trust 'low)
(org-lint-add-checker 'named-result
"Report results evaluation with #+name keyword."
#'org-lint-named-result
:categories '(babel) :trust 'high)
(org-lint-add-checker 'empty-header-argument
"Report empty values in babel headers"
#'org-lint-empty-header-argument
:categories '(babel) :trust 'low)
(org-lint-add-checker 'deprecated-category-setup
"Report misuse of CATEGORY keyword"
#'org-lint-deprecated-category-setup
:categories '(obsolete))
(org-lint-add-checker 'invalid-coderef-link
"Report \"coderef\" links with unknown destination"
#'org-lint-invalid-coderef-link
:categories '(link))
(org-lint-add-checker 'invalid-custom-id-link
"Report \"custom-id\" links with unknown destination"
#'org-lint-invalid-custom-id-link
:categories '(link))
(org-lint-add-checker 'invalid-fuzzy-link
"Report \"fuzzy\" links with unknown destination"
#'org-lint-invalid-fuzzy-link
:categories '(link))
(org-lint-add-checker 'invalid-id-link
"Report \"id\" links with unknown destination"
#'org-lint-invalid-id-link
:categories '(link))
(org-lint-add-checker 'trailing-bracket-after-link
"Report potentially confused trailing ']' after link."
#'org-lint-confusing-brackets
:categories '(link) :trust 'low)
(org-lint-add-checker 'unclosed-brackets-in-link-description
"Report potentially confused trailing ']' after link."
#'org-lint-brackets-inside-description
:categories '(link) :trust 'low)
(org-lint-add-checker 'link-to-local-file
"Report links to non-existent local files"
#'org-lint-link-to-local-file
:categories '(link) :trust 'low)
(org-lint-add-checker 'non-existent-setupfile-parameter
"Report SETUPFILE keywords with non-existent file parameter"
#'org-lint-non-existent-setupfile-parameter
:trust 'low)
(org-lint-add-checker 'wrong-include-link-parameter
"Report INCLUDE keywords with misleading link parameter"
#'org-lint-wrong-include-link-parameter
:categories '(export) :trust 'low)
(org-lint-add-checker 'obsolete-include-markup
"Report obsolete markup in INCLUDE keyword"
#'org-lint-obsolete-include-markup
:categories '(obsolete export) :trust 'low)
(org-lint-add-checker 'unknown-options-item
"Report unknown items in OPTIONS keyword"
#'org-lint-unknown-options-item
:categories '(export) :trust 'low)
(org-lint-add-checker 'misspelled-export-option
"Report potentially misspelled export options in properties."
#'org-lint-export-option-keywords
:categories '(export) :trust 'low)
(org-lint-add-checker 'invalid-macro-argument-and-template
"Report spurious macro arguments or invalid macro templates"
#'org-lint-invalid-macro-argument-and-template
:categories '(export) :trust 'low)
(org-lint-add-checker 'special-property-in-properties-drawer
"Report special properties in properties drawers"
#'org-lint-special-property-in-properties-drawer
:categories '(properties))
(org-lint-add-checker 'obsolete-properties-drawer
"Report obsolete syntax for properties drawers"
#'org-lint-obsolete-properties-drawer
:categories '(obsolete properties))
(org-lint-add-checker 'invalid-effort-property
"Report invalid duration in EFFORT property"
#'org-lint-invalid-effort-property
:categories '(properties))
(org-lint-add-checker 'invalid-id-property
"Report search string delimiter \"::\" in ID property"
#'org-lint-invalid-id-property
:categories '(properties))
(org-lint-add-checker 'undefined-footnote-reference
"Report missing definition for footnote references"
#'org-lint-undefined-footnote-reference
:categories '(footnote))
(org-lint-add-checker 'unreferenced-footnote-definition
"Report missing reference for footnote definitions"
#'org-lint-unreferenced-footnote-definition
:categories '(footnote))
(org-lint-add-checker 'extraneous-element-in-footnote-section
"Report non-footnote definitions in footnote section"
#'org-lint-extraneous-element-in-footnote-section
:categories '(footnote))
(org-lint-add-checker 'invalid-keyword-syntax
"Report probable invalid keywords"
#'org-lint-invalid-keyword-syntax
:trust 'low)
(org-lint-add-checker 'invalid-image-alignment
"Report unsupported align attribute for keyword"
#'org-lint-invalid-image-alignment
:trust 'high)
(org-lint-add-checker 'invalid-block
"Report invalid blocks"
#'org-lint-invalid-block
:trust 'low)
(org-lint-add-checker 'mismatched-planning-repeaters
"Report mismatched repeaters in planning info line"
#'org-lint-mismatched-planning-repeaters
:trust 'low)
(org-lint-add-checker 'misplaced-planning-info
"Report misplaced planning info line"
#'org-lint-misplaced-planning-info
:trust 'low)
(org-lint-add-checker 'incomplete-drawer
"Report probable incomplete drawers"
#'org-lint-incomplete-drawer
:trust 'low)
(org-lint-add-checker 'indented-diary-sexp
"Report probable indented diary-sexps"
#'org-lint-indented-diary-sexp
:trust 'low)
(org-lint-add-checker 'quote-section
"Report obsolete QUOTE section"
#'org-lint-quote-section
:categories '(obsolete) :trust 'low)
(org-lint-add-checker 'file-application
"Report obsolete \"file+application\" link"
#'org-lint-file-application
:categories '(link obsolete))
(org-lint-add-checker 'percent-encoding-link-escape
"Report obsolete escape syntax in links"
#'org-lint-percent-encoding-link-escape
:categories '(link obsolete) :trust 'low)
(org-lint-add-checker 'spurious-colons
"Report spurious colons in tags"
#'org-lint-spurious-colons
:categories '(tags))
(org-lint-add-checker 'non-existent-bibliography
"Report invalid bibliography file"
#'org-lint-non-existent-bibliography
:categories '(cite))
(org-lint-add-checker 'missing-print-bibliography
"Report missing \"print_bibliography\" keyword"
#'org-lint-missing-print-bibliography
:categories '(cite))
(org-lint-add-checker 'invalid-cite-export-declaration
"Report invalid value for \"cite_export\" keyword"
#'org-lint-invalid-cite-export-declaration
:categories '(cite))
(org-lint-add-checker 'incomplete-citation
"Report incomplete citation object"
#'org-lint-incomplete-citation
:categories '(cite) :trust 'low)
(org-lint-add-checker 'item-number
"Report inconsistent item numbers in lists"
#'org-lint-item-number
:categories '(plain-list))
(org-lint-add-checker 'LaTeX-$
"Report potentially confusing $...$ LaTeX markup."
#'org-lint-LaTeX-$
:categories '(markup))
(org-lint-add-checker 'LaTeX-$
"Report $ that might be treated as LaTeX fragment boundary."
#'org-lint-LaTeX-$-ambiguous
:categories '(markup) :trust 'low)
(org-lint-add-checker 'beamer-frame
"Report that frame text contains beamer frame environment."
#'org-lint-beamer-frame
:categories '(export) :trust 'low)
(org-lint-add-checker 'timestamp-syntax
"Report malformed timestamps."
#'org-lint-timestamp-syntax
:categories '(timestamp) :trust 'low)
(org-lint-add-checker 'planning-inactive
"Report inactive timestamps in SCHEDULED/DEADLINE."
#'org-lint-inactive-planning
:categories '(timestamp) :trust 'high)
(provide 'org-lint)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; org-lint.el ends here
org-mode-9.7.29+dfsg/lisp/org-list.el 0000664 0000000 0000000 00000421714 15004304337 0017313 0 ustar 00root root 0000000 0000000 ;;; org-list.el --- Plain lists for Org -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2004-2025 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
;; Bastien Guerry <bzg@gnu.org>
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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 <https://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;; This file contains the code dealing with plain lists in Org mode.
;; The core concept behind lists is their structure. A structure is
;; a snapshot of the list, in the shape of a data tree (see
;; `org-list-struct').
;; Once the list structure is stored, it is possible to make changes
;; on it that will be mirrored to the real list or to get information
;; about the list, using accessors and methods provided in the
;; library. Most of them require the use of one or two helper
;; functions, namely `org-list-parents-alist' and
;; `org-list-prevs-alist'.
;; Structure is eventually applied to the buffer with
;; `org-list-write-struct'. This function repairs (bullets,
;; indentation, checkboxes) the list in the process. It should be
;; called near the end of any function working on structures.
;; Thus, a function applying to lists should usually follow this
;; template:
;; 1. Verify point is in a list and grab item beginning (with the same
;; function `org-in-item-p'). If the function requires the cursor
;; to be at item's bullet, `org-at-item-p' is more selective. It
;; is also possible to move point to the closest item with
;; `org-list-search-backward', or `org-list-search-forward',
;; applied to the function `org-item-beginning-re'.
;; 2. Get list structure with `org-list-struct'.
;; 3. Compute one, or both, helper functions,
;; (`org-list-parents-alist', `org-list-prevs-alist') depending on
;; needed accessors.
;; 4. Proceed with the modifications, using methods and accessors.
;; 5. Verify and apply structure to buffer, using
;; `org-list-write-struct'.
;; 6. If changes made to the list might have modified check-boxes,
;; call `org-update-checkbox-count-maybe'.
;; Computing a structure can be a costly operation on huge lists (a
;; few thousand lines long). Thus, code should follow the rule:
;; "collect once, use many". As a corollary, it is usually a bad idea
;; to use directly an interactive function inside the code, as those,
;; being independent entities, read the whole list structure another
;; time.
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'cl-lib)
(require 'org-macs)
(require 'org-compat)
(require 'org-fold-core)
(require 'org-footnote)
(defvar org-M-RET-may-split-line)
(defvar org-adapt-indentation)
(defvar org-auto-align-tags)
(defvar org-blank-before-new-entry)
(defvar org-clock-string)
(defvar org-closed-string)
(defvar org-deadline-string)
(defvar org-done-keywords)
(defvar org-drawer-regexp)
(defvar org-element-all-objects)
(defvar org-inhibit-startup)
(defvar org-loop-over-headlines-in-active-region)
(defvar org-odd-levels-only)
(defvar org-outline-regexp-bol)
(defvar org-scheduled-string)
(defvar org-todo-line-regexp)
(defvar org-ts-regexp)
(defvar org-ts-regexp-both)
(declare-function org-at-heading-p "org" (&optional invisible-ok))
(declare-function org-back-to-heading "org" (&optional invisible-ok))
(declare-function org-before-first-heading-p "org" ())
(declare-function org-current-level "org" ())
(declare-function org-element-at-point "org-element" (&optional pom cached-only))
(declare-function org-element-context "org-element" (&optional element))
(declare-function org-element-interpret-data "org-element" (data))
(declare-function org-element-lineage "org-element-ast" (blob &optional types with-self))
(declare-function org-element-macro-interpreter "org-element" (macro ##))
(declare-function org-element-map "org-element" (data types fun &optional info first-match no-recursion with-affiliated))
(declare-function org-element-normalize-string "org-element" (s))
(declare-function org-element-parse-buffer "org-element" (&optional granularity visible-only keep-deferred))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-begin "org-element" (node))
(declare-function org-element-end "org-element" (node))
(declare-function org-element-contents-begin "org-element" (node))
(declare-function org-element-contents-end "org-element" (node))
(declare-function org-element-post-affiliated "org-element" (node))
(declare-function org-element-post-blank "org-element" (node))
(declare-function org-element-parent "org-element-ast" (node))
(declare-function org-element-put-property "org-element-ast" (node property value))
(declare-function org-element-set "org-element-ast" (old new))
(declare-function org-element-type-p "org-element-ast" (node types))
(declare-function org-element-update-syntax "org-element" ())
(declare-function org-end-of-meta-data "org" (&optional full))
(declare-function org-entry-get "org" (pom property &optional inherit literal-nil))
(declare-function org-export-create-backend "ox" (&rest rest) t)
(declare-function org-export-data-with-backend "ox" (data backend info))
(declare-function org-export-get-backend "ox" (name))
(declare-function org-export-get-environment "ox" (&optional backend subtreep ext-plist))
(declare-function org-export-get-next-element "ox" (blob info &optional n))
(declare-function org-export-with-backend "ox" (backend data &optional contents info))
(declare-function org-fix-tags-on-the-fly "org" ())
(declare-function org-get-todo-state "org" ())
(declare-function org-in-block-p "org" (names))
(declare-function org-inlinetask-goto-beginning "org-inlinetask" ())
(declare-function org-inlinetask-goto-end "org-inlinetask" ())
(declare-function org-inlinetask-in-task-p "org-inlinetask" ())
(declare-function org-inlinetask-outline-regexp "org-inlinetask" ())
(declare-function org-level-increment "org" ())
(declare-function org-mode "org" ())
(declare-function org-narrow-to-subtree "org" (&optional element))
(declare-function org-outline-level "org" ())
(declare-function org-previous-line-empty-p "org" ())
(declare-function org-reduced-level "org" (L))
(declare-function org-set-tags "org" (tags))
(declare-function org-fold-show-subtree "org-fold" ())
(declare-function org-fold-region "org-fold" (from to flag &optional spec))
(declare-function org-sort-remove-invisible "org" (S))
(declare-function org-time-string-to-seconds "org" (s))
(declare-function org-timer-hms-to-secs "org-timer" (hms))
(declare-function org-timer-item "org-timer" (&optional arg))
(declare-function outline-next-heading "outline" ())
(declare-function outline-previous-heading "outline" ())
;;; Configuration variables
(defgroup org-plain-lists nil
"Options concerning plain lists in Org mode."
:tag "Org Plain lists"
:group 'org-structure)
(defcustom org-cycle-include-plain-lists t
"When t, make TAB cycle visibility on plain list items.
Cycling plain lists works only when the cursor is on a plain list
item. When the cursor is on an outline heading, plain lists are
treated as text. This is the most stable way of handling this,
which is why it is the default.
When this is the symbol `integrate', then integrate plain list
items when cycling, as if they were children of outline headings.
This setting can lead to strange effects when switching visibility
to `children', because the first \"child\" in a subtree decides
what children should be listed. If that first \"child\" is a
plain list item with an implied large level number, all true
children and grand children of the outline heading will be
exposed in a children' view."
:group 'org-plain-lists
:group 'org-cycle
:type '(choice
(const :tag "Never" nil)
(const :tag "With cursor in plain list (recommended)" t)
(const :tag "As children of outline headings" integrate)))
(defcustom org-list-demote-modify-bullet nil
"Default bullet type installed when demoting an item.
This is an association list, for each bullet type, this alist will point
to the bullet that should be used when this item is demoted.
For example,
(setq org-list-demote-modify-bullet
\\='((\"+\" . \"-\") (\"-\" . \"+\") (\"*\" . \"+\")))
will make
+ Movies
+ Silence of the Lambs
+ My Cousin Vinny
+ Books
+ The Hunt for Red October
+ The Road to Omaha
into
+ Movies
- Silence of the Lambs
- My Cousin Vinny
+ Books
- The Hunt for Red October
- The Road to Omaha"
:group 'org-plain-lists
:type '(repeat
(cons
(choice :tag "If the current bullet is "
(const "-")
(const "+")
(const "*")
(const "1.")
(const "1)"))
(choice :tag "demotion will change it to"
(const "-")
(const "+")
(const "*")
(const "1.")
(const "1)")))))
(defcustom org-plain-list-ordered-item-terminator t
"The character that makes a line with leading number an ordered list item.
Valid values are ?. and ?\\). To get both terminators, use t.
This variable needs to be set before org.el is loaded. If you
need to make a change while Emacs is running, use the customize
interface or run the following code after updating it:
`\\[org-element-update-syntax]'"
:group 'org-plain-lists
:type '(choice (const :tag "dot like in \"2.\"" ?.)
(const :tag "paren like in \"2)\"" ?\))
(const :tag "both" t))
:set (lambda (var val) (set-default-toplevel-value var val)
(when (featurep 'org-element) (org-element-update-syntax))))
(defcustom org-list-allow-alphabetical nil
"Non-nil means single character alphabetical bullets are allowed.
Both uppercase and lowercase are handled. Lists with more than
26 items will fallback to standard numbering. Alphabetical
counters like \"[@c]\" will be recognized.
This variable needs to be set before org.el is loaded. If you
need to make a change while Emacs is running, use the customize
interface or run the following code after updating it:
`\\[org-element-update-syntax]'"
:group 'org-plain-lists
:version "24.1"
:type 'boolean
:set (lambda (var val) (set-default-toplevel-value var val)
(when (featurep 'org-element) (org-element-update-syntax))))
(defcustom org-list-two-spaces-after-bullet-regexp nil
"A regular expression matching bullets that should have 2 spaces after them.
When nil, no bullet will have two spaces after them. When
a string, it will be used as a regular expression. When the
bullet type of a list is changed, the new bullet type will be
matched against this regexp. If it matches, there will be two
spaces instead of one after the bullet in each item of the list."
:group 'org-plain-lists
:type '(choice
(const :tag "never" nil)
(regexp)))
(defcustom org-list-automatic-rules '((checkbox . t)
(indent . t))
"Non-nil means apply set of rules when acting on lists.
\\<org-mode-map>
By default, automatic actions are taken when using
`\\[org-meta-return]',
`\\[org-metaright]',
`\\[org-metaleft]',
`\\[org-shiftmetaright]',
`\\[org-shiftmetaleft]',
`\\[org-ctrl-c-minus]',
`\\[org-toggle-checkbox]',
`\\[org-insert-todo-heading]'.
You can disable individually these rules by setting them to nil.
Valid rules are:
checkbox when non-nil, checkbox statistics is updated each time
you either insert a new checkbox or toggle a checkbox.
indent when non-nil, indenting or outdenting list top-item
with its subtree will move the whole list and
outdenting a list whose bullet is * to column 0 will
change that bullet to \"-\"."
:group 'org-plain-lists
:version "24.1"
:type '(alist :tag "Sets of rules"
:key-type
(choice
(const :tag "Checkbox" checkbox)
(const :tag "Indent" indent))
:value-type
(boolean :tag "Activate" :value t)))
(defcustom org-list-use-circular-motion nil
"Non-nil means commands implying motion in lists should be cyclic.
\\<org-mode-map>
In that case, the item following the last item is the first one,
and the item preceding the first item is the last one.
This affects the behavior of
`\\[org-move-item-up]',
`\\[org-move-item-down]',
`\\[org-next-item]',
`\\[org-previous-item]'."
:group 'org-plain-lists
:version "24.1"
:type 'boolean)
(defvar org-checkbox-statistics-hook nil
"Hook that is run whenever Org thinks checkbox statistics should be updated.
This hook runs even if checkbox rule in
`org-list-automatic-rules' does not apply, so it can be used to
implement alternative ways of collecting statistics
information.")
(defcustom org-checkbox-hierarchical-statistics t
"Non-nil means checkbox statistics counts only the state of direct children.
When nil, all boxes below the cookie are counted.
This can be set to nil on a per-node basis using a COOKIE_DATA property
with the word \"recursive\" in the value."
:group 'org-plain-lists
:type 'boolean)
(defcustom org-list-indent-offset 0
"Additional indentation for sub-items in a list.
By setting this to a small number, usually 1 or 2, one can more
clearly distinguish sub-items in a list."
:group 'org-plain-lists
:version "24.1"
:type 'integer)
(defvar org-list-forbidden-blocks '("example" "verse" "src" "export")
"Names of blocks where lists are not allowed.
Names must be in lower case.")
;;; Predicates and regexps
(defconst org-list-end-re "^[ \t]*\n[ \t]*\n"
"Regex matching the end of a plain list.")
(defconst org-list-full-item-re
(concat "^[ \t]*\\(\\(?:[-+*]\\|\\(?:[0-9]+\\|[A-Za-z]\\)[.)]\\)\\(?:[ \t]+\\|$\\)\\)"
"\\(?:\\[@\\(?:start:\\)?\\([0-9]+\\|[A-Za-z]\\)\\][ \t]*\\)?"
"\\(?:\\(\\[[ X-]\\]\\)\\(?:[ \t]+\\|$\\)\\)?"
"\\(?:\\(.*\\)[ \t]+::\\(?:[ \t]+\\|$\\)\\)?")
"Matches a list item and puts everything into groups:
group 1: bullet
group 2: counter
group 3: checkbox
group 4: description tag")
(defvar org--item-re-cache nil
"Results cache for `org-item-re'.")
(defsubst org-item-re ()
"Return the correct regular expression for plain lists."
(or (plist-get
(plist-get org--item-re-cache
org-list-allow-alphabetical)
org-plain-list-ordered-item-terminator)
(let* ((term (cond
((eq org-plain-list-ordered-item-terminator t) "[.)]")
((= org-plain-list-ordered-item-terminator ?\)) ")")
((= org-plain-list-ordered-item-terminator ?.) "\\.")
(t "[.)]")))
(alpha (if org-list-allow-alphabetical "\\|[A-Za-z]" ""))
(re (concat "\\([ \t]*\\([-+]\\|\\(\\([0-9]+" alpha "\\)" term
"\\)\\)\\|[ \t]+\\*\\)\\([ \t]+\\|$\\)")))
(setq org--item-re-cache
(plist-put
org--item-re-cache
org-list-allow-alphabetical
(plist-put
(plist-get org--item-re-cache
org-list-allow-alphabetical)
org-plain-list-ordered-item-terminator
re)))
re)))
(defsubst org-item-beginning-re ()
"Regexp matching the beginning of a plain list item."
(concat "^" (org-item-re)))
(defun org-list-at-regexp-after-bullet-p (regexp)
"Is point at a list item with REGEXP after bullet?"
(and (org-at-item-p)
(save-excursion
(goto-char (match-end 0))
(let ((counter-re (concat "\\(?:\\[@\\(?:start:\\)?"
(if org-list-allow-alphabetical
"\\([0-9]+\\|[A-Za-z]\\)"
"[0-9]+")
"\\][ \t]*\\)")))
;; Ignore counter if any
(when (looking-at counter-re) (goto-char (match-end 0))))
(looking-at regexp))))
(defun org-list-in-valid-context-p ()
"Is point in a context where lists are allowed?"
(not (org-in-block-p org-list-forbidden-blocks)))
(defun org-in-item-p ()
"Return item beginning position when in a plain list, nil otherwise."
(save-excursion
(forward-line 0)
(let* ((case-fold-search t)
(context (org-list-context))
(lim-up (car context))
(inlinetask-re (and (featurep 'org-inlinetask)
(org-inlinetask-outline-regexp)))
(item-re (org-item-re))
;; Indentation isn't meaningful when point starts at an empty
;; line or an inline task.
(ind-ref (if (or (looking-at "^[ \t]*$")
(and inlinetask-re (looking-at inlinetask-re)))
10000
(org-current-text-indentation))))
(cond
((eq (nth 2 context) 'invalid) nil)
((looking-at item-re) (point))
(t
;; Detect if cursor in amidst `org-list-end-re'. First, count
;; number HL of hard lines it takes, then call `org-in-regexp'
;; to compute its boundaries END-BOUNDS. When point is
;; in-between, move cursor before regexp beginning.
(let ((hl 0) (i -1) end-bounds)
(when (and (progn
(while (setq i (string-match
"[\r\n]" org-list-end-re (1+ i)))
(setq hl (1+ hl)))
(setq end-bounds (org-in-regexp org-list-end-re hl)))
(>= (point) (car end-bounds))
(< (point) (cdr end-bounds)))
(goto-char (car end-bounds))
(forward-line -1)))
;; Look for an item, less indented that reference line.
(catch 'exit
(while t
(let ((ind (org-current-text-indentation)))
(cond
;; This is exactly what we want.
((and (looking-at item-re) (< ind ind-ref))
(throw 'exit (point)))
;; At upper bound of search or looking at the end of a
;; previous list: search is over.
((<= (point) lim-up) (throw 'exit nil))
((looking-at org-list-end-re) (throw 'exit nil))
;; Skip blocks, drawers, inline-tasks, blank lines
((and (looking-at "^[ \t]*#\\+end_")
(re-search-backward "^[ \t]*#\\+begin_" lim-up t)))
((and (looking-at "^[ \t]*:END:")
(re-search-backward org-drawer-regexp lim-up t))
(forward-line 0))
((and inlinetask-re (looking-at inlinetask-re))
(org-inlinetask-goto-beginning)
(forward-line -1))
((looking-at "^[ \t]*$") (forward-line -1))
;; Text at column 0 cannot belong to a list: stop.
((zerop ind) (throw 'exit nil))
;; Normal text less indented than reference line, take
;; it as new reference.
((< ind ind-ref)
(setq ind-ref ind)
(forward-line -1))
(t (forward-line -1)))))))))))
;; FIXME: We should make use of org-element API in more places here.
(defun org-at-item-p ()
"Is point in a line starting a hand-formatted item?
Modify match data, matching against `org-item-re'."
(save-excursion
(forward-line 0)
(and
(org-element-type-p
(org-element-at-point)
'(plain-list item))
;; Set match data.
(looking-at (org-item-re)))))
(defun org-at-item-bullet-p ()
"Is point at the bullet of a plain list item?"
(and (org-at-item-p)
(not (member (char-after) '(?\ ?\t)))
(< (point) (match-end 0))))
(defun org-at-item-timer-p ()
"Is point at a line starting a plain list item with a timer?"
(org-list-at-regexp-after-bullet-p
"\\([0-9]+:[0-9]+:[0-9]+\\)[ \t]+::[ \t]+"))
(defun org-at-item-description-p ()
"Is point at a description list item?"
(org-list-at-regexp-after-bullet-p "\\(\\S-.+\\)[ \t]+::\\([ \t]+\\|$\\)"))
(defun org-at-item-checkbox-p ()
"Is point at a line starting a plain-list item with a checklet?"
(org-list-at-regexp-after-bullet-p "\\(\\[[- X]\\]\\)[ \t]+"))
(defun org-at-item-counter-p ()
"Is point at a line starting a plain-list item with a counter?"
(and (org-at-item-p)
(looking-at org-list-full-item-re)
(match-string 2)))
;;; Structures and helper functions
(defun org-list-context ()
"Determine context, and its boundaries, around point.
Context will be a cell like (MIN MAX CONTEXT) where MIN and MAX
are boundaries and CONTEXT is a symbol among `drawer', `block',
`invalid', `inlinetask' and nil.
Contexts `block' and `invalid' refer to `org-list-forbidden-blocks'."
(save-match-data
(save-excursion
(org-with-limited-levels
(forward-line 0)
(let ((case-fold-search t) (pos (point)) beg end context-type
;; Get positions of surrounding headings. This is the
;; default context.
(lim-up (or (save-excursion (and (ignore-errors (org-back-to-heading t))
(point)))
(point-min)))
(lim-down (or (save-excursion (outline-next-heading)) (point-max))))
;; Is point inside a drawer?
(let ((end-re "^[ \t]*:END:")
(beg-re org-drawer-regexp))
(when (save-excursion
(and (not (looking-at beg-re))
(not (looking-at end-re))
(setq beg (and (re-search-backward beg-re lim-up t)
(1+ (line-end-position))))
(setq end (or (and (re-search-forward end-re lim-down t)
(1- (match-beginning 0)))
lim-down))
(>= end pos)))
(setq lim-up beg lim-down end context-type 'drawer)))
;; Is point strictly in a block, and of which type?
(let ((block-re "^[ \t]*#\\+\\(begin\\|end\\)_") type)
(when (save-excursion
(and (not (looking-at block-re))
(setq beg (and (re-search-backward block-re lim-up t)
(1+ (line-end-position))))
(looking-at "^[ \t]*#\\+begin_\\(\\S-+\\)")
(setq type (downcase (match-string 1)))
(goto-char beg)
(setq end (or (and (re-search-forward block-re lim-down t)
(1- (line-beginning-position)))
lim-down))
(>= end pos)
(equal (downcase (match-string 1)) "end")))
(setq lim-up beg lim-down end
context-type (if (member type org-list-forbidden-blocks)
'invalid 'block))))
;; Is point in an inlinetask?
(when (and (featurep 'org-inlinetask)
(save-excursion
(let* ((beg-re (org-inlinetask-outline-regexp))
(end-re (concat beg-re "END[ \t]*$")))
(and (not (looking-at "^\\*+"))
(setq beg (and (re-search-backward beg-re lim-up t)
(1+ (line-end-position))))
(not (looking-at end-re))
(setq end (and (re-search-forward end-re lim-down t)
(1- (match-beginning 0))))
(> (point) pos)))))
(setq lim-up beg lim-down end context-type 'inlinetask))
;; Return context boundaries and type.
(list lim-up lim-down context-type))))))
(defun org-list-struct ()
"Return structure of list at point.
A list structure is an alist where key is point at item, and
values are:
1. indentation,
2. bullet with trailing whitespace,
3. bullet counter, if any,
4. checkbox, if any,
5. description tag, if any,
6. position at item end.
Thus the following list, where numbers in parens are
line-beginning-position:
- [X] first item (1)
1. sub-item 1 (18)
5. [@5] sub-item 2 (34)
some other text belonging to first item (55)
- last item (97)
+ tag :: description (109)
(131)
will get the following structure:
((1 0 \"- \" nil \"[X]\" nil 97)
(18 2 \"1. \" nil nil nil 34)
(34 2 \"5. \" \"5\" nil nil 55)
(97 0 \"- \" nil nil nil 131)
(109 2 \"+ \" nil nil \"tag\" 131))
Assume point is at an item."
(save-excursion
(forward-line 0)
(let* ((case-fold-search t)
(context (org-list-context))
(lim-up (car context))
(lim-down (nth 1 context))
(text-min-ind 10000)
(item-re (org-item-re))
(inlinetask-re (and (featurep 'org-inlinetask)
(org-inlinetask-outline-regexp)))
(beg-cell (cons (point) (org-current-text-indentation)))
itm-lst itm-lst-2 end-lst end-lst-2 struct
(assoc-at-point
;; Return association at point.
(lambda (ind)
(looking-at org-list-full-item-re)
(let ((bullet (match-string-no-properties 1)))
(list (point)
ind
bullet
(match-string-no-properties 2) ; counter
(match-string-no-properties 3) ; checkbox
;; Description tag.
(and (string-match-p "[-+*]" bullet)
(match-string-no-properties 4))))))
(end-before-blank
;; Ensure list ends at the first blank line.
(lambda ()
(skip-chars-backward " \r\t\n")
(min (1+ (line-end-position)) lim-down))))
;; 1. Read list from starting item to its beginning, and save
;; top item position and indentation in BEG-CELL. Also store
;; ending position of items in END-LST.
(save-excursion
(catch 'exit
(while t
(let ((ind (org-current-text-indentation)))
(cond
((<= (point) lim-up)
;; At upward limit: if we ended at an item, store it,
;; else dismiss useless data recorded above BEG-CELL.
;; Jump to part 2.
(throw 'exit
(setq itm-lst
(if (not (looking-at item-re))
(memq (assq (car beg-cell) itm-lst) itm-lst)
(setq beg-cell (cons (point) ind))
(cons (funcall assoc-at-point ind) itm-lst)))))
;; Looking at a list ending regexp. Dismiss useless
;; data recorded above BEG-CELL. Jump to part 2.
((looking-at org-list-end-re)
(throw 'exit
(setq itm-lst
(memq (assq (car beg-cell) itm-lst) itm-lst))))
;; Point is at an item. Add data to ITM-LST. It may
;; also end a previous item: save it in END-LST. If
;; ind is less or equal than BEG-CELL and there is no
;; end at this ind or lesser, this item becomes the new
;; BEG-CELL.
((looking-at item-re)
(push (funcall assoc-at-point ind) itm-lst)
(push (cons ind (point)) end-lst)
(when (< ind text-min-ind) (setq beg-cell (cons (point) ind)))
(forward-line -1))
;; Skip blocks, drawers, inline tasks, blank lines.
((and (looking-at "^[ \t]*#\\+end_")
(re-search-backward "^[ \t]*#\\+begin_" lim-up t)))
((and (looking-at "^[ \t]*:END:")
(re-search-backward org-drawer-regexp lim-up t))
(forward-line 0))
((and inlinetask-re (looking-at inlinetask-re))
(org-inlinetask-goto-beginning)
(forward-line -1))
((looking-at "^[ \t]*$")
(forward-line -1))
;; From there, point is not at an item. Interpret
;; line's indentation:
;; - text at column 0 is necessarily out of any list.
;; Dismiss data recorded above BEG-CELL. Jump to
;; part 2.
;; - any other case may be an ending position for an
;; hypothetical item above. Store it and proceed.
((zerop ind)
(throw 'exit
(setq itm-lst
(memq (assq (car beg-cell) itm-lst) itm-lst))))
(t
(when (< ind text-min-ind) (setq text-min-ind ind))
(push (cons ind (point)) end-lst)
(forward-line -1)))))))
;; 2. Read list from starting point to its end, that is until we
;; get out of context, or that a non-item line is less or
;; equally indented than BEG-CELL's cdr. Also, store ending
;; position of items in END-LST-2.
(catch 'exit
(while t
(let ((ind (org-current-text-indentation)))
(cond
((>= (point) lim-down)
;; At downward limit: this is de facto the end of the
;; list. Save point as an ending position, and jump to
;; part 3.
(throw 'exit
(push (cons 0 (funcall end-before-blank)) end-lst-2)))
;; Looking at a list ending regexp. Save point as an
;; ending position and jump to part 3.
((looking-at org-list-end-re)
(throw 'exit (push (cons 0 (point)) end-lst-2)))
((looking-at item-re)
;; Point is at an item. Add data to ITM-LST-2. It may
;; also end a previous item, so save it in END-LST-2.
(push (funcall assoc-at-point ind) itm-lst-2)
(push (cons ind (point)) end-lst-2)
(forward-line 1))
;; Skip inline tasks and blank lines along the way
((and inlinetask-re (looking-at inlinetask-re))
(org-inlinetask-goto-end))
((looking-at "^[ \t]*$")
(forward-line 1))
;; Ind is lesser or equal than BEG-CELL's. The list is
;; over: store point as an ending position and jump to
;; part 3.
((<= ind (cdr beg-cell))
(throw 'exit
(push (cons 0 (funcall end-before-blank)) end-lst-2)))
;; Else, if ind is lesser or equal than previous item's,
;; this is an ending position: store it. In any case,
;; skip block or drawer at point, and move to next line.
(t
(when (<= ind (nth 1 (car itm-lst-2)))
(push (cons ind (point)) end-lst-2))
(cond
((and (looking-at "^[ \t]*#\\+begin_")
(re-search-forward "^[ \t]*#\\+end_" lim-down t)))
((and (looking-at org-drawer-regexp)
(re-search-forward "^[ \t]*:END:" lim-down t))))
(forward-line 1))))))
(setq struct (append itm-lst (cdr (nreverse itm-lst-2)))
end-lst (append end-lst (cdr (nreverse end-lst-2))))
;; 3. Associate each item to its end position.
(org-list-struct-assoc-end struct end-lst)
;; 4. Return STRUCT
struct)))
(defun org-list-struct-assoc-end (struct end-list)
"Associate proper ending point to items in STRUCT.
END-LIST is a pseudo-alist where car is indentation and cdr is
ending position.
This function modifies STRUCT."
(let ((endings end-list))
(mapc
(lambda (elt)
(let ((pos (car elt))
(ind (nth 1 elt)))
;; Remove end candidates behind current item.
(while (or (<= (cdar endings) pos))
(pop endings))
;; Add end position to item assoc.
(let ((old-end (nthcdr 6 elt))
(new-end (assoc-default ind endings '<=)))
(if old-end
(setcar old-end new-end)
(setcdr elt (append (cdr elt) (list new-end)))))))
struct)))
(defun org-list-prevs-alist (struct)
"Return alist between item and previous item in STRUCT."
(let ((item-end-alist (mapcar (lambda (e) (cons (car e) (nth 6 e)))
struct)))
(mapcar (lambda (e)
(let ((prev (car (rassq (car e) item-end-alist))))
(cons (car e) prev)))
struct)))
(defun org-list-parents-alist (struct)
"Return alist between item and parent in STRUCT."
(let* ((ind-to-ori (list (list (nth 1 (car struct)))))
(top-item (org-list-get-top-point struct))
(prev-pos (list top-item)))
(cons prev-pos
(mapcar (lambda (item)
(let ((pos (car item))
(ind (nth 1 item))
(prev-ind (caar ind-to-ori)))
(push pos prev-pos)
(cond
((> prev-ind ind)
;; A sub-list is over. Find the associated
;; origin in IND-TO-ORI. If it cannot be
;; found (ill-formed list), set its parent as
;; the first item less indented. If there is
;; none, make it a top-level item.
(setq ind-to-ori
(or (member (assq ind ind-to-ori) ind-to-ori)
(catch 'exit
(mapc
(lambda (e)
(when (< (car e) ind)
(throw 'exit (member e ind-to-ori))))
ind-to-ori)
(list (list ind)))))
(cons pos (cdar ind-to-ori)))
;; A sub-list starts. Every item at IND will
;; have previous item as its parent.
((< prev-ind ind)
(let ((origin (nth 1 prev-pos)))
(push (cons ind origin) ind-to-ori)
(cons pos origin)))
;; Another item in the same sub-list: it shares
;; the same parent as the previous item.
(t (cons pos (cdar ind-to-ori))))))
(cdr struct)))))
(defun org-list--delete-metadata ()
"Delete metadata from the heading at point.
Metadata are tags, planning information and properties drawers."
(save-match-data
(org-with-wide-buffer
(org-set-tags nil)
(delete-region (line-beginning-position 2)
(save-excursion
(org-end-of-meta-data)
(org-skip-whitespace)
(if (eobp) (point) (line-beginning-position)))))))
;;; Accessors
(defsubst org-list-get-nth (n key struct)
"Return the Nth value of KEY in STRUCT."
(nth n (assq key struct)))
(defun org-list-set-nth (n key struct new)
"Set the Nth value of KEY in STRUCT to NEW.
\nThis function modifies STRUCT."
(setcar (nthcdr n (assq key struct)) new))
(defsubst org-list-get-ind (item struct)
"Return indentation of ITEM in STRUCT."
(org-list-get-nth 1 item struct))
(defun org-list-set-ind (item struct ind)
"Set indentation of ITEM in STRUCT to IND.
\nThis function modifies STRUCT."
(org-list-set-nth 1 item struct ind))
(defsubst org-list-get-bullet (item struct)
"Return bullet of ITEM in STRUCT."
(org-list-get-nth 2 item struct))
(defun org-list-set-bullet (item struct bullet)
"Set bullet of ITEM in STRUCT to BULLET.
\nThis function modifies STRUCT."
(org-list-set-nth 2 item struct bullet))
(defsubst org-list-get-counter (item struct)
"Return counter of ITEM in STRUCT."
(org-list-get-nth 3 item struct))
(defsubst org-list-get-checkbox (item struct)
"Return checkbox of ITEM in STRUCT or nil."
(org-list-get-nth 4 item struct))
(defun org-list-set-checkbox (item struct checkbox)
"Set checkbox of ITEM in STRUCT to CHECKBOX.
\nThis function modifies STRUCT."
(org-list-set-nth 4 item struct checkbox))
(defsubst org-list-get-tag (item struct)
"Return end position of ITEM in STRUCT."
(org-list-get-nth 5 item struct))
(defun org-list-get-item-end (item struct)
"Return end position of ITEM in STRUCT."
(org-list-get-nth 6 item struct))
(defun org-list-get-item-end-before-blank (item struct)
"Return point at end of ITEM in STRUCT, before any blank line.
Point returned is at end of line."
(save-excursion
(goto-char (org-list-get-item-end item struct))
(skip-chars-backward " \r\t\n")
(line-end-position)))
(defun org-list-get-parent (item struct parents)
"Return parent of ITEM or nil.
STRUCT is the list structure. PARENTS is the alist of parents,
as returned by `org-list-parents-alist'."
(let ((parents (or parents (org-list-parents-alist struct))))
(cdr (assq item parents))))
(defun org-list-has-child-p (item struct)
"Non-nil if ITEM has a child.
STRUCT is the list structure.
Value returned is the position of the first child of ITEM."
(let ((ind (org-list-get-ind item struct))
(child-maybe (car (nth 1 (member (assq item struct) struct)))))
(when (and child-maybe
(< ind (org-list-get-ind child-maybe struct)))
child-maybe)))
(defun org-list-get-next-item (item _struct prevs)
"Return next item in same sub-list as ITEM, or nil.
STRUCT is the list structure. PREVS is the alist of previous
items, as returned by `org-list-prevs-alist'."
(car (rassq item prevs)))
(defun org-list-get-prev-item (item _struct prevs)
"Return previous item in same sub-list as ITEM, or nil.
STRUCT is the list structure. PREVS is the alist of previous
items, as returned by `org-list-prevs-alist'."
(cdr (assq item prevs)))
(defun org-list-get-subtree (item struct)
"List all items having ITEM as a common ancestor, or nil.
STRUCT is the list structure."
(let* ((item-end (org-list-get-item-end item struct))
(sub-struct (cdr (member (assq item struct) struct)))
items)
(catch :exit
(pcase-dolist (`(,pos . ,_) sub-struct)
(if (< pos item-end)
(push pos items)
(throw :exit nil))))
(nreverse items)))
(defun org-list-get-all-items (item struct prevs)
"List all items in the same sub-list as ITEM.
STRUCT is the list structure. PREVS is the alist of previous
items, as returned by `org-list-prevs-alist'."
(let ((prev-item item)
(next-item item)
before-item after-item)
(while (setq prev-item (org-list-get-prev-item prev-item struct prevs))
(push prev-item before-item))
(while (setq next-item (org-list-get-next-item next-item struct prevs))
(push next-item after-item))
(append before-item (list item) (nreverse after-item))))
(defun org-list-get-children (item _struct parents)
"List all children of ITEM, or nil.
STRUCT is the list structure. PARENTS is the alist of parents,
as returned by `org-list-parents-alist'."
(let (all child)
(while (setq child (car (rassq item parents)))
(setq parents (cdr (member (assq child parents) parents)))
(push child all))
(nreverse all)))
(defun org-list-get-top-point (struct)
"Return point at beginning of list.
STRUCT is the list structure."
(caar struct))
(defun org-list-get-bottom-point (struct)
"Return point at bottom of list.
STRUCT is the list structure."
(apply #'max
(mapcar (lambda (e) (org-list-get-item-end (car e) struct)) struct)))
(defun org-list-get-list-begin (item struct prevs)
"Return point at beginning of sub-list ITEM belongs.
STRUCT is the list structure. PREVS is the alist of previous
items, as returned by `org-list-prevs-alist'."
(let ((first-item item) prev-item)
(while (setq prev-item (org-list-get-prev-item first-item struct prevs))
(setq first-item prev-item))
first-item))
(defalias 'org-list-get-first-item 'org-list-get-list-begin)
(defun org-list-get-last-item (item struct prevs)
"Return point at last item of sub-list ITEM belongs.
STRUCT is the list structure. PREVS is the alist of previous
items, as returned by `org-list-prevs-alist'."
(let ((last-item item) next-item)
(while (setq next-item (org-list-get-next-item last-item struct prevs))
(setq last-item next-item))
last-item))
(defun org-list-get-list-end (item struct prevs)
"Return point at end of sub-list ITEM belongs.
STRUCT is the list structure. PREVS is the alist of previous
items, as returned by `org-list-prevs-alist'."
(org-list-get-item-end (org-list-get-last-item item struct prevs) struct))
(defun org-list-get-list-type (item struct prevs)
"Return the type of the list containing ITEM, as a symbol.
STRUCT is the list structure. PREVS is the alist of previous
items, as returned by `org-list-prevs-alist'.
Possible types are `descriptive', `ordered' and `unordered'. The
type is determined by the first item of the list."
(let ((first (org-list-get-list-begin item struct prevs)))
(cond
((string-match-p "[[:alnum:]]" (org-list-get-bullet first struct)) 'ordered)
((org-list-get-tag first struct) 'descriptive)
(t 'unordered))))
(defun org-list-get-item-number (item struct prevs parents)
"Return ITEM's sequence number.
STRUCT is the list structure. PREVS is the alist of previous
items, as returned by `org-list-prevs-alist'. PARENTS is the
alist of ancestors, as returned by `org-list-parents-alist'.
Return value is a list of integers. Counters have an impact on
that value."
(let ((get-relative-number
(lambda (item struct prevs)
;; Return relative sequence number of ITEM in the sub-list
;; it belongs. STRUCT is the list structure. PREVS is
;; the alist of previous items.
(let ((seq 0) (pos item) counter)
(while (and (not (setq counter (org-list-get-counter pos struct)))
(setq pos (org-list-get-prev-item pos struct prevs)))
(cl-incf seq))
(if (not counter) (1+ seq)
(cond
((string-match "[A-Za-z]" counter)
(+ (- (string-to-char (upcase (match-string 0 counter))) 64)
seq))
((string-match "[0-9]+" counter)
(+ (string-to-number (match-string 0 counter)) seq))
(t (1+ seq))))))))
;; Cons each parent relative number into return value (OUT).
(let ((out (list (funcall get-relative-number item struct prevs)))
(parent item))
(while (setq parent (org-list-get-parent parent struct parents))
(push (funcall get-relative-number parent struct prevs) out))
;; Return value.
out)))
;;; Searching
(defun org-list-search-generic (search re bound noerr)
"Search a string in valid contexts for lists.
Arguments SEARCH, RE, BOUND and NOERR are similar to those used
in `re-search-forward'."
(catch 'exit
(let ((origin (point)))
(while t
;; 1. No match: return to origin or bound, depending on NOERR.
(unless (funcall search re bound noerr)
(throw 'exit (and (goto-char (if (memq noerr '(t nil)) origin bound))
nil)))
;; 2. Match in valid context: return point. Else, continue
;; searching.
(when (org-list-in-valid-context-p) (throw 'exit (point)))))))
(defun org-list-search-backward (regexp &optional bound noerror)
"Like `re-search-backward' but stop only where lists are recognized.
Arguments REGEXP, BOUND and NOERROR are similar to those used in
`re-search-backward'."
(org-list-search-generic #'re-search-backward
regexp (or bound (point-min)) noerror))
(defun org-list-search-forward (regexp &optional bound noerror)
"Like `re-search-forward' but stop only where lists are recognized.
Arguments REGEXP, BOUND and NOERROR are similar to those used in
`re-search-forward'."
(org-list-search-generic #'re-search-forward
regexp (or bound (point-max)) noerror))
;;; Methods on structures
(defsubst org-list-bullet-string (bullet)
"Return BULLET with the correct number of whitespaces.
It determines the number of whitespaces to append by looking at
`org-list-two-spaces-after-bullet-regexp'."
(save-match-data
(let ((spaces (if (and org-list-two-spaces-after-bullet-regexp
(string-match
org-list-two-spaces-after-bullet-regexp bullet))
" "
" ")))
(if (string-match "\\S-+\\([ \t]*\\)" bullet)
(replace-match spaces nil nil bullet 1)
bullet))))
(defun org-list-swap-items (beg-A beg-B struct)
"Swap item starting at BEG-A with item starting at BEG-B in STRUCT.
Blank lines at the end of items are left in place. Item
visibility is preserved. Return the new structure after the
changes.
Assume BEG-A is lesser than BEG-B and that BEG-A and BEG-B belong
to the same sub-list.
This function modifies STRUCT."
(save-excursion
(org-fold-core-ignore-modifications
(let* ((end-A-no-blank (org-list-get-item-end-before-blank beg-A struct))
(end-B-no-blank (org-list-get-item-end-before-blank beg-B struct))
(end-A (org-list-get-item-end beg-A struct))
(end-B (org-list-get-item-end beg-B struct))
(size-A (- end-A-no-blank beg-A))
(size-B (- end-B-no-blank beg-B))
(body-A (buffer-substring beg-A end-A-no-blank))
(body-B (buffer-substring beg-B end-B-no-blank))
(between-A-no-blank-and-B (buffer-substring end-A-no-blank beg-B))
(sub-A (cons beg-A (org-list-get-subtree beg-A struct)))
(sub-B (cons beg-B (org-list-get-subtree beg-B struct)))
;; Store inner folds responsible for visibility status.
(folds
(cons
(org-fold-core-get-regions :from beg-A :to end-A :relative t)
(org-fold-core-get-regions :from beg-B :to end-B :relative t))))
;; Clear up the folds.
(org-fold-region beg-A end-B-no-blank nil)
;; 1. Move effectively items in buffer.
(goto-char beg-A)
(delete-region beg-A end-B-no-blank)
(insert (concat body-B between-A-no-blank-and-B body-A))
;; Restore visibility status.
(org-fold-core-regions (cdr folds) :relative beg-A)
(org-fold-core-regions
(car folds)
:relative (+ beg-A size-B (length between-A-no-blank-and-B)))
;; 2. Now modify struct. No need to re-read the list, the
;; transformation is just a shift of positions. Some special
;; attention is required for items ending at END-A and END-B
;; as empty spaces are not moved there. In others words,
;; item BEG-A will end with whitespaces that were at the end
;; of BEG-B and the same applies to BEG-B.
(dolist (e struct)
(let ((pos (car e)))
(cond
((< pos beg-A))
((memq pos sub-A)
(let ((end-e (nth 6 e)))
(setcar e (+ pos (- end-B-no-blank end-A-no-blank)))
(setcar (nthcdr 6 e)
(+ end-e (- end-B-no-blank end-A-no-blank)))
(when (= end-e end-A) (setcar (nthcdr 6 e) end-B))))
((memq pos sub-B)
(let ((end-e (nth 6 e)))
(setcar e (- (+ pos beg-A) beg-B))
(setcar (nthcdr 6 e) (+ end-e (- beg-A beg-B)))
(when (= end-e end-B)
(setcar (nthcdr 6 e)
(+ beg-A size-B (- end-A end-A-no-blank))))))
((< pos beg-B)
(let ((end-e (nth 6 e)))
(setcar e (+ pos (- size-B size-A)))
(setcar (nthcdr 6 e) (+ end-e (- size-B size-A))))))))
(setq struct (sort struct #'car-less-than-car))
;; Return structure.
struct))))
(defun org-list-separating-blank-lines-number (pos struct prevs)
"Return number of blank lines that should separate items in list.
POS is the position of point where `org-list-insert-item' was called.
STRUCT is the list structure. PREVS is the alist of previous
items, as returned by `org-list-prevs-alist'.
Assume point is at item's beginning. If the item is alone, apply
some heuristics to guess the result."
(save-excursion
(let ((item (point))
(insert-blank-p
(cdr (assq 'plain-list-item org-blank-before-new-entry)))
usr-blank
(count-blanks
(lambda ()
;; Count blank lines above beginning of line.
(save-excursion
(count-lines (goto-char (line-beginning-position))
(progn (skip-chars-backward " \r\t\n")
(forward-line)
(point)))))))
(cond
;; Trivial cases where there should be none.
((not insert-blank-p) 0)
;; When `org-blank-before-new-entry' says so, it is 1.
((eq insert-blank-p t) 1)
;; `plain-list-item' is 'auto. Count blank lines separating
;; neighbors' items in list.
(t (let ((next-p (org-list-get-next-item item struct prevs)))
(cond
;; Is there a next item?
(next-p (goto-char next-p)
(funcall count-blanks))
;; Is there a previous item?
((org-list-get-prev-item item struct prevs)
(funcall count-blanks))
;; User inserted blank lines, trust him.
((and (> pos (org-list-get-item-end-before-blank item struct))
(> (save-excursion (goto-char pos)
(setq usr-blank (funcall count-blanks)))
0))
usr-blank)
;; Are there blank lines inside the list so far?
((save-excursion
(goto-char (org-list-get-top-point struct))
;; Do not use `org-list-search-forward' so blank lines
;; in blocks can be counted in.
(re-search-forward
"^[ \t]*$" (org-list-get-item-end-before-blank item struct) t))
1)
;; Default choice: no blank line.
(t 0))))))))
(defun org-list-insert-item (pos struct prevs &optional checkbox after-bullet)
"Insert a new list item at POS and return the new structure.
If POS is before first character after bullet of the item, the
new item will be created before the current one.
STRUCT is the list structure. PREVS is the alist of previous
items, as returned by `org-list-prevs-alist'.
Insert a checkbox if CHECKBOX is non-nil, and string AFTER-BULLET
after the bullet. Cursor will be after this text once the
function ends.
This function modifies STRUCT."
(let* ((case-fold-search t)
;; Get information about list: ITEM containing POS, position
;; of point with regards to item start (BEFOREP), blank lines
;; number separating items (BLANK-NB), if we're allowed to
;; (SPLIT-LINE-P).
(item
(catch :exit
(let ((i nil))
(pcase-dolist (`(,start ,_ ,_ ,_ ,_ ,_ ,end) struct)
(cond
((> start pos) (throw :exit i))
((< end pos) nil) ;skip sub-lists before point
(t (setq i start))))
;; If no suitable item is found, insert a sibling of the
;; last item in buffer.
(or i (caar (reverse struct))))))
(item-end (org-list-get-item-end item struct))
(item-end-no-blank (org-list-get-item-end-before-blank item struct))
(beforep
(progn
(goto-char item)
(looking-at org-list-full-item-re)
(<= pos
(cond
((not (match-beginning 4)) (match-end 0))
;; Ignore tag in a non-descriptive list.
((save-match-data (string-match "[.)]" (match-string 1)))
(match-beginning 4))
(t (save-excursion
(goto-char (match-end 4))
(skip-chars-forward " \t")
(point)))))))
(split-line-p (org-get-alist-option org-M-RET-may-split-line 'item))
(blank-nb (org-list-separating-blank-lines-number pos struct prevs))
;; Build the new item to be created. Concatenate same bullet
;; as item, checkbox, text AFTER-BULLET if provided, and text
;; cut from point to end of item (TEXT-CUT) to form item's
;; BODY. TEXT-CUT depends on BEFOREP and SPLIT-LINE-P. The
;; difference of size between what was cut and what was
;; inserted in buffer is stored in SIZE-OFFSET.
(ind (org-list-get-ind item struct))
(ind-size (if indent-tabs-mode
(+ (/ ind tab-width) (mod ind tab-width))
ind))
(bullet (org-list-bullet-string (org-list-get-bullet item struct)))
(box (and checkbox "[ ]"))
(text-cut
(and (not beforep)
split-line-p
(progn
(goto-char pos)
;; If POS is greater than ITEM-END, then point is in
;; some white lines after the end of the list. Those
;; must be removed, or they will be left, stacking up
;; after the list.
(when (< item-end pos)
(delete-region (1- item-end) (line-end-position)))
(skip-chars-backward " \r\t\n")
;; Cut position is after any blank on the line.
(save-excursion
(skip-chars-forward " \t")
(setq pos (point)))
(delete-and-extract-region (point) item-end-no-blank))))
(body
(concat bullet
(and box (concat box " "))
after-bullet
(and text-cut
(if (string-match "\\`[ \t]+" text-cut)
(replace-match "" t t text-cut)
text-cut))))
(item-sep (make-string (1+ blank-nb) ?\n))
(item-size (+ ind-size (length body) (length item-sep)))
(size-offset (- item-size (length text-cut))))
;; Insert effectively item into buffer.
(goto-char item)
(indent-to-column ind)
(insert body item-sep)
;; Add new item to STRUCT.
(dolist (e struct)
(let ((p (car e)) (end (nth 6 e)))
(cond
;; Before inserted item, positions don't change but an item
;; ending after insertion has its end shifted by SIZE-OFFSET.
((< p item)
(when (> end item)
(setcar (nthcdr 6 e) (+ end size-offset))))
;; Item where insertion happens may be split in two parts.
;; In this case, move start by ITEM-SIZE and end by
;; SIZE-OFFSET.
((and (= p item) (not beforep) split-line-p)
(setcar e (+ p item-size))
(setcar (nthcdr 6 e) (+ end size-offset)))
;; Items starting after modified item fall into two
;; categories.
;;
;; If modified item was split, and current sub-item was
;; located after split point, it was moved to the new item:
;; the part between body start and split point (POS) was
;; removed. So we compute the length of that part and shift
;; item's positions accordingly.
;;
;; Otherwise, the item was simply shifted by SIZE-OFFSET.
((and split-line-p (not beforep) (>= p pos) (<= p item-end-no-blank))
(let ((offset (- pos item ind (length bullet) (length after-bullet))))
(setcar e (- p offset))
(setcar (nthcdr 6 e) (- end offset))))
(t
(setcar e (+ p size-offset))
(setcar (nthcdr 6 e) (+ end size-offset))))))
(push (list item ind bullet nil box nil (+ item item-size)) struct)
(setq struct (sort struct #'car-less-than-car))
;; If not BEFOREP, new item must appear after ITEM, so exchange
;; ITEM with the next item in list. Position cursor after bullet,
;; counter, checkbox, and label.
(if beforep
(goto-char item)
(setq struct (org-list-swap-items item (+ item item-size) struct))
(goto-char (org-list-get-next-item
item struct (org-list-prevs-alist struct))))
struct))
(defun org-list-delete-item (item struct)
"Remove ITEM from the list and return the new structure.
STRUCT is the list structure."
(let* ((end (org-list-get-item-end item struct))
(beg (if (= (org-list-get-bottom-point struct) end)
;; If ITEM ends with the list, delete blank lines
;; before it.
(save-excursion
(goto-char item)
(skip-chars-backward " \r\t\n")
(min (1+ (line-end-position)) (point-max)))
item)))
;; Remove item from buffer.
(delete-region beg end)
;; Remove item from structure and shift others items accordingly.
;; Don't forget to shift also ending position when appropriate.
(let ((size (- end beg)))
(delq nil (mapcar (lambda (e)
(let ((pos (car e)))
(cond
((< pos item)
(let ((end-e (nth 6 e)))
(cond
((< end-e item) e)
((= end-e item)
(append (butlast e) (list beg)))
(t
(append (butlast e) (list (- end-e size)))))))
((< pos end) nil)
(t
(cons (- pos size)
(append (butlast (cdr e))
(list (- (nth 6 e) size))))))))
struct)))))
(defun org-list-send-item (item dest struct)
"Send ITEM to destination DEST.
STRUCT is the list structure.
DEST can have various values.
If DEST is a buffer position, the function will assume it points
to another item in the same list as ITEM, and will move the
latter just before the former.
If DEST is `begin' (respectively `end'), ITEM will be moved at
the beginning (respectively end) of the list it belongs to.
If DEST is a string like \"N\", where N is an integer, ITEM will
be moved at the Nth position in the list.
If DEST is `kill', ITEM will be deleted and its body will be
added to the kill-ring.
If DEST is `delete', ITEM will be deleted.
Visibility of item is preserved.
This function returns, destructively, the new list structure."
(let* ((prevs (org-list-prevs-alist struct))
(item-end (org-list-get-item-end item struct))
;; Grab full item body minus its bullet.
(body (org-trim
(buffer-substring
(save-excursion
(goto-char item)
(looking-at
(concat "[ \t]*"
(regexp-quote (org-list-get-bullet item struct))))
(match-end 0))
item-end)))
;; Change DEST into a buffer position. A trick is needed
;; when ITEM is meant to be sent at the end of the list.
;; Indeed, by setting locally `org-M-RET-may-split-line' to
;; nil and insertion point (INS-POINT) to the first line's
;; end of the last item, we ensure the new item will be
;; inserted after the last item, and not after any of its
;; hypothetical sub-items.
(ins-point (cond
((or (eq dest 'kill) (eq dest 'delete)))
((eq dest 'begin)
(setq dest (org-list-get-list-begin item struct prevs)))
((eq dest 'end)
(setq dest (org-list-get-list-end item struct prevs))
(save-excursion
(goto-char (org-list-get-last-item item struct prevs))
(line-end-position)))
((and (stringp dest) (string-match-p "\\`[0-9]+\\'" dest))
(let* ((all (org-list-get-all-items item struct prevs))
(len (length all))
(index (mod (string-to-number dest) len)))
(if (not (zerop index))
(setq dest (nth (1- index) all))
;; Send ITEM at the end of the list.
(setq dest (org-list-get-list-end item struct prevs))
(save-excursion
(goto-char
(org-list-get-last-item item struct prevs))
(line-end-position)))))
(t dest)))
(org-M-RET-may-split-line nil)
;; Store inner overlays (to preserve visibility).
(overlays (cl-remove-if (lambda (o) (or (< (overlay-start o) item)
(> (overlay-end o) item)))
(overlays-in item item-end))))
(cond
((eq dest 'delete) (org-list-delete-item item struct))
((eq dest 'kill)
(kill-new body)
(org-list-delete-item item struct))
((and (integerp dest) (/= item ins-point))
(setq item (copy-marker item))
(setq struct (org-list-insert-item ins-point struct prevs nil body))
;; 1. Structure returned by `org-list-insert-item' may not be
;; accurate, as it cannot see sub-items included in BODY.
;; Thus, first compute the real structure so far.
(let ((moved-items
(cons (marker-position item)
(org-list-get-subtree (marker-position item) struct)))
(new-end (org-list-get-item-end (point) struct))
(old-end (org-list-get-item-end (marker-position item) struct))
(new-item (point))
(shift (- (point) item)))
;; 1.1. Remove the item just created in structure.
(setq struct (delete (assq new-item struct) struct))
;; 1.2. Copy ITEM and any of its sub-items at NEW-ITEM.
(setq struct (sort
(append
struct
(mapcar (lambda (e)
(let* ((cell (assq e struct))
(pos (car cell))
(end (nth 6 cell)))
(cons (+ pos shift)
(append (butlast (cdr cell))
(list (if (= end old-end)
new-end
(+ end shift)))))))
moved-items))
#'car-less-than-car)))
;; 2. Restore inner overlays.
(dolist (o overlays)
(move-overlay o
(+ (overlay-start o) (- (point) item))
(+ (overlay-end o) (- (point) item))))
;; 3. Eventually delete extra copy of the item and clean marker.
(prog1 (org-list-delete-item (marker-position item) struct)
(move-marker item nil)))
(t struct))))
(defun org-list-struct-outdent (start end struct parents)
"Outdent items between positions START and END.
STRUCT is the list structure. PARENTS is the alist of items'
parents, as returned by `org-list-parents-alist'.
START is included, END excluded."
(let* (acc
(out (lambda (cell)
(let* ((item (car cell))
(parent (cdr cell)))
(cond
;; Item not yet in zone: keep association.
((< item start) cell)
;; Item out of zone: follow associations in ACC.
((>= item end)
(let ((convert (and parent (assq parent acc))))
(if convert (cons item (cdr convert)) cell)))
;; Item has no parent: error
((not parent)
(error "Cannot outdent top-level items"))
;; Parent is outdented: keep association.
((>= parent start)
(push (cons parent item) acc) cell)
(t
;; Parent isn't outdented: reparent to grand-parent.
(let ((grand-parent (org-list-get-parent
parent struct parents)))
(push (cons parent item) acc)
(cons item grand-parent))))))))
(mapcar out parents)))
(defun org-list-struct-indent (start end struct parents prevs)
"Indent items between positions START and END.
STRUCT is the list structure. PARENTS is the alist of parents
and PREVS is the alist of previous items, returned by,
respectively, `org-list-parents-alist' and
`org-list-prevs-alist'.
START is included and END excluded.
STRUCT may be modified if `org-list-demote-modify-bullet' matches
bullets between START and END."
(let* (acc
(set-assoc (lambda (cell) (push cell acc) cell))
(ind
(lambda (cell)
(let* ((item (car cell))
(parent (cdr cell)))
(cond
;; Item not yet in zone: keep association.
((< item start) cell)
((>= item end)
;; Item out of zone: follow associations in ACC.
(let ((convert (assq parent acc)))
(if convert (cons item (cdr convert)) cell)))
(t
;; Item is in zone...
(let ((prev (org-list-get-prev-item item struct prevs)))
;; Check if bullet needs to be changed.
(pcase (assoc (let ((b (org-list-get-bullet item struct))
(case-fold-search nil))
(cond ((string-match "[A-Z]\\." b) "A.")
((string-match "[A-Z])" b) "A)")
((string-match "[a-z]\\." b) "a.")
((string-match "[a-z])" b) "a)")
((string-match "[0-9]\\." b) "1.")
((string-match "[0-9])" b) "1)")
(t (org-trim b))))
org-list-demote-modify-bullet)
(`(,_ . ,bullet)
(org-list-set-bullet
item struct (org-list-bullet-string bullet)))
(_ nil))
(cond
;; First item indented but not parent: error
((and (not prev) (or (not parent) (< parent start)))
(user-error "Cannot indent the first item of a list"))
;; First item and parent indented: keep same
;; parent.
((not prev) (funcall set-assoc cell))
;; Previous item not indented: reparent to it.
((< prev start) (funcall set-assoc (cons item prev)))
;; Previous item indented: reparent like it.
(t
(funcall set-assoc
(cons item (cdr (assq prev acc)))))))))))))
(mapcar ind parents)))
;;; Repairing structures
(defun org-list-use-alpha-bul-p (first struct prevs)
"Non-nil if list starting at FIRST can have alphabetical bullets.
STRUCT is list structure. PREVS is the alist of previous items,
as returned by `org-list-prevs-alist'."
(and org-list-allow-alphabetical
(catch 'exit
(let ((item first) (ascii 64) (case-fold-search nil))
;; Pretend that bullets are uppercase and check if alphabet
;; is sufficient, taking counters into account.
(while item
(let ((count (org-list-get-counter item struct)))
;; Virtually determine current bullet
(if (and count (string-match-p "[a-zA-Z]" count))
;; Counters are not case-sensitive.
(setq ascii (string-to-char (upcase count)))
(setq ascii (1+ ascii)))
;; Test if bullet would be over z or Z.
(if (> ascii 90)
(throw 'exit nil)
(setq item (org-list-get-next-item item struct prevs)))))
;; All items checked. All good.
t))))
(defun org-list-inc-bullet-maybe (bullet)
"Increment BULLET if applicable."
(let ((case-fold-search nil))
(cond
;; Num bullet: increment it.
((string-match "[0-9]+" bullet)
(replace-match
(number-to-string (1+ (string-to-number (match-string 0 bullet))))
nil nil bullet))
;; Alpha bullet: increment it.
((string-match "[A-Za-z]" bullet)
(replace-match
(char-to-string (1+ (string-to-char (match-string 0 bullet))))
nil nil bullet))
;; Unordered bullet: leave it.
(t bullet))))
(defun org-list-struct-fix-bul (struct prevs)
"Verify and correct bullets in STRUCT.
PREVS is the alist of previous items, as returned by
`org-list-prevs-alist'.
This function modifies STRUCT."
(let ((case-fold-search nil)
(fix-bul
;; Set bullet of ITEM in STRUCT, depending on the type of
;; first item of the list, the previous bullet and counter
;; if any.
(lambda (item)
(let* ((prev (org-list-get-prev-item item struct prevs))
(prev-bul (and prev (org-list-get-bullet prev struct)))
(counter (org-list-get-counter item struct))
(bullet (org-list-get-bullet item struct))
(alphap (and (not prev)
(org-list-use-alpha-bul-p item struct prevs))))
(org-list-set-bullet
item struct
(org-list-bullet-string
(cond
;; Alpha counter in alpha list: use counter.
((and prev counter
(string-match "[a-zA-Z]" counter)
(string-match "[a-zA-Z]" prev-bul))
;; Use cond to be sure `string-match' is used in
;; both cases.
(let ((real-count
(cond
((string-match "[a-z]" prev-bul) (downcase counter))
((string-match "[A-Z]" prev-bul) (upcase counter)))))
(replace-match real-count nil nil prev-bul)))
;; Num counter in a num list: use counter.
((and prev counter
(string-match "[0-9]+" counter)
(string-match "[0-9]+" prev-bul))
(replace-match counter nil nil prev-bul))
;; No counter: increase, if needed, previous bullet.
(prev
(org-list-inc-bullet-maybe (org-list-get-bullet prev struct)))
;; Alpha counter at first item: use counter.
((and counter (org-list-use-alpha-bul-p item struct prevs)
(string-match "[A-Za-z]" counter)
(string-match "[A-Za-z]" bullet))
(let ((real-count
(cond
((string-match "[a-z]" bullet) (downcase counter))
((string-match "[A-Z]" bullet) (upcase counter)))))
(replace-match real-count nil nil bullet)))
;; Num counter at first item: use counter.
((and counter
(string-match "[0-9]+" counter)
(string-match "[0-9]+" bullet))
(replace-match counter nil nil bullet))
;; First bullet is alpha uppercase: use "A".
((and alphap (string-match "[A-Z]" bullet))
(replace-match "A" nil nil bullet))
;; First bullet is alpha lowercase: use "a".
((and alphap (string-match "[a-z]" bullet))
(replace-match "a" nil nil bullet))
;; First bullet is num: use "1".
((string-match "\\([0-9]+\\|[A-Za-z]\\)" bullet)
(replace-match "1" nil nil bullet))
;; Not an ordered list: keep bullet.
(t bullet))))))))
(mapc fix-bul (mapcar #'car struct))))
(defun org-list-struct-fix-ind (struct parents &optional bullet-size)
"Verify and correct indentation in STRUCT.
PARENTS is the alist of parents, as returned by
`org-list-parents-alist'.
If numeric optional argument BULLET-SIZE is set, assume all
bullets in list have this length to determine new indentation.
This function modifies STRUCT."
(let* ((ancestor (org-list-get-top-point struct))
(top-ind (org-list-get-ind ancestor struct))
(new-ind
(lambda (item)
(let ((parent (org-list-get-parent item struct parents)))
(if parent
;; Indent like parent + length of parent's bullet +
;; sub-list offset.
(org-list-set-ind
item struct (+ (or bullet-size
(length
(org-list-get-bullet parent struct)))
(org-list-get-ind parent struct)
org-list-indent-offset))
;; If no parent, indent like top-point.
(org-list-set-ind item struct top-ind))))))
(mapc new-ind (mapcar #'car (cdr struct)))))
(defun org-list-struct-fix-box (struct parents prevs &optional ordered)
"Verify and correct checkboxes in STRUCT.
PARENTS is the alist of parents and PREVS is the alist of
previous items, as returned by, respectively,
`org-list-parents-alist' and `org-list-prevs-alist'.
If ORDERED is non-nil, a checkbox can only be checked when every
checkbox before it is checked too. If there was an attempt to
break this rule, the function will return the blocking item. In
all others cases, the return value will be nil.
This function modifies STRUCT."
(let ((all-items (mapcar #'car struct))
(set-parent-box
(lambda (item)
(let* ((box-list
(mapcar (lambda (child)
(org-list-get-checkbox child struct))
(org-list-get-children item struct parents))))
(org-list-set-checkbox
item struct
(cond
((and (member "[ ]" box-list) (member "[X]" box-list)) "[-]")
((member "[-]" box-list) "[-]")
((member "[X]" box-list) "[X]")
((member "[ ]" box-list) "[ ]")
;; Parent has no boxed child: leave box as-is.
(t (org-list-get-checkbox item struct)))))))
parent-list)
;; 1. List all parents with a checkbox.
(mapc
(lambda (e)
(let* ((parent (org-list-get-parent e struct parents))
(parent-box-p (org-list-get-checkbox parent struct)))
(when (and parent-box-p (not (memq parent parent-list)))
(push parent parent-list))))
all-items)
;; 2. Sort those parents by decreasing indentation.
(setq parent-list (sort parent-list
(lambda (e1 e2)
(> (org-list-get-ind e1 struct)
(org-list-get-ind e2 struct)))))
;; 3. For each parent, get all children's checkboxes to determine
;; and set its checkbox accordingly.
(mapc set-parent-box parent-list)
;; 4. If ORDERED is set, see if we need to uncheck some boxes.
(when ordered
(let* ((box-list
(mapcar (lambda (e) (org-list-get-checkbox e struct)) all-items))
(after-unchecked (member "[ ]" box-list)))
;; There are boxes checked after an unchecked one: fix that.
(when (member "[X]" after-unchecked)
(let ((index (- (length struct) (length after-unchecked))))
(dolist (e (nthcdr index all-items))
(when (org-list-get-checkbox e struct)
(org-list-set-checkbox e struct "[ ]")))
;; Verify once again the structure, without ORDERED.
(org-list-struct-fix-box struct parents prevs nil)
;; Return blocking item.
(nth index all-items)))))))
(defun org-list-struct-fix-item-end (struct)
"Verify and correct each item end position in STRUCT.
This function modifies STRUCT."
(let (end-list acc-end)
(pcase-dolist (`(,pos . ,_) struct)
(let ((ind-pos (org-list-get-ind pos struct))
(end-pos (org-list-get-item-end pos struct)))
(unless (assq end-pos struct)
;; To determine real ind of an ending position that is not
;; at an item, we have to find the item it belongs to: it is
;; the last item (ITEM-UP), whose ending is further than the
;; position we're interested in.
(let ((item-up (assoc-default end-pos acc-end #'>)))
(push (cons
;; Else part is for the bottom point.
(if item-up (+ (org-list-get-ind item-up struct) 2) 0)
end-pos)
end-list)))
(push (cons ind-pos pos) end-list)
(push (cons end-pos pos) acc-end)))
(setq end-list (sort end-list (lambda (e1 e2) (< (cdr e1) (cdr e2)))))
(org-list-struct-assoc-end struct end-list)))
(defun org-list-struct-apply-struct (struct old-struct)
"Apply set difference between STRUCT and OLD-STRUCT to the buffer.
OLD-STRUCT is the structure before any modifications, and STRUCT
the structure to be applied. The function will only modify parts
of the list which have changed.
Initial position of cursor is restored after the changes."
(let* ((origin (point-marker))
(inlinetask-re (and (featurep 'org-inlinetask)
(org-inlinetask-outline-regexp)))
(item-re (org-item-re))
(shift-body-ind
;; Shift the indentation between END and BEG by DELTA.
;; Start from the line before END.
(lambda (end beg delta)
(goto-char end)
(skip-chars-backward " \r\t\n")
(forward-line 0)
(while (or (> (point) beg)
(and (= (point) beg)
(not (looking-at item-re))))
(cond
;; Skip inline tasks.
((and inlinetask-re (looking-at inlinetask-re))
(org-inlinetask-goto-beginning))
;; Shift only non-empty lines.
((looking-at-p "^[ \t]*\\S-")
(indent-line-to (+ (org-current-text-indentation) delta))))
(forward-line -1))))
(modify-item
;; Replace ITEM first line elements with new elements from
;; STRUCT, if appropriate.
(lambda (item)
(goto-char item)
(let* ((new-ind (org-list-get-ind item struct))
(old-ind (org-current-text-indentation))
(new-bul (org-list-bullet-string
(org-list-get-bullet item struct)))
(old-bul (org-list-get-bullet item old-struct))
(new-box (org-list-get-checkbox item struct)))
(looking-at org-list-full-item-re)
;; a. Replace bullet
(unless (equal old-bul new-bul)
(let ((keep-space ""))
(save-excursion
;; If origin is inside the bullet, preserve the
;; spaces after origin.
(when (<= (match-beginning 1) origin (match-end 1))
(org-with-point-at origin
(save-match-data
(when (looking-at "[ \t]+")
(setq keep-space (match-string 0))))))
(replace-match "" nil nil nil 1)
(goto-char (match-end 1))
(insert-before-markers new-bul)
(insert keep-space))))
;; Refresh potentially shifted match markers.
(goto-char item)
(looking-at org-list-full-item-re)
;; b. Replace checkbox.
(cond
((equal (match-string 3) new-box))
((and (match-string 3) new-box)
(replace-match new-box nil nil nil 3))
((match-string 3)
(looking-at ".*?\\([ \t]*\\[[ X-]\\]\\)")
(replace-match "" nil nil nil 1))
(t (let ((counterp (match-end 2)))
(goto-char (if counterp (1+ counterp) (match-end 1)))
(insert (concat new-box (unless counterp " "))))))
;; c. Indent item to appropriate column.
(unless (= new-ind old-ind)
(delete-region (goto-char (line-beginning-position))
(progn (skip-chars-forward " \t") (point)))
(indent-to new-ind))))))
;; 1. First get list of items and position endings. We maintain
;; two alists: ITM-SHIFT, determining indentation shift needed
;; at item, and END-LIST, a pseudo-alist where key is ending
;; position and value point.
(let (end-list acc-end itm-shift all-ends sliced-struct)
(dolist (e old-struct)
(let* ((pos (car e))
(ind-pos (org-list-get-ind pos struct))
(ind-old (org-list-get-ind pos old-struct))
(bul-pos (org-list-get-bullet pos struct))
(bul-old (org-list-get-bullet pos old-struct))
(ind-shift (- (+ ind-pos (length bul-pos))
(+ ind-old (length bul-old))))
(end-pos (org-list-get-item-end pos old-struct)))
(push (cons pos ind-shift) itm-shift)
(unless (assq end-pos old-struct)
;; To determine real ind of an ending position that
;; is not at an item, we have to find the item it
;; belongs to: it is the last item (ITEM-UP), whose
;; ending is further than the position we're
;; interested in.
(let ((item-up (assoc-default end-pos acc-end #'>)))
(push (cons end-pos item-up) end-list)))
(push (cons end-pos pos) acc-end)))
;; 2. Slice the items into parts that should be shifted by the
;; same amount of indentation. Each slice follow the pattern
;; (END BEG DELTA). Slices are returned in reverse order.
(setq all-ends (sort (append (mapcar #'car itm-shift)
(org-uniquify (mapcar #'car end-list)))
#'<)
acc-end (nreverse acc-end))
(while (cdr all-ends)
(let* ((up (pop all-ends))
(down (car all-ends))
(itemp (assq up struct))
(delta
(if itemp (cdr (assq up itm-shift))
;; If we're not at an item, there's a child of the
;; item point belongs to above. Make sure the less
;; indented line in this slice has the same column
;; as that child.
(let* ((child (cdr (assq up acc-end)))
(ind (org-list-get-ind child struct))
(min-ind most-positive-fixnum))
(save-excursion
(goto-char up)
(while (< (point) down)
;; Ignore empty lines. Also ignore blocks and
;; drawers contents.
(unless (looking-at-p "[ \t]*$")
(setq min-ind (min (org-current-text-indentation) min-ind))
(cond
((and (looking-at "#\\+BEGIN\\(:\\|_\\S-+\\)")
(re-search-forward
(format "^[ \t]*#\\+END%s[ \t]*$"
(match-string 1))
down t)))
((and (looking-at org-drawer-regexp)
(re-search-forward "^[ \t]*:END:[ \t]*$"
down t)))))
(forward-line)))
(- ind min-ind)))))
(push (list down up delta) sliced-struct)))
;; 3. Shift each slice in buffer, provided delta isn't 0, from
;; end to beginning. Take a special action when beginning is
;; at item bullet.
(dolist (e sliced-struct)
(unless (zerop (nth 2 e)) (apply shift-body-ind e))
(let* ((beg (nth 1 e))
(cell (assq beg struct)))
(unless (or (not cell) (equal cell (assq beg old-struct)))
(funcall modify-item beg)))))
;; 4. Go back to initial position and clean marker.
(goto-char origin)
(move-marker origin nil)))
(defun org-list-write-struct (struct parents &optional old-struct)
"Correct bullets, checkboxes and indentation in list at point.
STRUCT is the list structure. PARENTS is the alist of parents,
as returned by `org-list-parents-alist'.
When non-nil, optional argument OLD-STRUCT is the reference
structure of the list. It should be provided whenever STRUCT
doesn't correspond anymore to the real list in buffer."
;; Order of functions matters here: checkboxes and endings need
;; correct indentation to be set, and indentation needs correct
;; bullets.
;;
;; 0. Save a copy of structure before modifications
(let ((old-struct (or old-struct (copy-tree struct))))
;; 1. Set a temporary, but coherent with PARENTS, indentation in
;; order to get items endings and bullets properly
(org-list-struct-fix-ind struct parents 2)
;; 2. Fix each item end to get correct prevs alist.
(org-list-struct-fix-item-end struct)
;; 3. Get bullets right.
(let ((prevs (org-list-prevs-alist struct)))
(org-list-struct-fix-bul struct prevs)
;; 4. Now get real indentation.
(org-list-struct-fix-ind struct parents)
;; 5. Eventually fix checkboxes.
(org-list-struct-fix-box struct parents prevs))
;; 6. Apply structure modifications to buffer.
(org-list-struct-apply-struct struct old-struct))
;; 7. Return the updated structure
struct)
;;; Misc Tools
(defun org-apply-on-list (function init-value &rest args)
"Call FUNCTION on each item of the list at point.
FUNCTION must be called with at least one argument: INIT-VALUE,
that will contain the value returned by the function at the
previous item, plus ARGS extra arguments.
FUNCTION is applied on items in reverse order.
As an example, \(org-apply-on-list \(lambda \(result) \(1+ result)) 0)
will return the number of items in the current list.
Sublists of the list are skipped. Cursor is always at the
beginning of the item."
(let* ((struct (org-list-struct))
(prevs (org-list-prevs-alist struct))
(item (copy-marker (line-beginning-position)))
(all (org-list-get-all-items (marker-position item) struct prevs))
(value init-value))
(dolist (e (nreverse all))
(goto-char e)
(setq value (apply function value args)))
(goto-char item)
(move-marker item nil)
value))
(defun org-list-set-item-visibility (item struct view)
"Set visibility of ITEM in STRUCT to VIEW.
Possible values are: `folded', `children' or `subtree'. See
`org-cycle' for more information."
(cond
((eq view 'folded)
(let ((item-end (org-list-get-item-end-before-blank item struct)))
;; Hide from eol
(org-fold-region (save-excursion (goto-char item) (line-end-position))
item-end t 'outline)))
((eq view 'children)
;; First show everything.
(org-list-set-item-visibility item struct 'subtree)
;; Then fold every child.
(let* ((parents (org-list-parents-alist struct))
(children (org-list-get-children item struct parents)))
(dolist (child children)
(org-list-set-item-visibility child struct 'folded))))
((eq view 'subtree)
;; Show everything
(let ((item-end (org-list-get-item-end item struct)))
(org-fold-region item item-end nil 'outline)))))
(defun org-list-item-body-column (item)
"Return column at which body of ITEM should start."
(save-excursion
(goto-char item)
(looking-at "[ \t]*\\(\\S-+\\)")
(+ (progn (goto-char (match-end 1)) (current-column))
(if (and org-list-two-spaces-after-bullet-regexp
(string-match-p org-list-two-spaces-after-bullet-regexp
(match-string 1)))
2
1))))
;;; Interactive functions
(defalias 'org-list-get-item-begin 'org-in-item-p)
(defun org-beginning-of-item ()
"Go to the beginning of the current item.
Throw an error when not in a list."
(interactive)
(let ((begin (org-in-item-p)))
(if begin (goto-char begin) (error "Not in an item"))))
(defun org-beginning-of-item-list ()
"Go to the beginning item of the current list or sublist.
Throw an error when not in a list."
(interactive)
(let ((begin (org-in-item-p)))
(if (not begin)
(error "Not in an item")
(goto-char begin)
(let* ((struct (org-list-struct))
(prevs (org-list-prevs-alist struct)))
(goto-char (org-list-get-list-begin begin struct prevs))))))
(defun org-end-of-item-list ()
"Go to the end of the current list or sublist.
Throw an error when not in a list."
(interactive)
(let ((begin (org-in-item-p)))
(if (not begin)
(error "Not in an item")
(goto-char begin)
(let* ((struct (org-list-struct))
(prevs (org-list-prevs-alist struct)))
(goto-char (org-list-get-list-end begin struct prevs))))))
(defun org-end-of-item ()
"Go to the end of the current item.
Throw an error when not in a list."
(interactive)
(let ((begin (org-in-item-p)))
(if (not begin)
(error "Not in an item")
(goto-char begin)
(let ((struct (org-list-struct)))
(goto-char (org-list-get-item-end begin struct))))))
(defun org-previous-item ()
"Move to the beginning of the previous item.
Throw an error when not in a list. Also throw an error when at
first item, unless `org-list-use-circular-motion' is non-nil."
(interactive)
(let ((item (org-in-item-p)))
(if (not item)
(error "Not in an item")
(goto-char item)
(let* ((struct (org-list-struct))
(prevs (org-list-prevs-alist struct))
(prevp (org-list-get-prev-item item struct prevs)))
(cond
(prevp (goto-char prevp))
(org-list-use-circular-motion
(goto-char (org-list-get-last-item item struct prevs)))
(t (error "On first item")))))))
(defun org-next-item ()
"Move to the beginning of the next item.
Throw an error when not in a list. Also throw an error when at
last item, unless `org-list-use-circular-motion' is non-nil."
(interactive)
(let ((item (org-in-item-p)))
(if (not item)
(error "Not in an item")
(goto-char item)
(let* ((struct (org-list-struct))
(prevs (org-list-prevs-alist struct))
(prevp (org-list-get-next-item item struct prevs)))
(cond
(prevp (goto-char prevp))
(org-list-use-circular-motion
(goto-char (org-list-get-first-item item struct prevs)))
(t (error "On last item")))))))
(defun org-move-item-down ()
"Move the item at point down, i.e. swap with following item.
Sub-items (items with larger indentation) are considered part of
the item, so this really moves item trees."
(interactive)
(unless (org-at-item-p) (error "Not at an item"))
(let* ((col (current-column))
(item (line-beginning-position))
(struct (org-list-struct))
(prevs (org-list-prevs-alist struct))
(next-item (org-list-get-next-item (line-beginning-position) struct prevs)))
(unless (or next-item org-list-use-circular-motion)
(user-error "Cannot move this item further down"))
(if (not next-item)
(setq struct (org-list-send-item item 'begin struct))
(setq struct (org-list-swap-items item next-item struct))
(goto-char
(org-list-get-next-item item struct (org-list-prevs-alist struct))))
(org-list-write-struct struct (org-list-parents-alist struct))
(org-move-to-column col)))
(defun org-move-item-up ()
"Move the item at point up, i.e. swap with previous item.
Sub-items (items with larger indentation) are considered part of
the item, so this really moves item trees."
(interactive)
(unless (org-at-item-p) (error "Not at an item"))
(let* ((col (current-column))
(item (line-beginning-position))
(struct (org-list-struct))
(prevs (org-list-prevs-alist struct))
(prev-item (org-list-get-prev-item (line-beginning-position) struct prevs)))
(unless (or prev-item org-list-use-circular-motion)
(user-error "Cannot move this item further up"))
(if (not prev-item)
(setq struct (org-list-send-item item 'end struct))
(setq struct (org-list-swap-items prev-item item struct)))
(org-list-write-struct struct (org-list-parents-alist struct))
(org-move-to-column col)))
(defun org-insert-item (&optional checkbox)
"Insert a new item at the current level.
If cursor is before first character after bullet of the item, the
new item will be created before the current one.
If CHECKBOX is non-nil, add a checkbox next to the bullet.
Return t when things worked, nil when we are not in an item, or
item is invisible."
(interactive "P")
(let ((itemp (org-in-item-p))
(pos (point)))
;; If cursor isn't is a list or if list is invisible, return nil.
(unless (or (not itemp)
(save-excursion
(goto-char itemp)
(org-invisible-p)))
(if (save-excursion
(goto-char itemp)
(org-at-item-timer-p))
;; Timer list: delegate to `org-timer-item'.
(progn (org-timer-item) t)
(let* ((struct (save-excursion (goto-char itemp)
(org-list-struct)))
(prevs (org-list-prevs-alist struct))
;; If we're in a description list, ask for the new term.
(desc (when (eq (org-list-get-list-type itemp struct prevs)
'descriptive)
" :: ")))
(setq struct (org-list-insert-item pos struct prevs checkbox desc))
(org-list-write-struct struct (org-list-parents-alist struct))
(when checkbox (org-update-checkbox-count-maybe))
(forward-line 0)
(looking-at org-list-full-item-re)
(goto-char (if (and (match-beginning 4)
(save-match-data
(string-match "[.)]" (match-string 1))))
(match-beginning 4)
(match-end 0)))
(when desc (backward-char 1))
t)))))
(defun org-list-repair ()
"Fix indentation, bullets and checkboxes in the list at point."
(interactive)
(unless (org-at-item-p) (error "This is not a list"))
(let* ((struct (org-list-struct))
(parents (org-list-parents-alist struct)))
(org-list-write-struct struct parents)))
(defun org-cycle-list-bullet (&optional which)
"Cycle through the different itemize/enumerate bullets.
This cycle the entire list level through the sequence:
`-' -> `+' -> `*' -> `1.' -> `1)'
If WHICH is a valid string, use that as the new bullet. If WHICH
is an integer, 0 means `-', 1 means `+' etc. If WHICH is
`previous', cycle backwards."
(interactive "P")
(unless (org-at-item-p) (error "Not at an item"))
(let ((origin (point-marker)))
(forward-line 0)
(let* ((struct (org-list-struct))
(parents (org-list-parents-alist struct))
(prevs (org-list-prevs-alist struct))
(list-beg (org-list-get-first-item (point) struct prevs))
;; Record relative point position to bullet beginning.
(origin-offset (- origin
(+ (point) (org-list-get-ind (point) struct))))
;; Record relative point position to bullet end.
(origin-offset2 (- origin
(+ (point) (org-list-get-ind (point) struct)
(length (org-list-get-bullet (point) struct)))))
(bullet (org-list-get-bullet list-beg struct))
(alpha-p (org-list-use-alpha-bul-p list-beg struct prevs))
(case-fold-search nil)
(current (cond
((string-match "[a-z]\\." bullet) "a.")
((string-match "[a-z])" bullet) "a)")
((string-match "[A-Z]\\." bullet) "A.")
((string-match "[A-Z])" bullet) "A)")
((string-match "\\." bullet) "1.")
((string-match ")" bullet) "1)")
(t (org-trim bullet))))
;; Compute list of possible bullets, depending on context.
(bullet-list
(append '("-" "+" )
;; *-bullets are not allowed at column 0.
(unless (looking-at "\\S-") '("*"))
;; Description items cannot be numbered.
(unless (or (eq org-plain-list-ordered-item-terminator ?\))
(org-at-item-description-p))
'("1."))
(unless (or (eq org-plain-list-ordered-item-terminator ?.)
(org-at-item-description-p))
'("1)"))
(unless (or (not alpha-p)
(eq org-plain-list-ordered-item-terminator ?\))
(org-at-item-description-p))
'("a." "A."))
(unless (or (not alpha-p)
(eq org-plain-list-ordered-item-terminator ?.)
(org-at-item-description-p))
'("a)" "A)"))))
(len (length bullet-list))
(item-index (- len (length (member current bullet-list))))
(get-value (lambda (index) (nth (mod index len) bullet-list)))
(new (cond
((member which bullet-list) which)
((numberp which) (funcall get-value which))
((eq 'previous which) (funcall get-value (1- item-index)))
(t (funcall get-value (1+ item-index))))))
;; Use a short variation of `org-list-write-struct' as there's
;; no need to go through all the steps.
(let ((old-struct (copy-tree struct)))
(org-list-set-bullet list-beg struct (org-list-bullet-string new))
(org-list-struct-fix-bul struct prevs)
(org-list-struct-fix-ind struct parents)
(org-list-struct-apply-struct struct old-struct))
(goto-char origin)
(setq struct (org-list-struct))
(cond
((>= origin-offset2 0)
(forward-line 0)
(move-marker origin (+ (point)
(org-list-get-ind (point) struct)
(length (org-list-get-bullet (point) struct))
origin-offset2))
(goto-char origin))
((>= origin-offset 0)
(forward-line 0)
(move-marker origin (+ (point)
(org-list-get-ind (point) struct)
origin-offset))
(goto-char origin)))
(move-marker origin nil))))
;;;###autoload
(define-minor-mode org-list-checkbox-radio-mode
"When turned on, use list checkboxes as radio buttons."
:lighter " CheckBoxRadio"
(unless (eq major-mode 'org-mode)
(user-error "Cannot turn this mode outside org-mode buffers")))
(defun org-toggle-radio-button (&optional arg)
"Toggle off all checkboxes and toggle on the one at point."
(interactive "P")
(if (not (org-at-item-p))
(user-error "Cannot toggle checkbox outside of a list")
(let* ((cpos (org-in-item-p))
(struct (org-list-struct))
(orderedp (org-entry-get nil "ORDERED"))
(parents (org-list-parents-alist struct))
(old-struct (copy-tree struct))
(cbox (org-list-get-checkbox cpos struct))
(prevs (org-list-prevs-alist struct))
(start (org-list-get-list-begin (line-beginning-position) struct prevs))
(new (unless (and cbox (equal arg '(4)) (equal start cpos))
"[ ]")))
(dolist (pos (org-list-get-all-items
start struct (org-list-prevs-alist struct)))
(org-list-set-checkbox pos struct new))
(when new
(org-list-set-checkbox
cpos struct
(cond ((equal arg '(4)) (unless cbox "[ ]"))
((equal arg '(16)) (unless cbox "[-]"))
(t (if (equal cbox "[X]") "[ ]" "[X]")))))
(org-list-struct-fix-box struct parents prevs orderedp)
(org-list-struct-apply-struct struct old-struct)
(org-update-checkbox-count-maybe))))
(defun org-at-radio-list-p ()
"Is point at a list item with radio buttons?"
(when (org-match-line (org-item-re)) ;short-circuit
(let* ((e (save-excursion (forward-line 0) (org-element-at-point))))
;; Check we're really on a line with a bullet.
(when (org-element-type-p e '(item plain-list))
;; Look for ATTR_ORG attribute in the current plain list.
(let ((plain-list (org-element-lineage e 'plain-list t)))
(org-with-point-at (org-element-post-affiliated plain-list)
(let ((case-fold-search t)
(regexp "^[ \t]*#\\+attr_org:.* :radio \\(\\S-+\\)")
(begin (org-element-begin plain-list)))
(and (re-search-backward regexp begin t)
(not (string-equal "nil" (match-string 1)))))))))))
(defun org-toggle-checkbox (&optional toggle-presence)
"Toggle the checkbox in the current line.
With prefix argument TOGGLE-PRESENCE, add or remove checkboxes.
With a double prefix argument, set the checkbox to \"[-]\".
When there is an active region, toggle status or presence of the
first checkbox there, and make every item inside have the same
status or presence, respectively.
If point is on a headline, apply this to all checkbox items in
the text below the heading, taking as reference the first item in
subtree, ignoring planning line and any drawer following it."
(interactive "P")
(if (org-at-radio-list-p)
(org-toggle-radio-button toggle-presence)
(save-excursion
(let* (singlep
block-item
lim-up
lim-down
(orderedp (org-entry-get nil "ORDERED"))
(_bounds
;; In a region, start at first item in region.
(cond
((org-region-active-p)
(let ((limit (region-end)))
(goto-char (region-beginning))
(if (org-list-search-forward (org-item-beginning-re) limit t)
(setq lim-up (line-beginning-position))
(error "No item in region"))
(setq lim-down (copy-marker limit))))
((org-at-heading-p)
;; On a heading, start at first item after drawers and
;; timestamps (scheduled, etc.).
(let ((limit (save-excursion (outline-next-heading) (point))))
(org-end-of-meta-data t)
(if (org-list-search-forward (org-item-beginning-re) limit t)
(setq lim-up (line-beginning-position))
(error "No item in subtree"))
(setq lim-down (copy-marker limit))))
;; Just one item: set SINGLEP flag.
((org-at-item-p)
(setq singlep t)
(setq lim-up (line-beginning-position)
lim-down (copy-marker (line-end-position))))
(t (error "Not at an item or heading, and no active region"))))
;; Determine the checkbox going to be applied to all items
;; within bounds.
(ref-checkbox
(progn
(goto-char lim-up)
(let ((cbox (and (org-at-item-checkbox-p) (match-string 1))))
(cond
((equal toggle-presence '(16)) "[-]")
((equal toggle-presence '(4))
(unless cbox "[ ]"))
((equal "[X]" cbox) "[ ]")
(t "[X]"))))))
;; When an item is found within bounds, grab the full list at
;; point structure, then: (1) set check-box of all its items
;; within bounds to REF-CHECKBOX, (2) fix check-boxes of the
;; whole list, (3) move point after the list.
(goto-char lim-up)
(while (and (< (point) lim-down)
(org-list-search-forward (org-item-beginning-re)
lim-down 'move))
(let* ((struct (org-list-struct))
(struct-copy (copy-tree struct))
(parents (org-list-parents-alist struct))
(prevs (org-list-prevs-alist struct))
(bottom (copy-marker (org-list-get-bottom-point struct)))
(items-to-toggle (cl-remove-if
(lambda (e) (or (< e lim-up) (> e lim-down)))
(mapcar #'car struct))))
(dolist (e items-to-toggle)
(org-list-set-checkbox
e struct
;; If there is no box at item, leave as-is unless
;; function was called with C-u prefix.
(let ((cur-box (org-list-get-checkbox e struct)))
(if (or cur-box (equal toggle-presence '(4)))
ref-checkbox
cur-box))))
(setq block-item (org-list-struct-fix-box
struct parents prevs orderedp))
;; Report some problems due to ORDERED status of subtree.
;; If only one box was being checked, throw an error, else,
;; only signal problems.
(cond
((and singlep block-item (> lim-up block-item))
(error
"Checkbox blocked because of unchecked box at line %d"
(org-current-line block-item)))
(block-item
(message
"Checkboxes were removed due to unchecked box at line %d"
(org-current-line block-item))))
(goto-char bottom)
(move-marker bottom nil)
(org-list-struct-apply-struct struct struct-copy)))
(move-marker lim-down nil))))
(org-update-checkbox-count-maybe))
(defun org-reset-checkbox-state-subtree ()
"Reset all checkboxes in an entry subtree."
(interactive "*")
(if (org-before-first-heading-p)
(error "Not inside a tree")
(save-restriction
(save-excursion
(org-narrow-to-subtree)
(org-fold-show-subtree)
(goto-char (point-min))
(let ((end (point-max)))
(while (< (point) end)
(when (org-at-item-checkbox-p)
(replace-match "[ ]" t t nil 1))
(forward-line 1)))
(org-update-checkbox-count-maybe 'narrow)))))
(defun org-update-checkbox-count (&optional all)
"Update the checkbox statistics in the current section.
This will find all statistic cookies like [57%] and [6/12] and
update them with the current numbers.
With optional prefix argument ALL, do this for the whole buffer.
When ALL is symbol `narrow', update statistics only in the accessible
portion of the buffer."
(interactive "P")
(save-excursion
(save-restriction
(unless (eq all 'narrow) (widen))
(let* ((cookie-re "\\(\\(\\[[0-9]*%\\]\\)\\|\\(\\[[0-9]*/[0-9]*\\]\\)\\)")
(box-re "^[ \t]*\\([-+*]\\|\\([0-9]+\\|[A-Za-z]\\)[.)]\\)[ \t]+\
\\(?:\\[@\\(?:start:\\)?\\([0-9]+\\|[A-Za-z]\\)\\][ \t]*\\)?\\(\\[[- X]\\]\\)")
(cookie-data (or (org-entry-get nil "COOKIE_DATA") ""))
(recursivep
(or (not org-checkbox-hierarchical-statistics)
(string-match-p "\\<recursive\\>" cookie-data)))
(within-inlinetask (and (not all)
(featurep 'org-inlinetask)
(org-inlinetask-in-task-p)))
(end (cond (all (point-max))
(within-inlinetask
(save-excursion (outline-next-heading) (point)))
(t (save-excursion
(org-with-limited-levels (outline-next-heading))
(point)))))
(count-boxes
(lambda (item structs recursivep)
;; Return number of checked boxes and boxes of all types
;; in all structures in STRUCTS. If RECURSIVEP is
;; non-nil, also count boxes in sub-lists. If ITEM is
;; nil, count across the whole structure, else count only
;; across subtree whose ancestor is ITEM.
(let ((c-on 0) (c-all 0))
(dolist (s structs (list c-on c-all))
(let* ((pre (org-list-prevs-alist s))
(par (org-list-parents-alist s))
(items
(cond
((and recursivep item) (org-list-get-subtree item s))
(recursivep (mapcar #'car s))
(item (org-list-get-children item s par))
(t (org-list-get-all-items
(org-list-get-top-point s) s pre))))
(cookies (delq nil (mapcar
(lambda (e)
(org-list-get-checkbox e s))
items))))
(cl-incf c-all (length cookies))
(cl-incf c-on (cl-count "[X]" cookies :test #'equal)))))))
cookies-list cache)
;; Move to start.
(cond (all (goto-char (point-min)))
(within-inlinetask (org-back-to-heading t))
(t (org-with-limited-levels (outline-previous-heading))))
;; Build an alist for each cookie found. The key is the position
;; at beginning of cookie and values ending position, format of
;; cookie, number of checked boxes to report and total number of
;; boxes.
(while (re-search-forward cookie-re end t)
(let ((context (save-excursion (backward-char)
(save-match-data (org-element-context)))))
(when (and (org-element-type-p context 'statistics-cookie)
(not (string-match-p "\\<todo\\>" cookie-data)))
(push
(append
(list (match-beginning 1) (match-end 1) (match-end 2))
(let* ((container
(org-element-lineage
context
'(drawer center-block dynamic-block inlinetask item
quote-block special-block verse-block)))
(beg (if container
(org-element-contents-begin container)
(save-excursion
(org-with-limited-levels
(outline-previous-heading))
(point)))))
(or (cdr (assq beg cache))
(save-excursion
(goto-char beg)
(let ((end
(if container
(org-element-contents-end container)
(save-excursion
(org-with-limited-levels (outline-next-heading))
(point))))
structs)
(while (re-search-forward box-re end t)
(let ((element (org-element-at-point)))
(when (org-element-type-p element 'item)
(push (org-element-property :structure element)
structs)
;; Skip whole list since we have its
;; structure anyway.
(while (setq element (org-element-lineage
element 'plain-list))
(goto-char
(min (org-element-end element)
end))))))
;; Cache count for cookies applying to the same
;; area. Then return it.
(let ((count
(funcall count-boxes
(and (org-element-type-p
container 'item)
(org-element-property
:begin container))
structs
recursivep)))
(push (cons beg count) cache)
count))))))
cookies-list))))
;; Apply alist to buffer.
(dolist (cookie cookies-list)
(let* ((beg (car cookie))
(end (nth 1 cookie))
(percent (nth 2 cookie))
(checked (nth 3 cookie))
(total (nth 4 cookie)))
(goto-char beg)
(org-fold-core-ignore-modifications
(insert-and-inherit
(if percent (format "[%d%%]" (floor (* 100.0 checked)
(max 1 total)))
(format "[%d/%d]" checked total)))
(delete-region (point) (+ (point) (- end beg))))
(when org-auto-align-tags (org-fix-tags-on-the-fly))))))))
(defun org-get-checkbox-statistics-face ()
"Select the face for checkbox statistics.
The face will be `org-done' when all relevant boxes are checked.
Otherwise it will be `org-todo'."
(if (match-end 1)
(if (equal (match-string 1) "100%")
'org-checkbox-statistics-done
'org-checkbox-statistics-todo)
(if (and (> (match-end 2) (match-beginning 2))
(equal (match-string 2) (match-string 3)))
'org-checkbox-statistics-done
'org-checkbox-statistics-todo)))
(defun org-update-checkbox-count-maybe (&optional all)
"Update checkbox statistics unless turned off by user.
With an optional argument ALL, update them in the whole buffer.
When ALL is symbol `narrow', update statistics only in the accessible
portion of the buffer."
(when (cdr (assq 'checkbox org-list-automatic-rules))
(org-update-checkbox-count all))
(run-hooks 'org-checkbox-statistics-hook))
(defvar org-last-indent-begin-marker (make-marker))
(defvar org-last-indent-end-marker (make-marker))
(defun org-list-indent-item-generic (arg no-subtree struct)
"Indent a local list item including its children.
When number ARG is a negative, item will be outdented, otherwise
it will be indented.
If a region is active, all items inside will be moved.
If NO-SUBTREE is non-nil, only indent the item itself, not its
children.
STRUCT is the list structure.
Return t if successful."
(save-excursion
(let* ((regionp (org-region-active-p))
(rbeg (and regionp (region-beginning)))
(rend (and regionp (region-end)))
(top (org-list-get-top-point struct))
(parents (org-list-parents-alist struct))
(prevs (org-list-prevs-alist struct))
;; Are we going to move the whole list?
(specialp
(and (not regionp)
(= top (line-beginning-position))
(cdr (assq 'indent org-list-automatic-rules))
(if no-subtree
(user-error
"At first item: use S-M-<left/right> to move the whole list")
t))))
;; Determine begin and end points of zone to indent. If moving
;; more than one item, save them for subsequent moves.
(unless (and (memq last-command '(org-shiftmetaright org-shiftmetaleft))
(memq this-command '(org-shiftmetaright org-shiftmetaleft)))
(if regionp
(progn
(set-marker org-last-indent-begin-marker rbeg)
(set-marker org-last-indent-end-marker rend))
(set-marker org-last-indent-begin-marker (line-beginning-position))
(set-marker org-last-indent-end-marker
(cond
(specialp (org-list-get-bottom-point struct))
(no-subtree (1+ (line-beginning-position)))
(t (org-list-get-item-end (line-beginning-position) struct))))))
(let* ((beg (marker-position org-last-indent-begin-marker))
(end (marker-position org-last-indent-end-marker))
(deactivate-mark nil))
(cond
;; Special case: moving top-item with indent rule.
(specialp
(let* ((level-skip (org-level-increment))
(offset (if (< arg 0) (- level-skip) level-skip))
(top-ind (org-list-get-ind beg struct))
(old-struct (copy-tree struct)))
(if (< (+ top-ind offset) 0)
(error "Cannot outdent beyond margin")
;; Change bullet if necessary.
(when (and (= (+ top-ind offset) 0)
(string-match "\\*"
(org-list-get-bullet beg struct)))
(org-list-set-bullet beg struct
(org-list-bullet-string "-")))
;; Shift every item by OFFSET and fix bullets. Then
;; apply changes to buffer.
(pcase-dolist (`(,pos . ,_) struct)
(let ((ind (org-list-get-ind pos struct)))
(org-list-set-ind pos struct (+ ind offset))))
(org-list-struct-fix-bul struct prevs)
(org-list-struct-apply-struct struct old-struct))))
;; Forbidden move:
((and (< arg 0)
;; If only one item is moved, it mustn't have a child.
(or (and no-subtree
(not regionp)
(org-list-has-child-p beg struct))
;; If a subtree or region is moved, the last item
;; of the subtree mustn't have a child.
(let ((last-item (caar
(reverse
(cl-remove-if
(lambda (e) (>= (car e) end))
struct)))))
(org-list-has-child-p last-item struct))))
(error "Cannot outdent an item without its children"))
;; Normal shifting
(t
(let* ((old-struct (copy-tree struct))
(new-parents
(if (< arg 0)
(org-list-struct-outdent beg end struct parents)
(org-list-struct-indent beg end struct parents prevs))))
(org-list-write-struct struct new-parents old-struct))
(org-update-checkbox-count-maybe))))))
t)
(defun org-outdent-item ()
"Outdent a local list item, but not its children.
If a region is active, all items inside will be moved."
(interactive)
(let ((regionp (org-region-active-p)))
(cond
((or (org-at-item-p)
(and regionp
(save-excursion (goto-char (region-beginning))
(org-at-item-p))))
(let ((struct (if (not regionp) (org-list-struct)
(save-excursion (goto-char (region-beginning))
(org-list-struct)))))
(org-list-indent-item-generic -1 t struct)))
(regionp (error "Region not starting at an item"))
(t (error "Not at an item")))))
(defun org-indent-item ()
"Indent a local list item, but not its children.
If a region is active, all items inside will be moved."
(interactive)
(let ((regionp (org-region-active-p)))
(cond
((or (org-at-item-p)
(and regionp
(save-excursion (goto-char (region-beginning))
(org-at-item-p))))
(let ((struct (if (not regionp) (org-list-struct)
(save-excursion (goto-char (region-beginning))
(org-list-struct)))))
(org-list-indent-item-generic 1 t struct)))
(regionp (error "Region not starting at an item"))
(t (error "Not at an item")))))
(defun org-outdent-item-tree ()
"Outdent a local list item including its children.
If a region is active, all items inside will be moved."
(interactive)
(let ((regionp (org-region-active-p)))
(cond
((or (org-at-item-p)
(and regionp
(save-excursion (goto-char (region-beginning))
(org-at-item-p))))
(let ((struct (if (not regionp) (org-list-struct)
(save-excursion (goto-char (region-beginning))
(org-list-struct)))))
(org-list-indent-item-generic -1 nil struct)))
(regionp (error "Region not starting at an item"))
(t (error "Not at an item")))))
(defun org-indent-item-tree ()
"Indent a local list item including its children.
If a region is active, all items inside will be moved."
(interactive)
(let ((regionp (org-region-active-p)))
(cond
((or (org-at-item-p)
(and regionp
(save-excursion (goto-char (region-beginning))
(org-at-item-p))))
(let ((struct (if (not regionp) (org-list-struct)
(save-excursion (goto-char (region-beginning))
(org-list-struct)))))
(org-list-indent-item-generic 1 nil struct)))
(regionp (error "Region not starting at an item"))
(t (error "Not at an item")))))
(defvar org-tab-ind-state)
(defun org-cycle-item-indentation ()
"Cycle levels of indentation of an empty item.
The first run indents the item, if applicable. Subsequent runs
outdent it at meaningful levels in the list. When done, item is
put back at its original position with its original bullet.
Return t at each successful move."
(when (org-at-item-p)
(let* ((struct (org-list-struct))
(item (line-beginning-position))
(ind (org-list-get-ind item struct)))
;; Accept empty items or if cycle has already started.
(when (or (eq last-command 'org-cycle-item-indentation)
(and (org-match-line org-list-full-item-re)
(>= (match-end 0)
(save-excursion
(goto-char (org-list-get-item-end item struct))
(skip-chars-backward " \t\n")
(point)))))
(setq this-command 'org-cycle-item-indentation)
(let ((prevs (org-list-prevs-alist struct))
(parents (org-list-parents-alist struct)))
(if (eq last-command 'org-cycle-item-indentation)
;; When in the middle of the cycle, try to outdent. If
;; it fails, move point back to its initial position and
;; reset cycle.
(pcase-let ((`(,old-ind . ,old-bul) org-tab-ind-state)
(allow-outdent
(lambda (struct prevs parents)
;; Non-nil if current item can be
;; outdented.
(and (not (org-list-get-next-item item nil prevs))
(not (org-list-has-child-p item struct))
(org-list-get-parent item struct parents)))))
(cond
((and (> ind old-ind)
(org-list-get-prev-item item nil prevs))
(org-list-indent-item-generic 1 t struct))
((and (< ind old-ind)
(funcall allow-outdent struct prevs parents))
(org-list-indent-item-generic -1 t struct))
(t
(delete-region (line-beginning-position) (line-end-position))
(indent-to-column old-ind)
(insert old-bul " ")
(let* ((struct (org-list-struct))
(parents (org-list-parents-alist struct)))
(if (and (> ind old-ind)
;; We were previously indenting item. It
;; is no longer possible. Try to outdent
;; from initial position.
(funcall allow-outdent
struct
(org-list-prevs-alist struct)
parents))
(org-list-indent-item-generic -1 t struct)
(org-list-write-struct struct parents)
;; Start cycle over.
(setq this-command 'identity)
t)))))
;; If a cycle is starting, remember initial indentation
;; and bullet, then try to indent. If it fails, try to
;; outdent.
(setq org-tab-ind-state
(cons ind (org-trim (org-current-line-string))))
(cond
((org-list-get-prev-item item nil prevs)
(org-list-indent-item-generic 1 t struct))
((and (not (org-list-get-next-item item nil prevs))
(org-list-get-parent item struct parents))
(org-list-indent-item-generic -1 t struct))
(t
;; This command failed. So will the following one.
;; There's no point in starting the cycle.
(setq this-command 'identity)
(user-error "Cannot move item")))))))))
(defun org-sort-list
(&optional with-case sorting-type getkey-func compare-func interactive?)
"Sort list items.
The cursor may be at any item of the list that should be sorted.
Sublists are not sorted. Checkboxes, if any, are ignored.
Sorting can be alphabetically, numerically, by date/time as given
by a time stamp, by a property or by priority.
Comparing entries ignores case by default. However, with an
optional argument WITH-CASE, the sorting considers case as well,
if the current locale allows for it.
The command prompts for the sorting type unless it has been given
to the function through the SORTING-TYPE argument, which needs to
be a character, among ?n ?N ?a ?A ?t ?T ?f ?F ?x or ?X. Here is
the detailed meaning of each character:
n Numerically, by converting the beginning of the item to a number.
a Alphabetically. Only the first line of item is checked.
t By date/time, either the first active time stamp in the entry, if
any, or by the first inactive one. In a timer list, sort the timers.
x By \"checked\" status of a check list.
Capital letters will reverse the sort order.
If the SORTING-TYPE is ?f or ?F, then GETKEY-FUNC specifies
a function to be called with point at the beginning of the
record. It must return a value that is compatible with COMPARE-FUNC,
the function used to compare entries.
Sorting is done against the visible part of the headlines, it
ignores hidden links.
A non-nil value for INTERACTIVE? is used to signal that this
function is being called interactively."
(interactive (list current-prefix-arg nil nil nil t))
(let* ((case-func (if with-case 'identity 'downcase))
(struct (org-list-struct))
(prevs (org-list-prevs-alist struct))
(start (org-list-get-list-begin (line-beginning-position) struct prevs))
(end (org-list-get-list-end (line-beginning-position) struct prevs))
(sorting-type
(or sorting-type
(progn
(message
"Sort plain list: [a]lpha [n]umeric [t]ime [f]unc [x]checked A/N/T/F/X means reversed:")
(read-char-exclusive))))
(dcst (downcase sorting-type))
(getkey-func
(and (= dcst ?f)
(or getkey-func
(and interactive?
(org-read-function "Function for extracting keys: "))
(error "Missing key extractor"))))
(sort-func
(cond
((= dcst ?a) #'org-string<)
((= dcst ?f)
(or compare-func
(and interactive?
(org-read-function
(concat "Function for comparing keys "
"(empty for default `sort-subr' predicate): ")
'allow-empty))))
((= dcst ?t) #'<)
((= dcst ?x) #'string<))))
(message "Sorting items...")
(save-restriction
(narrow-to-region start end)
(goto-char (point-min))
(let* ((case-fold-search nil)
(now (current-time))
(next-record (lambda ()
(skip-chars-forward " \r\t\n")
(or (eobp) (forward-line 0))))
(end-record (lambda ()
(goto-char (org-list-get-item-end-before-blank
(point) struct))))
(value-to-sort
(lambda ()
(when (looking-at "[ \t]*[-+*0-9.)]+\\([ \t]+\\[[- X]\\]\\)?[ \t]+")
(cond
((= dcst ?n)
(string-to-number
(org-sort-remove-invisible
(buffer-substring (match-end 0) (line-end-position)))))
((= dcst ?a)
(funcall case-func
(org-sort-remove-invisible
(buffer-substring
(match-end 0) (line-end-position)))))
((= dcst ?t)
(cond
;; If it is a timer list, convert timer to seconds
((org-at-item-timer-p)
(org-timer-hms-to-secs (match-string 1)))
((or (save-excursion
(re-search-forward org-ts-regexp (line-end-position) t))
(save-excursion (re-search-forward org-ts-regexp-both
(line-end-position) t)))
(org-time-string-to-seconds (match-string 0)))
(t (float-time now))))
((= dcst ?x) (or (and (stringp (match-string 1))
(match-string 1))
""))
((= dcst ?f)
(if getkey-func
(let ((value (funcall getkey-func)))
(if (stringp value)
(funcall case-func value)
value))
(error "Invalid key function `%s'" getkey-func)))
(t (error "Invalid sorting type `%c'" sorting-type)))))))
(sort-subr (/= dcst sorting-type)
next-record
end-record
value-to-sort
nil
sort-func)
;; Read and fix list again, as `sort-subr' probably destroyed
;; its structure.
(org-list-repair)
(run-hooks 'org-after-sorting-entries-or-items-hook)
(message "Sorting items...done")))))
(defun org-toggle-item (arg)
"Convert headings or normal lines to items, items to normal lines.
If there is no active region, only the current line is considered.
If the first non blank line in the region is a headline, convert
all headlines to items, shifting text accordingly.
If it is an item, convert all items to normal lines.
If it is normal text, change region into a list of items.
With a prefix argument ARG, change the region in a single item."
(interactive "P")
(let ((extract-footnote-definitions
(lambda (end)
;; Remove footnote definitions from point to END.
;; Return the list of the extracted definitions.
(let (definitions element)
(save-excursion
(while (re-search-forward org-footnote-definition-re end t)
(setq element (org-element-at-point))
(when (org-element-type-p element 'footnote-definition)
(push (buffer-substring-no-properties
(org-element-begin element)
(org-element-end element))
definitions)
;; Ensure at least 2 blank lines after the last
;; footnote definition, thus not slurping the
;; following element.
(unless (<= 2 (org-element-post-blank
(org-element-at-point)))
(setf (car definitions)
(concat (car definitions)
(make-string
(- 2 (org-element-post-blank
(org-element-at-point)))
?\n))))
(delete-region
(org-element-begin element)
(org-element-end element))))
definitions))))
(shift-text
(lambda (ind end)
;; Shift text in current section to IND, from point to END.
;; The function leaves point to END line.
(let ((min-i 1000) (end (copy-marker end)))
;; First determine the minimum indentation (MIN-I) of
;; the text.
(save-excursion
(catch 'exit
(while (< (point) end)
(let ((i (org-current-text-indentation)))
(cond
;; Skip blank lines and inline tasks.
((looking-at "^[ \t]*$"))
((looking-at org-outline-regexp-bol))
;; We can't find less than 0 indentation.
((zerop i) (throw 'exit (setq min-i 0)))
((< i min-i) (setq min-i i))))
(forward-line))))
;; Then indent each line so that a line indented to
;; MIN-I becomes indented to IND. Ignore blank lines
;; and inline tasks in the process.
(let ((delta (- ind min-i)))
(while (< (point) end)
(unless (or (looking-at "^[ \t]*$")
(looking-at org-outline-regexp-bol))
(indent-line-to (+ (org-current-text-indentation) delta)))
(forward-line))))))
(skip-blanks
(lambda (pos)
;; Return beginning of first non-blank line, starting from
;; line at POS.
(save-excursion
(goto-char pos)
(skip-chars-forward " \r\t\n")
(line-beginning-position))))
beg end)
;; Determine boundaries of changes.
(if (org-region-active-p)
(setq beg (funcall skip-blanks (region-beginning))
end (copy-marker (region-end)))
(setq beg (line-beginning-position)
end (copy-marker (line-end-position))))
;; Depending on the starting line, choose an action on the text
;; between BEG and END.
(org-with-limited-levels
(save-excursion
(goto-char beg)
(cond
;; Case 1. Start at an item: de-itemize. Note that it only
;; happens when a region is active: `org-ctrl-c-minus'
;; would call `org-cycle-list-bullet' otherwise.
((org-at-item-p)
(while (< (point) end)
(when (org-at-item-p)
(skip-chars-forward " \t")
(delete-region (point) (match-end 0)))
(forward-line)))
;; Case 2. Start at a heading: convert to items.
((org-at-heading-p)
;; Remove metadata
(let (org-loop-over-headlines-in-active-region)
(org-list--delete-metadata))
(let* ((bul (org-list-bullet-string "-"))
(bul-len (length bul))
;; Indentation of the first heading. It should be
;; relative to the indentation of its parent, if any.
(start-ind (save-excursion
(cond
((not org-adapt-indentation) 0)
((not (outline-previous-heading)) 0)
(t (length (match-string 0))))))
;; Level of first heading. Further headings will be
;; compared to it to determine hierarchy in the list.
(ref-level (org-reduced-level (org-outline-level)))
(footnote-definitions
(funcall extract-footnote-definitions end)))
(while (< (point) end)
(let* ((level (org-reduced-level (org-outline-level)))
(delta (max 0 (- level ref-level)))
(todo-state (org-get-todo-state)))
;; If current headline is less indented than the first
;; one, set it as reference, in order to preserve
;; subtrees.
(when (< level ref-level) (setq ref-level level))
;; Remove metadata
(let (org-loop-over-headlines-in-active-region)
(org-list--delete-metadata))
;; Remove stars and TODO keyword.
(let ((case-fold-search nil)) (looking-at org-todo-line-regexp))
(delete-region (point) (or (match-beginning 3)
(line-end-position)))
(insert bul)
(indent-line-to (+ start-ind (* delta bul-len)))
;; Turn TODO keyword into a check box.
(when todo-state
(let* ((struct (org-list-struct))
(old (copy-tree struct)))
(org-list-set-checkbox
(line-beginning-position)
struct
(if (member todo-state org-done-keywords)
"[X]"
"[ ]"))
(org-list-write-struct struct
(org-list-parents-alist struct)
old)))
;; Ensure all text down to END (or SECTION-END) belongs
;; to the newly created item.
(let ((section-end (save-excursion
(or (outline-next-heading) (point)))))
(forward-line)
(funcall shift-text
(+ start-ind (* (1+ delta) bul-len))
(min end section-end)))))
(when footnote-definitions
(goto-char end)
;; Insert footnote definitions after the list.
(unless (bolp) (forward-line 1))
;; At (point-max).
(unless (bolp) (insert "\n"))
(dolist (def footnote-definitions)
(insert def)))))
;; Case 3. Normal line with ARG: make the first line of region
;; an item, and shift indentation of others lines to
;; set them as item's body.
(arg (let* ((bul (org-list-bullet-string "-"))
(bul-len (length bul))
(ref-ind (org-current-text-indentation))
(footnote-definitions
(funcall extract-footnote-definitions end)))
(skip-chars-forward " \t")
(insert bul)
(forward-line)
(while (< (point) end)
;; Ensure that lines less indented than first one
;; still get included in item body.
(funcall shift-text
(+ ref-ind bul-len)
(min end (save-excursion (or (outline-next-heading)
(point)))))
(forward-line))
(when footnote-definitions
;; If the new list is followed by same-level items,
;; move past them as well.
(goto-char (org-element-end
(org-element-lineage
(org-element-at-point (1- end))
'plain-list t)))
;; Insert footnote definitions after the list.
(unless (bolp) (forward-line 1))
;; At (point-max).
(unless (bolp) (insert "\n"))
(dolist (def footnote-definitions)
(insert def)))))
;; Case 4. Normal line without ARG: turn each non-item line
;; into an item.
(t
(while (< (point) end)
(unless (or (org-at-heading-p) (org-at-item-p))
(when (looking-at "\\([ \t]*\\)\\(\\S-\\)")
(replace-match
(concat "\\1" (org-list-bullet-string "-") "\\2"))))
(forward-line))))))))
;;; Send and receive lists
(defun org-list-to-lisp (&optional delete)
"Parse the list at point and maybe DELETE it.
Return a list whose car is a symbol of list type, among
`ordered', `unordered' and `descriptive'. Then, each item is
a list of strings and other sub-lists.
For example, the following list:
1. first item
+ sub-item one
+ [X] sub-item two
more text in first item
2. [@3] last item
is parsed as
(ordered
(\"first item\"
(unordered
(\"sub-item one\")
(\"[X] sub-item two\"))
\"more text in first item\")
(\"[@3] last item\"))
Point is left at list's end."
(letrec ((struct (org-list-struct))
(prevs (org-list-prevs-alist struct))
(parents (org-list-parents-alist struct))
(top (org-list-get-top-point struct))
(bottom (org-list-get-bottom-point struct))
(trim
(lambda (text)
;; Remove indentation and final newline from TEXT.
(org-remove-indentation
(if (string-match-p "\n\\'" text)
(substring text 0 -1)
text))))
(parse-sublist
(lambda (e)
;; Return a list whose car is list type and cdr a list
;; of items' body.
(cons (org-list-get-list-type (car e) struct prevs)
(mapcar parse-item e))))
(parse-item
(lambda (e)
;; Return a list containing counter of item, if any,
;; text and any sublist inside it.
(let* ((end (org-list-get-item-end e struct))
(children (org-list-get-children e struct parents))
(body
(save-excursion
(goto-char e)
(looking-at "[ \t]*\\S-+[ \t]*")
(list
(funcall
trim
(concat
(make-string (string-width (match-string 0)) ?\s)
(buffer-substring-no-properties
(match-end 0) (or (car children) end))))))))
(while children
(let* ((child (car children))
(sub (org-list-get-all-items child struct prevs))
(last-in-sub (car (last sub))))
(push (funcall parse-sublist sub) body)
;; Remove whole sub-list from children.
(setq children (cdr (memq last-in-sub children)))
;; There is a chunk of text belonging to the item
;; if last child doesn't end where next child
;; starts or where item ends.
(let ((sub-end (org-list-get-item-end last-in-sub struct))
(next (or (car children) end)))
(when (/= sub-end next)
(push (funcall
trim
(buffer-substring-no-properties sub-end next))
body)))))
(nreverse body)))))
;; Store output, take care of cursor position and deletion of
;; list, then return output.
(prog1 (funcall parse-sublist (org-list-get-all-items top struct prevs))
(goto-char top)
(when delete
(delete-region top bottom)
(when (and (not (looking-at "[ \t]*$")) (looking-at org-list-end-re))
(replace-match ""))))))
(defun org-list-make-subtree ()
"Convert the plain list at point into a subtree."
(interactive)
(let ((item (org-in-item-p)))
(unless item (error "Not in a list"))
(goto-char item)
(let ((level (pcase (org-current-level)
(`nil 1)
(l (1+ (org-reduced-level l)))))
(list (save-excursion (org-list-to-lisp t))))
(insert (org-list-to-subtree list level) "\n"))))
(defun org-list-to-generic (list params)
"Convert a LIST parsed through `org-list-to-lisp' to a custom format.
LIST is a list as returned by `org-list-to-lisp', which see.
PARAMS is a property list of parameters used to tweak the output
format.
Valid parameters are:
:backend, :raw
Export backend used as a basis to transcode elements of the
list, when no specific parameter applies to it. It is also
used to translate its contents. You can prevent this by
setting :raw property to a non-nil value.
:splice
When non-nil, only export the contents of the top most plain
list, effectively ignoring its opening and closing lines.
:ustart, :uend
Strings to start and end an unordered list. They can also be
set to a function returning a string or nil, which will be
called with the depth of the list, counting from 1.
:ostart, :oend
Strings to start and end an ordered list. They can also be set
to a function returning a string or nil, which will be called
with the depth of the list, counting from 1.
:dstart, :dend
Strings to start and end a descriptive list. They can also be
set to a function returning a string or nil, which will be
called with the depth of the list, counting from 1.
:dtstart, :dtend, :ddstart, :ddend
Strings to start and end a descriptive term.
:istart, :iend
Strings to start or end a list item, and to start a list item
with a counter. They can also be set to a function returning
a string or nil, which will be called with two arguments: the
type of list and the depth of the item, counting from 1.
:icount
Strings to start a list item with a counter. It can also be
set to a function returning a string or nil, which will be
called with three arguments: the type of list, the depth of the
item, counting from 1, and the counter. Its value, when
non-nil, has precedence over `:istart'.
:isep
String used to separate items. It can also be set to
a function returning a string or nil, which will be called with
two arguments: the type of list and the depth of the item,
counting from 1. It always start on a new line.
:ifmt
Function to be applied to the contents of every item. It is
called with two arguments: the type of list and the contents.
:cbon, :cboff, :cbtrans
String to insert, respectively, an un-checked check-box,
a checked check-box and a check-box in transitional state."
(require 'ox)
(let* ((backend (plist-get params :backend))
(custom-backend
(org-export-create-backend
:parent (or backend 'org)
:transcoders
`((plain-list . ,(org-list--to-generic-plain-list params))
(item . ,(org-list--to-generic-item params))
(macro . (lambda (m c i) (org-element-macro-interpreter m nil))))))
data info)
;; Write LIST back into Org syntax and parse it.
(with-temp-buffer
(let ((org-inhibit-startup t)) (org-mode))
(letrec ((insert-list
(lambda (l)
(dolist (i (cdr l))
(funcall insert-item i (car l)))))
(insert-item
(lambda (i type)
(let ((start (point)))
(insert (if (eq type 'ordered) "1. " "- "))
(dolist (e i)
(if (consp e) (funcall insert-list e)
(insert e)
(insert "\n")))
(forward-line 0)
(save-excursion
(let ((ind (if (eq type 'ordered) 3 2)))
(while (> (point) start)
(unless (looking-at-p "[ \t]*$")
(indent-to ind))
(forward-line -1))))))))
(funcall insert-list list))
(setf data
(org-element-map (org-element-parse-buffer) 'plain-list
#'identity nil t))
(setf info (org-export-get-environment backend nil params)))
(when (and backend (symbolp backend) (not (org-export-get-backend backend)))
(user-error "Unknown :backend value"))
(unless backend (require 'ox-org))
;; When ':raw' property has a non-nil value, turn all objects back
;; into Org syntax.
(when (and backend (plist-get params :raw))
(org-element-map data org-element-all-objects
(lambda (object)
(org-element-set
object (org-element-interpret-data object)))))
;; We use a low-level mechanism to export DATA so as to skip all
;; usual pre-processing and post-processing, i.e., hooks, filters,
;; Babel code evaluation, include keywords and macro expansion,
;; and filters.
(let ((output (org-export-data-with-backend data custom-backend info)))
;; Remove final newline.
(if (org-string-nw-p output) (substring-no-properties output 0 -1) ""))))
(defun org-list--depth (element)
"Return the level of ELEMENT within current plain list.
ELEMENT is either an item or a plain list."
(cl-count-if (lambda (ancestor) (org-element-type-p ancestor 'plain-list))
(org-element-lineage element nil t)))
(defun org-list--trailing-newlines (string)
"Return the number of trailing newlines in STRING."
(with-temp-buffer
(insert string)
(skip-chars-backward " \t\n")
(count-lines (line-beginning-position 2) (point-max))))
(defun org-list--generic-eval (value &rest args)
"Evaluate VALUE according to its type.
VALUE is either nil, a string or a function. In the latter case,
it is called with arguments ARGS."
(cond ((null value) nil)
((stringp value) value)
((functionp value) (apply value args))
(t (error "Wrong value: %s" value))))
(defun org-list--to-generic-plain-list (params)
"Return a transcoder for `plain-list' elements.
PARAMS is a plist used to tweak the behavior of the transcoder."
(let ((ustart (plist-get params :ustart))
(uend (plist-get params :uend))
(ostart (plist-get params :ostart))
(oend (plist-get params :oend))
(dstart (plist-get params :dstart))
(dend (plist-get params :dend))
(splice (plist-get params :splice))
(backend (plist-get params :backend)))
(lambda (plain-list contents info)
(let* ((type (org-element-property :type plain-list))
(depth (org-list--depth plain-list))
(start (and (not splice)
(org-list--generic-eval
(pcase type
(`ordered ostart)
(`unordered ustart)
(_ dstart))
depth)))
(end (and (not splice)
(org-list--generic-eval
(pcase type
(`ordered oend)
(`unordered uend)
(_ dend))
depth))))
;; Make sure trailing newlines in END appear in the output by
;; setting `:post-blank' property to their number.
(when end
(org-element-put-property
plain-list :post-blank (org-list--trailing-newlines end)))
;; Build output.
(concat (and start (concat start "\n"))
(if (or start end splice (not backend))
contents
(org-export-with-backend backend plain-list contents info))
end)))))
(defun org-list--to-generic-item (params)
"Return a transcoder for `item' elements.
PARAMS is a plist used to tweak the behavior of the transcoder."
(let ((backend (plist-get params :backend))
(istart (plist-get params :istart))
(iend (plist-get params :iend))
(isep (plist-get params :isep))
(icount (plist-get params :icount))
(ifmt (plist-get params :ifmt))
(cboff (plist-get params :cboff))
(cbon (plist-get params :cbon))
(cbtrans (plist-get params :cbtrans))
(dtstart (plist-get params :dtstart))
(dtend (plist-get params :dtend))
(ddstart (plist-get params :ddstart))
(ddend (plist-get params :ddend)))
(lambda (item contents info)
(let* ((type
(org-element-property :type (org-element-parent item)))
(tag (org-element-property :tag item))
(depth (org-list--depth item))
(separator (and (org-export-get-next-element item info)
(org-list--generic-eval isep type depth)))
(closing (pcase (org-list--generic-eval iend type depth)
((or `nil "") "\n")
((and (guard separator) s)
(if (equal (substring s -1) "\n") s (concat s "\n")))
(s s))))
;; When a closing line or a separator is provided, make sure
;; its trailing newlines are taken into account when building
;; output. This is done by setting `:post-blank' property to
;; the number of such lines in the last line to be added.
(let ((last-string (or separator closing)))
(when last-string
(org-element-put-property
item
:post-blank
(max (1- (org-list--trailing-newlines last-string)) 0))))
;; Build output.
(concat
(let ((c (org-element-property :counter item)))
(if (and c icount) (org-list--generic-eval icount type depth c)
(org-list--generic-eval istart type depth)))
(let ((body
(if (or istart iend icount ifmt cbon cboff cbtrans (not backend)
(and (eq type 'descriptive)
(or dtstart dtend ddstart ddend)))
(concat
(pcase (org-element-property :checkbox item)
(`on cbon)
(`off cboff)
(`trans cbtrans))
(and tag
(concat dtstart
(if backend
(org-export-data-with-backend
tag backend info)
(org-element-interpret-data tag))
dtend))
(and tag ddstart)
(let ((contents
(if (= (length contents) 0) ""
(substring contents 0 -1))))
(if ifmt (org-list--generic-eval ifmt type contents)
contents))
(and tag ddend))
(org-export-with-backend backend item contents info))))
;; Remove final newline.
(if (equal body "") ""
(substring (org-element-normalize-string body) 0 -1)))
closing
separator)))))
(defun org-list-to-latex (list &optional params)
"Convert LIST into a LaTeX list.
LIST is a parsed plain list, as returned by `org-list-to-lisp'.
PARAMS is a property list with overruling parameters for
`org-list-to-generic'. Return converted list as a string."
(require 'ox-latex)
(org-list-to-generic list (org-combine-plists '(:backend latex) params)))
(defun org-list-to-html (list &optional params)
"Convert LIST into a HTML list.
LIST is a parsed plain list, as returned by `org-list-to-lisp'.
PARAMS is a property list with overruling parameters for
`org-list-to-generic'. Return converted list as a string."
(require 'ox-html)
(org-list-to-generic list (org-combine-plists '(:backend html) params)))
(defun org-list-to-texinfo (list &optional params)
"Convert LIST into a Texinfo list.
LIST is a parsed plain list, as returned by `org-list-to-lisp'.
PARAMS is a property list with overruling parameters for
`org-list-to-generic'. Return converted list as a string."
(require 'ox-texinfo)
(org-list-to-generic list (org-combine-plists '(:backend texinfo) params)))
(defun org-list-to-org (list &optional params)
"Convert LIST into an Org plain list.
LIST is as returned by `org-list-parse-list'. PARAMS is a property list
with overruling parameters for `org-list-to-generic'."
(let* ((make-item
(lambda (type _depth &optional c)
(concat (if (eq type 'ordered) "1. " "- ")
(and c (format "[@%d] " c)))))
(defaults
(list :istart make-item
:icount make-item
:ifmt (lambda (_type contents)
(replace-regexp-in-string "\n" "\n " contents))
:dtend " :: "
:cbon "[X] "
:cboff "[ ] "
:cbtrans "[-] ")))
(org-list-to-generic list (org-combine-plists defaults params))))
(defun org-list-to-subtree (list &optional start-level params)
"Convert LIST into an Org subtree.
LIST is as returned by `org-list-to-lisp'. Subtree starts at
START-LEVEL or level 1 if nil. PARAMS is a property list with
overruling parameters for `org-list-to-generic'."
(let* ((blank (pcase (cdr (assq 'heading org-blank-before-new-entry))
(`t t)
(`auto (save-excursion
(org-with-limited-levels (outline-previous-heading))
(org-previous-line-empty-p)))))
(level (or start-level 1))
(make-stars
(lambda (_type depth &optional _count)
;; Return the string for the heading, depending on DEPTH
;; of current sub-list.
(let ((oddeven-level (+ level (1- depth))))
(concat (make-string (if org-odd-levels-only
(1- (* 2 oddeven-level))
oddeven-level)
?*)
" ")))))
(org-list-to-generic
list
(org-combine-plists
(list :splice t
:istart make-stars
:icount make-stars
:dtstart " " :dtend " "
:isep (if blank "\n\n" "\n")
:cbon "DONE " :cboff "TODO " :cbtrans "TODO ")
params))))
(provide 'org-list)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; org-list.el ends here
org-mode-9.7.29+dfsg/lisp/org-macro.el 0000664 0000000 0000000 00000043336 15004304337 0017441 0 ustar 00root root 0000000 0000000 ;;; org-macro.el --- Macro Replacement Code for Org -*- lexical-binding: t; -*-
;; Copyright (C) 2013-2025 Free Software Foundation, Inc.
;; Author: Nicolas Goaziou <n.goaziou@gmail.com>
;; Maintainer: Ihor Radchenko <yantar92 at posteo dot net>
;; Keywords: outlines, hypermedia, calendar, text
;; 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Macros are expanded with `org-macro-replace-all', which relies
;; internally on `org-macro-expand'.
;; Default templates for expansion are stored in the buffer-local
;; variable `org-macro-templates'. This variable is updated by
;; `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)}}},
;; {{{input-file}}},
;; {{{modification-time(format-string)}}},
;; {{{n(counter,action}}}.
;; Upon exporting, "ox.el" will also provide {{{author}}}, {{{date}}},
;; {{{email}}} and {{{title}}} macros.
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'cl-lib)
(require 'org-macs)
(require 'org-compat)
(declare-function org-collect-keywords "org" (keywords &optional unique directory))
(declare-function org-element-at-point "org-element" (&optional pom cached-only))
(declare-function org-element-context "org-element" (&optional element))
(declare-function org-element-copy "org-element-ast" (datum))
(declare-function org-element-macro-parser "org-element" ())
(declare-function org-element-keyword-parser "org-element" (limit affiliated))
(declare-function org-element-put-property "org-element-ast" (node property value))
(declare-function org-element-parse-secondary-string "org-element" (string restriction &optional parent))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-begin "org-element" (node))
(declare-function org-element-end "org-element" (node))
(declare-function org-element-restriction "org-element" (element))
(declare-function org-element-type "org-element-ast" (node &optional anonymous))
(declare-function org-element-type-p "org-element-ast" (node types))
(declare-function org-entry-get "org" (pom property &optional inherit literal-nil))
(declare-function org-file-contents "org" (file &optional noerror nocache))
(declare-function org-in-commented-heading-p "org" (&optional no-inheritance element))
(declare-function org-link-search "ol" (s &optional avoid-pos stealth))
(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 &optional success))
(defvar org-link-search-must-match-exact-headline)
;;; Variables
(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,
both as strings. This is an internal variable. Do not set it
directly, use instead:
#+MACRO: name template")
;;; Functions
(defun org-macro--makeargs (template)
"Compute the formal arglist to use for TEMPLATE."
(let ((max 0) (i 0))
(while (string-match "\\$\\([0-9]+\\)" template i)
(setq i (match-end 0))
(setq max (max max (string-to-number (match-string 1 template)))))
(let ((args '(&rest _)))
(if (< max 1) args ;Avoid `&optional &rest', refused by Emacs-26!
(while (> max 0)
(push (intern (format "$%d" max)) args)
(setq max (1- max)))
(cons '&optional args)))))
(defun org-macro--set-templates (templates)
"Set template for the macro NAME.
VALUE is the template of the macro. The new value override the
previous one, unless VALUE is nil. Return the updated list."
(let ((new-templates nil))
(pcase-dolist (`(,name . ,value) templates)
(let ((old-definition (assoc name new-templates)))
;; This code can be evaluated unconditionally, as a part of
;; loading Org mode. We *must not* evaluate any code present
;; inside the Org buffer while loading. Org buffers may come
;; from various sources, like received email messages from
;; potentially malicious senders. Org mode might be used to
;; preview such messages and no code evaluation from inside the
;; received Org text should ever happen without user consent.
(when (and (stringp value) (string-match-p "\\`(eval\\>" value))
;; Pre-process the evaluation form for faster macro expansion.
(let* ((args (org-macro--makeargs value))
(body
(condition-case nil
;; `value' is of the form "(eval ...)" but we
;; don't want this to mean to pass the result to
;; `eval' (which would cause double evaluation),
;; so we strip the `eval' away with `cadr'.
(cadr (read value))
(error
(user-error "Invalid definition for macro %S" name)))))
(setq value `(lambda ,args ,body))))
(cond ((and value old-definition) (setcdr old-definition value))
(old-definition)
(t (push (cons name (or value "")) new-templates)))))
new-templates))
(defun org-macro--collect-macros ()
"Collect macro definitions in current buffer and setup files.
Return an alist containing all macro templates found."
(let ((templates
`(("author" . ,(org-macro--find-keyword-value "AUTHOR" t))
("email" . ,(org-macro--find-keyword-value "EMAIL"))
("title" . ,(org-macro--find-keyword-value "TITLE" t))
("date" . ,(org-macro--find-date)))))
(pcase (org-collect-keywords '("MACRO"))
(`(("MACRO" . ,values))
(dolist (value values)
(when (string-match "^\\(\\S-+\\)[ \t]*" value)
(let ((name (match-string 1 value))
(definition (substring value (match-end 0))))
(push (cons name definition) templates))))))
templates))
(defun org-macro-initialize-templates (&optional default)
"Collect macro templates defined in current buffer.
DEFAULT is a list of globally available templates.
Templates are stored in buffer-local variable `org-macro-templates'.
In addition to buffer-defined macros, the function installs the
following ones: \"n\", \"author\", \"email\", \"keyword\",
\"time\", \"property\", and, if the buffer is associated to
a file, \"input-file\" and \"modification-time\"."
(require 'org-element)
(org-macro--counter-initialize) ;for "n" macro
(setq org-macro-templates
(nconc
;; Install user-defined macros. Local macros have higher
;; precedence than global ones.
(org-macro--set-templates (append default (org-macro--collect-macros)))
;; Install file-specific macros.
(let ((visited-file (buffer-file-name (buffer-base-buffer))))
(and visited-file
(file-exists-p visited-file)
(list
`("input-file" . ,(file-name-nondirectory visited-file))
`("modification-time" .
,(let ((modtime (file-attribute-modification-time
(file-attributes visited-file))))
(lambda (arg1 &optional arg2 &rest _)
(format-time-string
arg1
(or (and (org-string-nw-p arg2)
(org-macro--vc-modified-time visited-file))
modtime))))))))
;; Install generic macros.
'(("keyword" . (lambda (arg1 &rest _)
(org-macro--find-keyword-value arg1 t)))
("n" . (lambda (&optional arg1 arg2 &rest _)
(org-macro--counter-increment arg1 arg2)))
("property" . (lambda (arg1 &optional arg2 &rest _)
(org-macro--get-property arg1 arg2)))
("time" . (lambda (arg1 &rest _)
(format-time-string arg1)))))))
(defun org-macro-expand (macro templates)
"Return expanded MACRO, as a string.
MACRO is an object, obtained, for example, with
`org-element-context'. TEMPLATES is an alist of templates used
for expansion. See `org-macro-templates' for a buffer-local
default value. Return nil if no template was found."
(let ((template
;; Macro names are case-insensitive.
(cdr (assoc-string (org-element-property :key macro) templates t))))
(when template
(let* ((value
(if (functionp template)
(apply template (org-element-property :args macro))
(replace-regexp-in-string
"\\$[0-9]+"
(lambda (m)
(or (nth (1- (string-to-number (substring m 1)))
(org-element-property :args macro))
;; No argument: remove place-holder.
""))
template nil 'literal))))
;; Force return value to be a string.
(format "%s" (or value ""))))))
(defun org-macro-replace-all (templates &optional 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.
Optional argument KEYWORDS, when non-nil is a list of keywords,
as strings, where macro expansion is allowed.
Return an error if a macro in the buffer cannot be associated to
a definition in TEMPLATES."
(org-with-wide-buffer
(goto-char (point-min))
(let ((properties-regexp (format "\\`EXPORT_%s\\+?\\'"
(regexp-opt keywords)))
record)
(while (re-search-forward "{{{[-A-Za-z0-9_]" nil t)
(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
;; `:parent' property might change as we modify buffer.
;; We do not care about it when checking for circular
;; dependencies. So, setting `:parent' to nil making sure
;; that actual macro element (if org-element-cache is
;; active) is unchanged.
(setq macro (cl-copy-list macro))
(org-element-put-property macro :parent nil)
(let* ((key (org-element-property :key macro))
(value (org-macro-expand macro templates))
(begin (org-element-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" key))
(value
(push signature record)
(delete-region
begin
;; Preserve white spaces after the macro.
(progn (goto-char (org-element-end macro))
(skip-chars-backward " \t")
(point)))
;; Leave point before replacement in case of
;; recursive expansions.
(save-excursion (insert value)))
;; Special "results" macro: if it is not defined,
;; simply leave it as-is. It will be expanded in
;; a second phase.
((equal key "results"))
(t
(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"))
;;; Helper functions and variables for internal macros
(defun org-macro--get-property (property location)
"Find PROPERTY's value at LOCATION.
PROPERTY is a string. LOCATION is a search string, as expected
by `org-link-search', or the empty string."
(org-with-wide-buffer
(when (org-string-nw-p location)
(condition-case _
(let ((org-link-search-must-match-exact-headline t))
(org-link-search location nil t))
(error
(error "Macro property failed: cannot find location %s" location))))
(org-entry-get nil property 'selective)))
(defun org-macro--find-keyword-value (name &optional collect)
"Find value for keyword NAME in current buffer.
Return value associated to the keywords named after NAME, as
a string, or nil. When optional argument COLLECT is non-nil,
concatenate values, separated with a space, from various keywords
in the buffer."
(org-with-point-at 1
(let ((regexp (format "^[ \t]*#\\+%s:" (regexp-quote name)))
(case-fold-search t)
(result nil))
(catch :exit
(while (re-search-forward regexp nil t)
(let ((element (org-with-point-at (match-beginning 0) (org-element-keyword-parser (line-end-position) (list (match-beginning 0))))))
(when (org-element-type-p element 'keyword)
(let ((value (org-element-property :value element)))
(if (not collect) (throw :exit value)
(setq result (concat result " " value)))))))
(and result (org-trim result))))))
(defun org-macro--find-date ()
"Find value for DATE in current buffer.
Return value as a string."
(let* ((value (org-macro--find-keyword-value "DATE"))
(date (org-element-parse-secondary-string
value (org-element-restriction 'keyword))))
(if (and (consp date)
(not (cdr date))
(org-element-type-p (car date) 'timestamp))
(format "(eval (if (org-string-nw-p $1) %s %S))"
(format "(org-format-timestamp '%S $1)"
(org-element-put-property
(org-element-copy (car date))
;; Remove non-printable.
:buffer nil))
value)
value)))
(defun org-macro--vc-modified-time (file)
(require 'vc) ; Not everything we need is autoloaded.
(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 (list 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 (org-encode-time time))))))))
(let ((proc (get-buffer-process buf)))
(while (and proc (accept-process-output proc .5 nil t)))))
(kill-buffer buf))
date))))
(defvar org-macro--counter-table nil
"Hash table containing counter value per name.")
(defun org-macro--counter-initialize ()
"Initialize `org-macro--counter-table'."
(setq org-macro--counter-table (make-hash-table :test #'equal)))
(defun org-macro--counter-increment (name &optional action)
"Increment counter NAME.
NAME is a string identifying the counter.
When non-nil, optional argument ACTION is a string.
If the string is \"-\", keep the NAME counter at its current
value, i.e. do not increment.
If the string represents an integer, set the counter to this number.
Any other non-empty string resets the counter to 1."
(let ((name-trimmed (if (stringp name) (org-trim name) ""))
(action-trimmed (when (org-string-nw-p action)
(org-trim action))))
(puthash name-trimmed
(cond ((not (org-string-nw-p action-trimmed))
(1+ (gethash name-trimmed org-macro--counter-table 0)))
((string= "-" action-trimmed)
(gethash name-trimmed org-macro--counter-table 1))
((string-match-p "\\`[0-9]+\\'" action-trimmed)
(string-to-number action-trimmed))
(t 1))
org-macro--counter-table)))
(provide 'org-macro)
;;; org-macro.el ends here
org-mode-9.7.29+dfsg/lisp/org-macs.el 0000664 0000000 0000000 00000207641 15004304337 0017264 0 ustar 00root root 0000000 0000000 ;;; org-macs.el --- Top-level Definitions for Org -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2025 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
;; Maintainer: Ihor Radchenko <yantar92 at posteo dot net>
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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 <https://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; 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.
;;; Code:
(require 'cl-lib)
(require 'format-spec)
(eval-when-compile (require 'subr-x)) ; For `when-let*', Emacs < 29
;;; Org version verification.
(defvar org--inhibit-version-check nil
"When non-nil, skip the detection of mixed-versions situations.
For internal use only. See Emacs bug #62762.
This variable is only supposed to be changed by Emacs build scripts.
When nil, Org tries to detect when Org source files were compiled with
a different version of Org (which tends to lead to incorrect `.elc' files),
or when the current Emacs session has loaded a mix of files from different
Org versions (typically the one bundled with Emacs and another one installed
from GNU ELPA), which can happen if some parts of Org were loaded before
`load-path' was changed (e.g. before the GNU-ELPA-installed Org is activated
by `package-activate-all').")
(defmacro org-assert-version ()
"Assert compile time and runtime version match."
;; We intentionally use a more permissive `org-release' instead of
;; `org-git-version' to work around deficiencies in Elisp
;; compilation after pulling latest changes. Unchanged files will
;; not be re-compiled and thus their macro-expanded
;; `org-assert-version' calls would fail using strict
;; `org-git-version' check because the generated Org version strings
;; will not match.
`(unless (or ,org--inhibit-version-check (equal (org-release) ,(org-release)))
(warn "Org version mismatch.
This warning usually appears when a built-in Org version is loaded
prior to the more recent Org version.
Version mismatch is commonly encountered in the following situations:
1. Emacs is loaded using literate Org config and more recent Org
version is loaded inside the file loaded by `org-babel-load-file'.
`org-babel-load-file' triggers the built-in Org version clashing
the newer Org version attempt to be loaded later.
It is recommended to move the Org loading code before the
`org-babel-load-file' call.
2. New Org version is loaded manually by setting `load-path', but some
other package depending on Org is loaded before the `load-path' is
configured.
This \"other package\" is triggering built-in Org version, again
causing the version mismatch.
It is recommended to set `load-path' as early in the config as
possible.
3. New Org version is loaded using straight.el package manager and
other package depending on Org is loaded before straight triggers
loading of the newer Org version.
It is recommended to put
%s
early in the config. Ideally, right after the straight.el
bootstrap. Moving `use-package' :straight declaration may not be
sufficient if the corresponding `use-package' statement is
deferring the loading.
4. A new Org version is synchronized with Emacs git repository and
stale .elc files are still left from the previous build.
It is recommended to remove .elc files from lisp/org directory and
re-compile."
;; Avoid `warn' replacing "'" with "’" (see `format-message').
"(straight-use-package 'org)")))
;; We rely on org-macs when generating Org version. Checking Org
;; version here will interfere with Org build process.
;; (org-assert-version)
(declare-function org-mode "org" ())
(declare-function org-agenda-files "org" (&optional unrestricted archives))
(declare-function org-time-string-to-seconds "org" (s))
(declare-function org-fold-show-context "org-fold" (&optional key))
(declare-function org-fold-save-outline-visibility "org-fold" (use-markers &rest body))
(declare-function org-fold-next-visibility-change "org-fold" (&optional pos limit ignore-hidden-p previous-p))
(declare-function org-fold-core-with-forced-fontification "org-fold" (&rest body))
(declare-function org-fold-folded-p "org-fold" (&optional pos limit ignore-hidden-p previous-p))
(declare-function org-time-convert-to-list "org-compat" (time))
(declare-function org-buffer-text-pixel-width "org-compat" ())
(defvar org-ts-regexp0)
(defvar ffap-url-regexp)
;;; Macros
(defmacro org-require-package (symbol &optional name noerror)
"Try to load library SYMBOL and display error otherwise.
With optional parameter NAME, use NAME as package name instead of
SYMBOL. Show warning instead of error when NOERROR is non-nil."
`(unless (require ,symbol nil t)
(,(if noerror 'warn 'user-error)
"`%s' failed to load required package \"%s\""
this-command ,(or name symbol))))
(defmacro org-with-gensyms (symbols &rest body)
(declare (debug (sexp body)) (indent 1))
`(let ,(mapcar (lambda (s)
`(,s (make-symbol (concat "--" (symbol-name ',s)))))
symbols)
,@body))
;; Use `with-silent-modifications' to ignore cosmetic changes and
;; `org-unmodified' to ignore real text modifications.
(defmacro org-unmodified (&rest body)
"Run BODY while preserving the buffer's `buffer-modified-p' state."
(declare (debug (body)))
(org-with-gensyms (was-modified)
`(let ((,was-modified (buffer-modified-p)))
(unwind-protect
(let ((buffer-undo-list t)
(inhibit-modification-hooks t))
,@body)
(set-buffer-modified-p ,was-modified)))))
(defmacro org-with-base-buffer (buffer &rest body)
"Run BODY in base buffer for BUFFER.
If BUFFER is nil, use base buffer for `current-buffer'."
(declare (debug (body)) (indent 1))
`(with-current-buffer (or (buffer-base-buffer ,buffer)
(or ,buffer (current-buffer)))
,@body))
(defmacro org-with-point-at (epom &rest body)
"Move to buffer and point of EPOM for the duration of BODY.
EPOM is an element, point, or marker."
(declare (debug (form body)) (indent 1))
(require 'org-element-ast)
(org-with-gensyms (mepom)
`(let ((,mepom ,epom))
(save-excursion
(cond
((markerp ,mepom)
(set-buffer (marker-buffer ,mepom)))
((numberp ,mepom))
(t
(when (org-element-property :buffer ,mepom)
(set-buffer (org-element-property :buffer ,mepom)))
(setq ,mepom (org-element-property :begin ,mepom))))
(org-with-wide-buffer
(goto-char (or ,mepom (point)))
,@body)))))
(defmacro org-with-remote-undo (buffer &rest body)
"Execute BODY while recording undo information in current buffer and BUFFER.
This function is only useful when called from Agenda buffer."
(declare (debug (form body)) (indent 1))
(org-with-gensyms (cline cmd buf1 buf2 undo1 undo2 c1 c2)
`(let ((,cline (org-current-line))
(,cmd this-command)
(,buf1 (current-buffer))
(,buf2 ,buffer)
(,undo1 buffer-undo-list)
(,undo2 (with-current-buffer ,buffer buffer-undo-list))
,c1 ,c2)
,@body
(when org-agenda-allow-remote-undo
(setq ,c1 (org-verify-change-for-undo
,undo1 (with-current-buffer ,buf1 buffer-undo-list))
,c2 (org-verify-change-for-undo
,undo2 (with-current-buffer ,buf2 buffer-undo-list)))
(when (or ,c1 ,c2)
;; make sure there are undo boundaries
(and ,c1 (with-current-buffer ,buf1 (undo-boundary)))
(and ,c2 (with-current-buffer ,buf2 (undo-boundary)))
;; remember which buffer to undo
(push (list ,cmd ,cline ,buf1 ,c1 ,buf2 ,c2)
org-agenda-undo-list))))))
(defmacro org-no-read-only (&rest body)
"Inhibit read-only for BODY."
(declare (debug (body)))
`(let ((inhibit-read-only t)) ,@body))
(defalias 'org-save-outline-visibility #'org-fold-save-outline-visibility)
(defmacro org-with-wide-buffer (&rest body)
"Execute BODY while temporarily widening the buffer."
(declare (debug (body)))
`(save-excursion
(save-restriction
(widen)
,@body)))
(defmacro org-with-limited-levels (&rest body)
"Execute BODY with limited number of outline levels."
(declare (debug (body)))
`(progn
(defvar org-called-with-limited-levels)
(defvar org-outline-regexp)
(defvar outline-regexp)
(defvar org-outline-regexp-bol)
(let* ((org-called-with-limited-levels t)
(org-outline-regexp (org-get-limited-outline-regexp))
(outline-regexp org-outline-regexp)
(org-outline-regexp-bol (org-get-limited-outline-regexp t)))
,@body)))
(defmacro org-eval-in-environment (environment form)
(declare (debug (form form)) (indent 1) (obsolete cl-progv "2021"))
`(eval (list 'let ,environment ',form)))
;;;###autoload
(defmacro org-load-noerror-mustsuffix (file)
"Load FILE with optional arguments NOERROR and MUSTSUFFIX."
`(load ,file 'noerror nil nil 'mustsuffix))
(defmacro org-preserve-local-variables (&rest body)
"Execute BODY while preserving local variables."
(declare (debug (body)))
`(let ((local-variables
(org-with-wide-buffer
(goto-char (point-max))
(let ((case-fold-search t))
(and (re-search-backward "^[ \t]*# +Local Variables:"
(max (- (point) 3000) 1)
t)
(let ((buffer-undo-list t))
(delete-and-extract-region (point) (point-max)))))))
(tick-counter-before (buffer-modified-tick)))
(unwind-protect (progn ,@body)
(when local-variables
(org-with-wide-buffer
(goto-char (point-max))
(unless (bolp) (insert "\n"))
(let ((modified (< tick-counter-before (buffer-modified-tick)))
(buffer-undo-list t))
(insert local-variables)
(unless modified
(restore-buffer-modified-p nil))))))))
;;;###autoload
(defmacro org-element-with-disabled-cache (&rest body)
"Run BODY without active org-element-cache."
(declare (debug (form body)) (indent 0))
`(cl-letf (((symbol-function #'org-element--cache-active-p) (lambda (&rest _) nil)))
,@body))
;;; Buffer and windows
(defun org-base-buffer (buffer)
"Return the base buffer of BUFFER, if it has one. Else return the buffer."
(when buffer
(or (buffer-base-buffer buffer)
buffer)))
(defun org-find-base-buffer-visiting (file)
"Like `find-buffer-visiting' but always return the base buffer.
FILE is the file name passed to `find-buffer-visiting'."
(let ((buf (or (get-file-buffer file)
(find-buffer-visiting file))))
(org-base-buffer buf)))
(defvar-local org-file-buffer-created nil
"Non-nil when current buffer is created from `org-with-file-buffer'.
The value is FILE argument passed to `org-with-file-buffer'.")
(defmacro org-with-file-buffer (file &rest body)
"Evaluate BODY with current buffer visiting FILE.
When no live buffer is visiting FILE, create one and kill after
evaluating BODY.
During evaluation, when the buffer was created, `org-file-buffer-created'
variable is set to FILE."
(declare (debug (form body)) (indent 1))
(org-with-gensyms (mark-function filename buffer)
`(let ((,mark-function (lambda () (setq-local org-file-buffer-created ,file)))
(,filename ,file)
,buffer)
(add-hook 'find-file-hook ,mark-function)
(unwind-protect
(progn
(setq ,buffer (find-file-noselect ,filename t))
(with-current-buffer ,buffer
(prog1 (progn ,@body)
(with-current-buffer ,buffer
(when (equal ,filename org-file-buffer-created)
(kill-buffer))))))
(remove-hook 'find-file-hook ,mark-function)))))
(defun org-fit-window-to-buffer (&optional window max-height min-height
shrink-only)
"Fit WINDOW to the buffer, but only if it is not a side-by-side window.
WINDOW defaults to the selected window. MAX-HEIGHT and MIN-HEIGHT are
passed through to `fit-window-to-buffer'. If SHRINK-ONLY is set, call
`shrink-window-if-larger-than-buffer' instead, the height limit is
ignored in this case."
(cond ((not (window-full-width-p window))
;; Do nothing if another window would suffer.
)
((not shrink-only)
(fit-window-to-buffer window max-height min-height))
(t (shrink-window-if-larger-than-buffer window)))
(or window (selected-window)))
(defun org-buffer-list (&optional predicate exclude-tmp)
"Return a list of Org buffers.
PREDICATE can be `export', `files' or `agenda'.
export restrict the list to Export buffers.
files restrict the list to buffers visiting Org files.
agenda restrict the list to buffers visiting agenda files.
If EXCLUDE-TMP is non-nil, ignore temporary buffers."
(let* ((bfn nil)
(agenda-files (and (eq predicate 'agenda)
(mapcar 'file-truename (org-agenda-files t))))
(filter
(cond
((eq predicate 'files)
(lambda (b) (with-current-buffer b (derived-mode-p 'org-mode))))
((eq predicate 'export)
(lambda (b) (string-match "\\*Org .*Export" (buffer-name b))))
((eq predicate 'agenda)
(lambda (b)
(with-current-buffer b
(and (derived-mode-p 'org-mode)
(setq bfn (buffer-file-name b))
(member (file-truename bfn) agenda-files)))))
(t (lambda (b) (with-current-buffer b
(or (derived-mode-p 'org-mode)
(string-match "\\*Org .*Export"
(buffer-name b)))))))))
(delq nil
(mapcar
(lambda(b)
(if (and (funcall filter b)
(or (not exclude-tmp)
(not (string-match "tmp" (buffer-name b)))))
b
nil))
(buffer-list)))))
;;; File
(defun org-file-newer-than-p (file time)
"Non-nil if FILE modification time is greater than TIME.
TIME should be obtained earlier for the same FILE name using
\(file-attribute-modification-time (file-attributes file))
If TIME is nil (file did not exist) then any existing FILE
is considered as a newer one. Some file systems have coarse
timestamp resolution, for example 1 second on HFS+ or 2 seconds on FAT,
so nil may be returned when file is updated twice within a short period
of time. File timestamp and system clock `current-time' may have
different resolution, so attempts to compare them may give unexpected
results.
Consider `file-newer-than-file-p' to check up to date state
in target-prerequisite files relation."
(let ((mtime (file-attribute-modification-time (file-attributes file))))
(and mtime (or (not time) (time-less-p time mtime)))))
;;; Indentation
(defmacro org-current-text-indentation ()
"Like `current-indentation', but ignore display/invisible properties."
`(let ((buffer-invisibility-spec nil))
(current-indentation)))
(defun org-do-remove-indentation (&optional n skip-fl)
"Remove the maximum common indentation from the buffer.
Do not consider invisible text when calculating indentation.
When optional argument N is a positive integer, remove exactly
that much characters from indentation, if possible. When
optional argument SKIP-FL is non-nil, skip the first
line. Return nil if it fails."
(catch :exit
(goto-char (point-min))
;; Find maximum common indentation, if not specified.
(let ((n (or n
(let ((min-ind (point-max)))
(save-excursion
(when skip-fl (forward-line))
(while (re-search-forward "^[ \t]*\\S-" nil t)
(let ((ind (org-current-text-indentation)))
(if (zerop ind) (throw :exit nil)
(setq min-ind (min min-ind ind))))))
min-ind))))
(if (zerop n) (throw :exit nil)
;; Remove exactly N indentation, but give up if not possible.
(when skip-fl (forward-line))
(while (not (eobp))
(let* ((buffer-invisibility-spec nil) ; do not treat invisible text specially
(ind (progn (skip-chars-forward " \t") (current-column))))
(cond ((< ind n)
(if (eolp) (delete-region (line-beginning-position) (point))
(throw :exit nil)))
(t (delete-region (line-beginning-position)
(progn (move-to-column n t)
(point)))))
(forward-line)))
;; Signal success.
t))))
;;; Input
(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")))))
(declare-function org-timestamp-inactive "org" (&optional arg))
(defun org-completing-read (&rest args)
"Completing-read with SPACE being a normal character."
(let ((enable-recursive-minibuffers t)
(minibuffer-local-completion-map
(copy-keymap minibuffer-local-completion-map)))
(define-key minibuffer-local-completion-map " " #'self-insert-command)
(define-key minibuffer-local-completion-map "?" #'self-insert-command)
(define-key minibuffer-local-completion-map (kbd "C-c !")
#'org-timestamp-inactive)
(apply #'completing-read args)))
(defun org--mks-read-key (allowed-keys prompt navigation-keys)
"Read a key and ensure it is a member of ALLOWED-KEYS.
Enable keys to scroll the window if NAVIGATION-KEYS is set.
TAB, SPC and RET are treated equivalently."
(setq header-line-format (when navigation-keys "Use C-n, C-p, C-v, M-v to navigate."))
(let ((char-key (read-char-exclusive prompt)))
(if (and navigation-keys (memq char-key '(14 16 22 134217846)))
(progn
(org-scroll char-key)
(org--mks-read-key allowed-keys prompt navigation-keys))
(let ((key (char-to-string
(pcase char-key
((or ?\s ?\t ?\r) ?\t)
(char char)))))
(if (member key allowed-keys)
key
(message "Invalid key: `%s'" key)
(sit-for 1)
(org--mks-read-key allowed-keys prompt navigation-keys))))))
(defun org-mks (table title &optional prompt specials)
"Select a member of an alist with multiple keys.
TABLE is the alist which should contain entries where the car is a string.
There should be two types of entries.
1. prefix descriptions like (\"a\" \"Description\")
This indicates that `a' is a prefix key for multi-letter selection, and
that there are entries following with keys like \"ab\", \"ax\"...
2. Select-able members must have more than two elements, with the first
being the string of keys that lead to selecting it, and the second a
short description string of the item.
The command will then make a temporary buffer listing all entries
that can be selected with a single key, and all the single key
prefixes. When you press the key for a single-letter entry, it is selected.
When you press a prefix key, the commands (and maybe further prefixes)
under this key will be shown and offered for selection.
TITLE will be placed over the selection in the temporary buffer,
PROMPT will be used when prompting for a key. SPECIALS is an
alist with (\"key\" \"description\") entries. When one of these
is selected, only the bare key is returned."
(save-window-excursion
(let ((inhibit-quit t)
(buffer (switch-to-buffer-other-window "*Org Select*"))
(prompt (or prompt "Select: "))
case-fold-search
current)
(unwind-protect
(catch 'exit
(while t
(erase-buffer)
(insert title "\n\n")
(let ((des-keys nil)
(allowed-keys '("\C-g"))
(tab-alternatives '("\s" "\t" "\r"))
(cursor-type nil))
;; Populate allowed keys and descriptions keys
;; available with CURRENT selector.
(let ((re (format "\\`%s\\(.\\)\\'"
(if current (regexp-quote current) "")))
(prefix (if current (concat current " ") "")))
(dolist (entry table)
(pcase entry
;; Description.
(`(,(and key (pred (string-match re))) ,desc)
(let ((k (match-string 1 key)))
(push k des-keys)
;; Keys ending in tab, space or RET are equivalent.
(if (member k tab-alternatives)
(push "\t" allowed-keys)
(push k allowed-keys))
(insert prefix "[" k "]" "..." " " desc "..." "\n")))
;; Usable entry.
(`(,(and key (pred (string-match re))) ,desc . ,_)
(let ((k (match-string 1 key)))
(insert prefix "[" k "]" " " desc "\n")
(push k allowed-keys)))
(_ nil))))
;; Insert special entries, if any.
(when specials
(insert "----------------------------------------------------\
---------------------------\n")
(pcase-dolist (`(,key ,description) specials)
(insert (format "[%s] %s\n" key description))
(push key allowed-keys)))
;; Display UI and let user select an entry or
;; a sub-level prefix.
(goto-char (point-min))
(org-fit-window-to-buffer)
(message "") ; With this line the prompt appears in
; the minibuffer. Else keystrokes may
; appear, which is spurious.
(let ((pressed (org--mks-read-key
allowed-keys prompt
(not (pos-visible-in-window-p (1- (point-max)))))))
(setq current (concat current pressed))
(cond
((equal pressed "\C-g") (user-error "Abort"))
;; Selection is a prefix: open a new menu.
((member pressed des-keys))
;; Selection matches an association: return it.
((let ((entry (assoc current table)))
(and entry (throw 'exit entry))))
;; Selection matches a special entry: return the
;; selection prefix.
((assoc current specials) (throw 'exit current))
(t (error "No entry available")))))))
(when buffer
(when-let* ((window (get-buffer-window buffer t)))
(quit-window 'kill window))
(kill-buffer buffer))))))
;;; List manipulation
(defsubst org-get-alist-option (option key)
(cond ((eq key t) t)
((eq option t) t)
((assoc key option) (cdr (assoc key option)))
(t (let ((r (cdr (assq 'default option))))
(if (listp r) (delq nil r) r)))))
(defsubst org-last (list)
"Return the last element of LIST."
(car (last list)))
(defsubst org-uniquify (list)
"Non-destructively remove duplicate elements from LIST."
(let ((res (copy-sequence list))) (delete-dups res)))
(defun org-uniquify-alist (alist)
"Merge elements of ALIST with the same key.
For example, in this alist:
\(org-uniquify-alist \\='((a 1) (b 2) (a 3)))
=> ((a 1 3) (b 2))
merge (a 1) and (a 3) into (a 1 3).
The function returns the new ALIST."
(let (rtn)
(dolist (e alist rtn)
(let (n)
(if (not (assoc (car e) rtn))
(push e rtn)
(setq n (cons (car e) (append (cdr (assoc (car e) rtn)) (cdr e))))
(setq rtn (assq-delete-all (car e) rtn))
(push n rtn))))))
(defun org-delete-all (elts list)
"Remove all elements in ELTS from LIST.
Comparison is done with `equal'. It is a destructive operation
that may remove elements by altering the list structure."
(while elts
(setq list (delete (pop elts) list)))
list)
(defun org-plist-delete-all (plist props)
"Delete all elements in PROPS from PLIST."
(dolist (e props plist)
(setq plist (org-plist-delete plist e))))
(defun org-plist-delete (plist property)
"Delete PROPERTY from PLIST.
This is in contrast to merely setting it to 0."
(let (p)
(while plist
(if (not (eq property (car plist)))
(setq p (plist-put p (car plist) (nth 1 plist))))
(setq plist (cddr plist)))
p))
(defun org-combine-plists (&rest plists)
"Create a single property list from all plists in PLISTS.
The process starts by copying the first list, and then setting properties
from the other lists. Settings in the last list are the most significant
ones and overrule settings in the other lists."
(let ((rtn (copy-sequence (pop plists)))
p v ls)
(while plists
(setq ls (pop plists))
(while ls
(setq p (pop ls) v (pop ls))
(setq rtn (plist-put rtn p v))))
rtn))
;;; Local variables
(defconst org-unique-local-variables
'(org-element--cache
org-element--headline-cache
org-element--cache-change-tic
org-element--cache-last-buffer-size
org-element--cache-change-warning
org-element--cache-gapless
org-element--cache-hash-left
org-element--cache-hash-right
org-element--cache-size
org-element--headline-cache-size
org-element--cache-sync-keys-value
org-element--cache-diagnostics-ring
org-element--cache-diagnostics-ring-size
org-element--cache-sync-keys
org-element--cache-sync-requests
org-element--cache-sync-timer)
"List of local variables that cannot be transferred to another buffer.")
(defun org-get-local-variables ()
"Return a list of all local variables in an Org mode buffer."
(delq nil
(mapcar
(lambda (x)
(let* ((binding (if (symbolp x) (list x) (list (car x) (cdr x))))
(name (car binding)))
(and (not (get name 'org-state))
(not (memq name org-unique-local-variables))
(string-match-p
"\\`\\(org-\\|orgtbl-\\|outline-\\|comment-\\|paragraph-\\|\
auto-fill\\|normal-auto-fill\\|fill-paragraph\\|indent-\\)"
(symbol-name name))
binding)))
(with-temp-buffer
(org-mode)
(buffer-local-variables)))))
(defun org-clone-local-variables (from-buffer &optional regexp)
"Clone local variables from FROM-BUFFER.
Optional argument REGEXP selects variables to clone."
(dolist (pair (buffer-local-variables from-buffer))
(pcase pair
(`(,name . ,value) ;ignore unbound variables
(when (and (not (memq name org-unique-local-variables))
(or (null regexp) (string-match-p regexp (symbol-name name))))
(ignore-errors (set (make-local-variable name) value)))))))
;;; Miscellaneous
(defsubst org-call-with-arg (command arg)
"Call COMMAND interactively, but pretend prefix arg was ARG."
(let ((current-prefix-arg arg)) (call-interactively command)))
(defsubst org-check-external-command (cmd &optional use no-error)
"Check if external program CMD for USE exists, error if not.
When the program does exist, return its path.
When it does not exist and NO-ERROR is set, return nil.
Otherwise, throw an error. The optional argument USE can describe what this
program is needed for, so that the error message can be more informative."
(or (executable-find cmd)
(if no-error
nil
(error "Can't find `%s'%s" cmd
(if use (format " (%s)" use) "")))))
(defun org-display-warning (message)
"Display the given MESSAGE as a warning."
(display-warning 'org message :warning))
(defun org-unlogged-message (&rest args)
"Display a message, but avoid logging it in the *Messages* buffer."
(let ((message-log-max nil))
(apply #'message args)))
(defmacro org-dlet (binders &rest body)
"Like `let*' but using dynamic scoping."
(declare (indent 1) (debug let))
(let ((vars (mapcar (lambda (binder)
(if (consp binder) (car binder) binder))
binders)))
`(progn
(with-no-warnings
,@(mapcar (lambda (var) `(defvar ,var)) vars))
(let* ,binders ,@body))))
(defmacro org-pushnew-to-end (val var)
"Like `cl-pushnew' but pushes to the end of the list.
Uses `equal' for comparisons.
Beware: this performs O(N) memory allocations, so if you use it in a loop, you
get an unnecessary O(N²) space complexity, so you're usually better off using
`cl-pushnew' (with a final `reverse' if you care about the order of elements)."
(declare (debug (form gv-place)))
(let ((v (make-symbol "v")))
`(let ((,v ,val))
(unless (member ,v ,var)
(setf ,var (append ,var (list ,v)))))))
(defun org-eval (form)
"Eval FORM and return result."
(condition-case-unless-debug error
(eval form t)
(error (format "%%![Error: %s]" error))))
(defvar org--headline-re-cache-no-bol nil
"Plist holding association between headline level regexp.")
(defvar org--headline-re-cache-bol nil
"Plist holding association between headline level regexp.")
(defsubst org-headline-re (true-level &optional no-bol)
"Generate headline regexp for TRUE-LEVEL.
When NO-BOL is non-nil, regexp will not demand the regexp to start at
beginning of line."
(or (plist-get
(if no-bol
org--headline-re-cache-no-bol
org--headline-re-cache-bol)
true-level)
(let ((re (rx-to-string
(if no-bol
`(seq (** 1 ,true-level "*") " ")
`(seq line-start (** 1 ,true-level "*") " ")))))
(if no-bol
(setq org--headline-re-cache-no-bol
(plist-put
org--headline-re-cache-no-bol
true-level re))
(setq org--headline-re-cache-bol
(plist-put
org--headline-re-cache-bol
true-level re)))
re)))
(defvar org-outline-regexp) ; defined in org.el
(defvar org-outline-regexp-bol) ; defined in org.el
(defvar org-odd-levels-only) ; defined in org.el
(defvar org-inlinetask-min-level) ; defined in org-inlinetask.el
(defun org-get-limited-outline-regexp (&optional with-bol)
"Return outline-regexp with limited number of levels.
The number of levels is controlled by `org-inlinetask-min-level'.
Match at beginning of line when WITH-BOL is non-nil."
(cond ((not (derived-mode-p 'org-mode))
(if (string-prefix-p "^" outline-regexp)
(if with-bol outline-regexp (substring outline-regexp 1))
(if with-bol (concat "^" outline-regexp) outline-regexp)))
((not (featurep 'org-inlinetask))
(if with-bol org-outline-regexp-bol org-outline-regexp))
(t
(let* ((limit-level (1- org-inlinetask-min-level))
(nstars (if org-odd-levels-only
(1- (* limit-level 2))
limit-level)))
(org-headline-re nstars (not with-bol))))))
(defun org--line-empty-p (n)
"Is the Nth next line empty?"
(and (not (bobp))
(save-excursion
(forward-line n)
(skip-chars-forward " \t")
(eolp))))
(defun org-previous-line-empty-p ()
"Is the previous line a blank line?
When NEXT is non-nil, check the next line instead."
(org--line-empty-p -1))
(defun org-next-line-empty-p ()
"Is the previous line a blank line?
When NEXT is non-nil, check the next line instead."
(org--line-empty-p 1))
(defun org-id-uuid ()
"Return string with random (version 4) UUID."
(let ((rnd (md5 (format "%s%s%s%s%s%s%s"
(random)
(org-time-convert-to-list nil)
(user-uid)
(emacs-pid)
(user-full-name)
user-mail-address
(recent-keys)))))
(format "%s-%s-4%s-%s%s-%s"
(substring rnd 0 8)
(substring rnd 8 12)
(substring rnd 13 16)
(format "%x"
(logior
#b10000000
(logand
#b10111111
(string-to-number
(substring rnd 16 18) 16))))
(substring rnd 18 20)
(substring rnd 20 32))))
;;; Motion
(defsubst org-goto-line (N)
(save-restriction
(widen)
(goto-char (point-min))
(forward-line (1- N))))
(defsubst org-current-line (&optional pos)
(save-excursion
(and pos (goto-char pos))
;; works also in narrowed buffer, because we start at 1, not point-min
(+ (if (bolp) 1 0) (count-lines 1 (point)))))
;;; Overlays and text properties
(defun org-overlay-display (ovl text &optional face evap)
"Make overlay OVL display TEXT with face FACE."
(overlay-put ovl 'display text)
(when face (overlay-put ovl 'face face))
(when evap (overlay-put ovl 'evaporate t)))
(defun org-overlay-before-string (ovl text &optional face evap)
"Make overlay OVL display TEXT with face FACE."
(when face (org-add-props text nil 'face face))
(overlay-put ovl 'before-string text)
(when 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 (found)
(dolist (ov (overlays-at (or pos (point))) found)
(cond ((not (overlay-get ov prop)))
(delete (delete-overlay ov))
(t (push ov found))))))
(defun org-find-text-property-region (pos prop)
"Find a region around POS containing same non-nil value of PROP text property.
Return nil when PROP is not set at POS."
(let* ((beg (and (get-text-property pos prop) pos))
(end beg))
(when beg
(unless (or (equal beg (point-min))
(not (eq (get-text-property beg prop)
(get-text-property (1- beg) prop))))
(setq beg (previous-single-property-change pos prop nil (point-min))))
(unless (or (equal end (point-max))
;; (not (eq (get-text-property end prop)
;; (get-text-property (1+ end) prop)))
)
(setq end (next-single-property-change pos prop nil (point-max))))
(cons beg end))))
;;; Regexp matching
(defsubst org-pos-in-match-range (pos n)
(and (match-beginning n)
(<= (match-beginning n) pos)
(>= (match-end n) pos)))
(defsubst org-skip-whitespace ()
"Skip over space, tabs and newline characters."
(skip-chars-forward " \t\n\r"))
(defun org-match-line (regexp)
"Match REGEXP at the beginning of the current line."
(save-excursion
(forward-line 0)
(looking-at regexp)))
(defun org-match-any-p (re list)
"Non-nil if regexp RE matches an element in LIST."
(cl-some (lambda (x) (string-match-p re x)) list))
(defun org-in-regexp (regexp &optional nlines visually)
"Check if point is inside a match of REGEXP.
Normally only the current line is checked, but you can include
NLINES extra lines around point into the search. If VISUALLY is
set, require that the cursor is not after the match but really
on, so that the block visually is on the match.
Return nil or a cons cell (BEG . END) where BEG and END are,
respectively, the positions at the beginning and the end of the
match."
(catch :exit
(let ((pos (point))
(eol (line-end-position (if nlines (1+ nlines) 1))))
(save-excursion
(forward-line (- (or nlines 0)))
(while (and (re-search-forward regexp eol t)
(<= (match-beginning 0) pos))
(let ((end (match-end 0)))
(when (or (> end pos) (and (= end pos) (not visually)))
(throw :exit (cons (match-beginning 0) (match-end 0))))))))))
(defun org-point-in-group (point group &optional context)
"Check if POINT is in match-group GROUP.
If CONTEXT is non-nil, return a list with CONTEXT and the boundaries of the
match. If the match group does not exist or point is not inside it,
return nil."
(and (match-beginning group)
(>= point (match-beginning group))
(<= point (match-end group))
(if context
(list context (match-beginning group) (match-end group))
t)))
(defun org-url-p (s)
"Non-nil if string S is a URL."
(require 'ffap)
(and ffap-url-regexp (string-match-p ffap-url-regexp s)))
(defconst org-uuid-regexp
"\\`[0-9a-f]\\{8\\}-[0-9a-f]\\{4\\}-[0-9a-f]\\{4\\}-[0-9a-f]\\{4\\}-[0-9a-f]\\{12\\}\\'"
"Regular expression matching a universal unique identifier (UUID).")
(defun org-uuidgen-p (s)
"Is S an ID created by UUIDGEN?"
(string-match org-uuid-regexp (downcase s)))
;;; String manipulation
(defcustom org-sort-function #'string-collate-lessp
"Function used to compare strings when sorting.
This function affects how Org mode sorts headlines, agenda items,
table lines, etc.
The function must accept either 2 or 4 arguments: strings to compare
and, optionally, LOCALE and IGNORE-CASE - locale name and flag to make
comparison case-insensitive.
The default value uses sorting rules according to OS language. Users
who want to make sorting language-independent, may customize the value
to `org-sort-function-fallback'.
Note that some string sorting rules are known to be not accurate on
MacOS. See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=59275.
MacOS users may customize the value to
`org-sort-function-fallback'."
:group 'org
:package-version '(Org . "9.7")
:type '(choice
(const :tag "According to OS language" string-collate-lessp)
(const :tag "Using string comparison" org-sort-function-fallback)
(function :tag "Custom function")))
(defun org-sort-function-fallback (a b &optional _ ignore-case)
"Return non-nil when downcased string A < string B.
Use `compare-strings' for comparison. Honor IGNORE-CASE."
(let ((ans (compare-strings a nil nil b nil nil ignore-case)))
(cond
((and (numberp ans) (< ans 0)) t)
(t nil))))
(defun org-string< (a b &optional locale ignore-case)
"Return non-nil when string A < string B.
LOCALE is the locale name. IGNORE-CASE, when non-nil, makes comparison
ignore case."
(if (= 4 (cdr (func-arity org-sort-function)))
(funcall org-sort-function a b locale ignore-case)
(funcall org-sort-function a b)))
(defun org-string<= (a b &optional locale ignore-case)
"Return non-nil when string A <= string B.
LOCALE is the locale name. IGNORE-CASE, when non-nil, makes comparison
ignore case."
(or (string= a b) (org-string< a b locale ignore-case)))
(defun org-string>= (a b &optional locale ignore-case)
"Return non-nil when string A >= string B.
LOCALE is the locale name. IGNORE-CASE, when non-nil, makes comparison
ignore case."
(not (org-string< a b locale ignore-case)))
(defun org-string> (a b &optional locale ignore-case)
"Return non-nil when string A > string B.
LOCALE is the locale name. IGNORE-CASE, when non-nil, makes comparison
ignore case."
(and (not (string= a b))
(not (org-string< a b locale ignore-case))))
(defun org-string<> (a b)
"Return non-nil when string A and string B are not equal."
(not (string= a b)))
(defsubst org-trim (s &optional keep-lead)
"Remove whitespace at the beginning and the end of string S.
When optional argument KEEP-LEAD is non-nil, removing blank lines
at the beginning of the string does not affect leading indentation."
(replace-regexp-in-string
(if keep-lead "\\`\\([ \t]*\n\\)+" "\\`[ \t\n\r]+") ""
(replace-regexp-in-string "[ \t\n\r]+\\'" "" s)))
(defun org-string-nw-p (s)
"Return S if S is a string containing a non-blank character.
Otherwise, return nil."
(and (stringp s)
(string-match-p "[^ \r\t\n]" s)
s))
(defun org-reverse-string (string)
"Return the reverse of STRING."
(apply #'string (nreverse (string-to-list string))))
(defun org-split-string (string &optional separators)
"Splits STRING into substrings at SEPARATORS.
SEPARATORS is a regular expression. When nil, it defaults to
\"[ \\f\\t\\n\\r\\v]+\".
Unlike `split-string', matching SEPARATORS at the beginning and
end of string are ignored."
(let ((separators (or separators "[ \f\t\n\r\v]+")))
(if (not (string-match separators string)) (list string)
(let ((i (match-end 0))
(results
(and (/= 0 (match-beginning 0)) ;skip leading separator
(list (substring string 0 (match-beginning 0))))))
(while (string-match separators string i)
(push (substring string i (match-beginning 0))
results)
(setq i (match-end 0)))
(nreverse (if (= i (length string))
results ;skip trailing separator
(cons (substring string i) results)))))))
(defun org--string-from-props (s property beg end)
"Return the visible part of string S.
Visible part is determined according to text PROPERTY, which is
either `invisible' or `display'. BEG and END are 0-indices
delimiting S."
(let ((width 0)
(cursor beg))
(while (setq beg (text-property-not-all beg end property nil s))
(let* ((next (next-single-property-change beg property s end))
(spec (get-text-property beg property s))
(value
(pcase property
(`invisible
;; If `invisible' property means text is to be
;; invisible, return 0. Otherwise return nil so as
;; to resume search.
(and (or (eq t buffer-invisibility-spec)
(assoc-string spec buffer-invisibility-spec))
0))
(`display
(pcase spec
(`nil nil)
(`(space . ,props)
(let ((width (plist-get props :width)))
(and (wholenump width) width)))
(`(image . ,_)
(and (fboundp 'image-size)
(ceiling (car (image-size spec)))))
((pred stringp)
;; Displayed string could contain invisible parts,
;; but no nested display.
(org--string-from-props spec 'invisible 0 (length spec)))
(_
;; Un-handled `display' value. Ignore it.
;; Consider the original string instead.
nil)))
(_ (error "Unknown property: %S" property)))))
(when value
(cl-incf width
;; When looking for `display' parts, we still need
;; to look for `invisible' property elsewhere.
(+ (cond ((eq property 'display)
(org--string-from-props s 'invisible cursor beg))
((= cursor beg) 0)
(t (string-width (substring s cursor beg))))
value))
(setq cursor next))
(setq beg next)))
(+ width
;; Look for `invisible' property in the last part of the
;; string. See above.
(cond ((eq property 'display)
(org--string-from-props s 'invisible cursor end))
((= cursor end) 0)
(t (string-width (substring s cursor end)))))))
(defun org--string-width-1 (string)
"Return width of STRING when displayed in the current buffer.
Unlike `string-width', this function takes into consideration
`invisible' and `display' text properties. It supports the
latter in a limited way, mostly for combinations used in Org.
Results may be off sometimes if it cannot handle a given
`display' value."
(org--string-from-props string 'display 0 (length string)))
(defun org-string-width (string &optional pixels default-face)
"Return width of STRING when displayed in the current buffer.
Return width in pixels when PIXELS is non-nil.
When PIXELS is nil, DEFAULT-FACE is the face used to calculate relative
STRING width. When REFERENCE-FACE is nil, `default' face is used."
(if (and (version< emacs-version "28") (not pixels))
;; FIXME: Fallback to old limited version, because
;; `window-pixel-width' is buggy in older Emacs.
(org--string-width-1 string)
;; Wrap/line prefix will make `window-text-pixel-size' return too
;; large value including the prefix.
(setq string (copy-sequence string)) ; do not modify STRING object
(remove-text-properties 0 (length string)
'(wrap-prefix t line-prefix t)
string)
;; Face should be removed to make sure that all the string symbols
;; are using default face with constant width. Constant char width
;; is critical to get right string width from pixel width (not needed
;; when PIXELS are requested though).
(unless pixels
(put-text-property 0 (length string) 'face (or default-face 'default) string))
(let (;; We need to remove the folds to make sure that folded table
;; alignment is not messed up.
(current-invisibility-spec
(or (and (not (listp buffer-invisibility-spec))
buffer-invisibility-spec)
(let (result)
(dolist (el buffer-invisibility-spec)
(unless (or (memq el
'(org-fold-drawer
org-fold-block
org-fold-outline))
(and (listp el)
(memq (car el)
'(org-fold-drawer
org-fold-block
org-fold-outline))))
(push el result)))
result)))
(current-char-property-alias-alist char-property-alias-alist))
(with-current-buffer (get-buffer-create " *Org string width*")
(setq-local display-line-numbers nil)
(setq-local line-prefix nil)
(setq-local wrap-prefix nil)
(setq-local buffer-invisibility-spec
(if (listp current-invisibility-spec)
(mapcar (lambda (el)
;; Consider ellipsis to have 0 width.
;; It is what Emacs 28+ does, but we have
;; to force it in earlier Emacs versions.
(if (and (consp el) (cdr el))
(list (car el))
el))
current-invisibility-spec)
current-invisibility-spec))
(setq-local char-property-alias-alist
current-char-property-alias-alist)
(let (pixel-width symbol-width)
(with-silent-modifications
(erase-buffer)
(insert string)
(setq pixel-width (org-buffer-text-pixel-width))
(unless pixels
(erase-buffer)
(insert (propertize "a" 'face (or default-face 'default)))
(setq symbol-width (org-buffer-text-pixel-width))))
(if pixels
pixel-width
(ceiling pixel-width symbol-width)))))))
(defmacro org-current-text-column ()
"Like `current-column' but ignore display properties.
Throw an error when `tab-width' is not 8.
This function forces `tab-width' value because it is used as a part of
the parser, to ensure parser consistency when calculating list
indentation."
`(progn
(unless (= 8 tab-width)
(org--set-tab-width)
(warning "Tab width in Org files must be 8, not %d. Setting back to 8. Please adjust your `tab-width' settings for Org mode" tab-width))
(string-width (buffer-substring-no-properties
(line-beginning-position) (point)))))
(defun org-not-nil (v)
"If V not nil, and also not the string \"nil\", then return V.
Otherwise return nil."
(and v (not (equal v "nil")) v))
(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. Return the new string. If STRING is nil, return nil."
(declare (indent 2))
(and string
(if (and (string-prefix-p pre string)
(string-suffix-p post string))
(substring string (length pre)
(and (not (string-equal "" post)) (- (length post))))
string)))
(defun org-strip-quotes (string)
"Strip double quotes from around STRING, if applicable.
If STRING is nil, return nil."
(org-unbracket-string "\"" "\"" string))
(defsubst org-current-line-string (&optional to-here)
"Return current line, as a string.
If optional argument TO-HERE is non-nil, return string from
beginning of line up to point."
(buffer-substring (line-beginning-position)
(if to-here (point) (line-end-position))))
(defun org-shorten-string (s maxlength)
"Shorten string S so that it is no longer than MAXLENGTH characters.
If the string is shorter or has length MAXLENGTH, just return the
original string. If it is longer, the functions finds a space in the
string, breaks this string off at that locations and adds three dots
as ellipsis. Including the ellipsis, the string will not be longer
than MAXLENGTH. If finding a good breaking point in the string does
not work, the string is just chopped off in the middle of a word
if necessary."
(if (<= (length s) maxlength)
s
(let* ((n (max (- maxlength 4) 1))
(re (concat "\\`\\(.\\{1," (number-to-string n)
"\\}[^ ]\\)\\([ ]\\|\\'\\)")))
(if (string-match re s)
(concat (match-string 1 s) "...")
(concat (substring s 0 (max (- maxlength 3) 0)) "...")))))
(defun org-remove-tabs (s &optional width)
"Replace tabulators in S with spaces.
Assumes that s is a single line, starting in column 0."
(setq width (or width tab-width))
(while (string-match "\t" s)
(setq s (replace-match
(make-string
(- (* width (/ (+ (match-beginning 0) width) width))
(match-beginning 0)) ?\ )
t t s)))
s)
(defun org-remove-blank-lines (s)
"Remove blank lines in S."
(replace-regexp-in-string (rx "\n" (1+ (0+ space) "\n")) "\n" s))
(defun org-wrap (string &optional width lines)
"Wrap string to either a number of lines, or a width in characters.
If WIDTH is non-nil, the string is wrapped to that width, however many lines
that costs. If there is a word longer than WIDTH, the text is actually
wrapped to the length of that word.
IF WIDTH is nil and LINES is non-nil, the string is forced into at most that
many lines, whatever width that takes.
The return value is a list of lines, without newlines at the end."
(let* ((words (split-string string))
(maxword (apply #'max (mapcar #'org-string-width words)))
w ll)
(cond (width
(org--do-wrap words (max maxword width)))
(lines
(setq w maxword)
(setq ll (org--do-wrap words maxword))
(if (<= (length ll) lines)
ll
(setq ll words)
(while (> (length ll) lines)
(setq w (1+ w))
(setq ll (org--do-wrap words w)))
ll))
(t (error "Cannot wrap this")))))
(defun org--do-wrap (words width)
"Create lines of maximum width WIDTH (in characters) from word list WORDS."
(let (lines line)
(while words
(setq line (pop words))
(while (and words (< (+ (length line) (length (car words))) width))
(setq line (concat line " " (pop words))))
(setq lines (push line lines)))
(nreverse lines)))
(defun org-remove-indentation (code &optional n)
"Remove maximum common indentation in string CODE and return it.
N may optionally be the number of columns to remove. Return CODE
as-is if removal failed."
(with-temp-buffer
(insert code)
(if (org-do-remove-indentation n) (buffer-string) code)))
(defun org-fill-template (template alist)
"Find each %key of ALIST in TEMPLATE and replace it."
(let ((case-fold-search nil))
(dolist (entry (sort (copy-sequence alist)
; Sort from longest key to shortest, so that
; "noweb-ref" and "tangle-mode" get processed
; before "noweb" and "tangle", respectively.
(lambda (a b) (< (length (car b)) (length (car a))))))
(setq template
(replace-regexp-in-string
(concat "%" (regexp-quote (car entry)))
(or (cdr entry) "") template t t)))
template))
(defun org-replace-escapes (string table)
"Replace %-escapes in STRING with values in TABLE.
TABLE is an association list with keys like \"%a\" and string values.
The sequences in STRING may contain normal field width and padding information,
for example \"%-5s\". Replacements happen in the sequence given by TABLE,
so values can contain further %-escapes if they are define later in TABLE."
(let ((tbl (copy-alist table))
(case-fold-search nil)
(pchg 0)
re rpl)
(dolist (e tbl)
(setq re (concat "%-?[0-9.]*" (substring (car e) 1)))
(when (and (cdr e) (string-match re (cdr e)))
(let ((sref (substring (cdr e) (match-beginning 0) (match-end 0)))
(safe (copy-sequence "SREF")))
(add-text-properties 0 3 (list 'sref sref) safe)
(setcdr e (replace-match safe t t (cdr e)))))
(while (string-match re string)
(setq rpl (format (concat (substring (match-string 0 string) 0 -1) "s")
(cdr e)))
(setq string (replace-match rpl t t string))))
(while (setq pchg (next-property-change pchg string))
(let ((sref (get-text-property pchg 'sref string)))
(when (and sref (string-match "SREF" string pchg))
(setq string (replace-match sref t t string)))))
string))
;;; Text properties
(defconst org-rm-props '(invisible t face t keymap t intangible t mouse-face t
rear-nonsticky t mouse-map t fontified t
org-emphasis t)
"Properties to remove when a string without properties is wanted.")
(defun org-buffer-substring-fontified (beg end)
"Return fontified region between BEG and END."
(when (bound-and-true-p jit-lock-mode)
(when (text-property-not-all beg end 'fontified t)
(save-excursion (save-match-data (font-lock-fontify-region beg end)))))
(buffer-substring beg end))
(defun org-looking-at-fontified (re)
"Call `looking-at' RE and make sure that the match is fontified."
(prog1 (looking-at re)
(when (bound-and-true-p jit-lock-mode)
(when (text-property-not-all
(match-beginning 0) (match-end 0)
'fontified t)
(save-excursion
(save-match-data
(font-lock-fontify-region (match-beginning 0)
(match-end 0))))))))
(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 restricted (remove-text-properties 0 (length s) org-rm-props s)
(set-text-properties 0 (length s) nil s))
s)
(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
that will be added to PLIST. Returns the string that was modified."
(declare (indent 2))
(add-text-properties
0 (length string) (if props (append plist props) plist) string)
string)
(defun org-make-parameter-alist (plist)
"Return alist based on PLIST.
PLIST is a property list with alternating symbol names and values.
The returned alist is a list of lists with the symbol name in `car'
and the value in `cadr'."
(when plist
(cons (list (car plist) (cadr plist))
(org-make-parameter-alist (cddr plist)))))
(defsubst org-get-at-bol (property)
"Get text property PROPERTY at the beginning of line."
(get-text-property (line-beginning-position) property))
(defun org-get-at-eol (property n)
"Get text property PROPERTY at the end of line less N characters."
(get-text-property (- (line-end-position) n) property))
(defun org-find-text-property-in-string (prop s)
"Return the first non-nil value of property PROP in string S."
(or (get-text-property 0 prop s)
(get-text-property (or (next-single-property-change 0 prop s) 0)
prop s)))
;; FIXME: move to org-fold?
(defun org-invisible-p (&optional pos folding-only)
"Non-nil if the character after POS is invisible.
If POS is nil, use `point' instead. When optional argument
FOLDING-ONLY is non-nil, only consider invisible parts due to
folding of a headline, a block or a drawer, i.e., not because of
fontification."
(let ((value (invisible-p (or pos (point)))))
(cond ((not value) nil)
(folding-only (org-fold-folded-p (or pos (point))))
(t value))))
(defun org-truly-invisible-p ()
"Check if point is at a character currently not visible.
This version does not only check the character property, but also
`visible-mode'."
(unless (bound-and-true-p visible-mode)
(org-invisible-p)))
(defun org-invisible-p2 ()
"Check if point is at a character currently not visible.
If the point is at EOL (and not at the beginning of a buffer too),
move it back by one char before doing this check."
(save-excursion
(when (and (eolp) (not (bobp)))
(backward-char 1))
(org-invisible-p)))
(defun org-region-invisible-p (beg end)
"Check if region if completely hidden."
(org-with-wide-buffer
(and (org-invisible-p beg)
(org-invisible-p (org-fold-next-visibility-change beg end)))))
(defun org-find-visible ()
"Return closest visible buffer position, or `point-max'."
(if (org-invisible-p)
(org-fold-next-visibility-change (point))
(point)))
(defun org-find-invisible ()
"Return closest invisible buffer position, or `point-max'."
(if (org-invisible-p)
(point)
(org-fold-next-visibility-change (point))))
;;; Time
(defun org-2ft (s)
"Convert S to a floating point time.
If S is already a number, just return it. If it is a string,
parse it as a time string and apply `float-time' to it. If S is
nil, just return 0."
(cond
((numberp s) s)
((stringp s)
(condition-case nil
(org-time-string-to-seconds s)
(error 0)))
(t 0)))
(defun org-time= (a b)
(let ((a (org-2ft a))
(b (org-2ft b)))
(and (> a 0) (> b 0) (= a b))))
(defun org-time< (a b)
(let ((a (org-2ft a))
(b (org-2ft b)))
(and (> a 0) (> b 0) (< a b))))
(defun org-time<= (a b)
(let ((a (org-2ft a))
(b (org-2ft b)))
(and (> a 0) (> b 0) (<= a b))))
(defun org-time> (a b)
(let ((a (org-2ft a))
(b (org-2ft b)))
(and (> a 0) (> b 0) (> a b))))
(defun org-time>= (a b)
(let ((a (org-2ft a))
(b (org-2ft b)))
(and (> a 0) (> b 0) (>= a b))))
(defun org-time<> (a b)
(let ((a (org-2ft a))
(b (org-2ft b)))
(and (> a 0) (> b 0) (\= a b))))
(defmacro org-encode-time (&rest time)
"Compatibility and convenience helper for `encode-time'.
TIME may be a 9 components list (SECONDS ... YEAR IGNORED DST ZONE)
as the recommended way since Emacs-27 or 6 or 9 separate arguments
similar to the only possible variant for Emacs-26 and earlier.
6 elements list as the only argument causes wrong type argument till
Emacs-29.
Warning: use -1 for DST to guess the actual value, nil means no
daylight saving time and may be wrong at particular time.
DST value is ignored prior to Emacs-27. Since Emacs-27 DST value matters
even when multiple arguments is passed to this macro and such
behavior is different from `encode-time'. See
Info node `(elisp)Time Conversion' for details and caveats,
preferably the latest version."
(if (version< emacs-version "27.1")
(if (cdr time)
`(encode-time ,@time)
`(apply #'encode-time ,@time))
(if (ignore-errors (with-no-warnings (encode-time '(0 0 0 1 1 1971))))
(pcase (length time) ; Emacs-29 since d75e2c12eb
(1 `(encode-time ,@time))
((or 6 9) `(encode-time (list ,@time)))
(_ (error "`org-encode-time' may be called with 1, 6, or 9 arguments but %d given"
(length time))))
(pcase (length time)
(1 `(encode-time ,@time))
(6 `(encode-time (list ,@time nil -1 nil)))
(9 `(encode-time (list ,@time)))
(_ (error "`org-encode-time' may be called with 1, 6, or 9 arguments but %d given"
(length time)))))))
(defun org-parse-time-string (s &optional nodefault)
"Parse Org time string S.
If time is not given, defaults to 0:00. However, with optional
NODEFAULT, hour and minute fields are nil if not given.
Throw an error if S does not contain a valid Org time string.
Note that the first match for YYYY-MM-DD will be used (e.g.,
\"-52000-02-03\" will be taken as \"2000-02-03\").
This should be a lot faster than the `parse-time-string'."
(unless (string-match org-ts-regexp0 s)
(error "Not an Org time string: %s" s))
(list 0
(cond ((match-beginning 8) (string-to-number (match-string 8 s)))
(nodefault nil)
(t 0))
(cond ((match-beginning 7) (string-to-number (match-string 7 s)))
(nodefault nil)
(t 0))
(string-to-number (match-string 4 s))
(string-to-number (match-string 3 s))
(string-to-number (match-string 2 s))
nil -1 nil))
(defun org-matcher-time (s)
"Interpret a time comparison value S as a floating point time.
S can be an Org time stamp, a modifier, e.g., \"<+2d>\", or the
following special strings: \"<now>\", \"<today>\",
\"<tomorrow>\", and \"<yesterday>\".
Return 0. if S is not recognized as a valid value."
(let ((today (float-time (org-encode-time
(append '(0 0 0) (nthcdr 3 (decode-time)))))))
(save-match-data
(cond
((string= s "<now>") (float-time))
((string= s "<today>") today)
((string= s "<tomorrow>") (+ 86400.0 today))
((string= s "<yesterday>") (- today 86400.0))
((string-match "\\`<\\([-+][0-9]+\\)\\([hdwmy]\\)>\\'" s)
(+ (if (string= (match-string 2 s) "h") (float-time) today)
(* (string-to-number (match-string 1 s))
(cdr (assoc (match-string 2 s)
'(("h" . 3600.0)
("d" . 86400.0) ("w" . 604800.0)
("m" . 2678400.0) ("y" . 31557600.0)))))))
((string-match org-ts-regexp0 s) (org-2ft s))
(t 0.)))))
;;; Misc
(defun org-scroll (key &optional additional-keys)
"Receive KEY and scroll the current window accordingly.
When ADDITIONAL-KEYS is not nil, also include SPC and DEL in the
allowed keys for scrolling, as expected in the export dispatch
window."
(let ((scrlup (if additional-keys '(?\s ?\C-v) ?\C-v))
(scrldn (if additional-keys `(?\d ?\M-v) ?\M-v)))
(pcase key
(?\C-n (if (not (pos-visible-in-window-p (point-max)))
(ignore-errors (scroll-up 1))
(message "End of buffer")
(sit-for 1)))
(?\C-p (if (not (pos-visible-in-window-p (point-min)))
(ignore-errors (scroll-down 1))
(message "Beginning of buffer")
(sit-for 1)))
;; SPC or
((guard (memq key scrlup))
(if (not (pos-visible-in-window-p (point-max)))
(scroll-up nil)
(message "End of buffer")
(sit-for 1)))
;; DEL
((guard (memq key scrldn))
(if (not (pos-visible-in-window-p (point-min)))
(scroll-down nil)
(message "Beginning of buffer")
(sit-for 1))))))
(cl-defun org-knuth-hash (number &optional (base 32))
"Calculate Knuth's multiplicative hash for NUMBER.
BASE is the maximum bitcount.
Credit: https://stackoverflow.com/questions/11871245/knuth-multiplicative-hash#41537995"
(cl-assert (and (<= 0 base 32)))
(ash (* number 2654435769) (- base 32)))
(defvar org-sxhash-hashes (make-hash-table :weakness 'key :test 'equal))
(defvar org-sxhash-objects (make-hash-table :weakness 'value))
(defun org-sxhash-safe (obj &optional counter)
"Like `sxhash' for OBJ, but collision-free for in-memory objects.
When COUNTER is non-nil, return safe hash for (COUNTER . OBJ)."
;; Note: third-party code may modify OBJ by side effect.
;; Should not affect anything as long as `org-sxhash-safe'
;; is used to calculate hash.
(or (and (not counter) (gethash obj org-sxhash-hashes))
(let* ((hash (sxhash (if counter (cons counter obj) obj)))
(obj-old (gethash hash org-sxhash-objects)))
(if obj-old ; collision
(org-sxhash-safe obj (if counter (1+ counter) 1))
;; No collision. Remember and return normal hash.
(puthash hash obj org-sxhash-objects)
(puthash obj hash org-sxhash-hashes)))))
(defun org-compile-file (source process ext &optional err-msg log-buf spec)
"Compile a SOURCE file using PROCESS.
See `org-compile-file-commands' for information on PROCESS, EXT, and SPEC.
If PROCESS fails, an error will be raised. The error message can
then be refined by providing string ERR-MSG, which is appended to
the standard message.
PROCESS must create a file with the same base name and directory
as SOURCE, but ending with EXT. The function then returns its
filename. Otherwise, it raises an error.
When PROCESS is a list of commands, optional argument LOG-BUF can
be set to a buffer or a buffer name. `shell-command' then uses
it for output."
(let* ((commands (org-compile-file-commands source process ext spec err-msg))
(output (concat (file-name-sans-extension source) "." ext))
;; Resolve symlinks in default-directory to correctly handle
;; absolute source paths or relative paths with ..
(relname (if (file-name-absolute-p source)
(let ((pwd (file-truename default-directory)))
(file-relative-name source pwd))
source))
(log-buf (and log-buf (get-buffer-create log-buf)))
(time (file-attribute-modification-time (file-attributes output))))
(save-window-excursion
(dolist (command commands)
(cond
((functionp command)
(funcall command (shell-quote-argument relname)))
((stringp command)
(let ((shell-command-dont-erase-buffer t))
(shell-command command log-buf))))))
;; Check for process failure. Output file is expected to be
;; located in the same directory as SOURCE.
(unless (org-file-newer-than-p output time)
(ignore (defvar org-batch-test))
;; Display logs when running tests.
(when (bound-and-true-p org-batch-test)
(message "org-compile-file log ::\n-----\n%s\n-----\n"
(with-current-buffer log-buf (buffer-string))))
(error
(format
"File %S wasn't produced%s"
output
(if (org-string-nw-p err-msg)
(concat " " (org-trim err-msg))
err-msg))))
output))
(defun org-compile-file-commands (source process ext &optional spec err-msg)
"Return list of commands used to compile SOURCE file.
The commands are formed from PROCESS, which is either a function or
a list of shell commands, as strings. EXT is a file extension, without
the leading dot, as a string. After PROCESS has been executed,
a file with the same basename and directory as SOURCE but with the
file extension EXT is expected to be produced.
Failure to produce this file will be interpreted as PROCESS failing.
If PROCESS is a function, it is called with a single argument:
the SOURCE file.
If PROCESS is a list of commands, each of them is called using
`shell-command'. By default, in each command, %b, %f, %F, %o and
%O are replaced with, respectively, SOURCE base name, relative
file name, absolute file name, relative directory and absolute
output file name. It is possible, however, to use more
place-holders by specifying them in optional argument SPEC, as an
alist following the pattern
(CHARACTER . REPLACEMENT-STRING).
Throw an error if PROCESS does not satisfy the described patterns.
The error string will be appended with ERR-MSG, when it is a string."
(let* ((basename (file-name-base source))
;; Resolve symlinks in default-directory to correctly handle
;; absolute source paths or relative paths with ..
(pwd (file-truename default-directory))
(absname (expand-file-name source pwd))
(relname (if (file-name-absolute-p source)
(file-relative-name source pwd)
source))
(relpath (or (file-name-directory relname) "./"))
(output (concat (file-name-sans-extension absname) "." ext))
(err-msg (if (stringp err-msg) (concat ". " err-msg) "")))
(pcase process
((pred functionp) (list process))
((pred consp)
(let ((spec (append spec
`((?b . ,(shell-quote-argument basename))
(?f . ,(shell-quote-argument relname))
(?F . ,(shell-quote-argument absname))
(?o . ,(shell-quote-argument relpath))
(?O . ,(shell-quote-argument output))))))
(mapcar (lambda (command) (format-spec command spec)) process)))
(_ (error "No valid command to process %S%s" source err-msg)))))
(defun org-display-buffer-split (buffer alist)
"Display BUFFER in the current frame split in two parts.
The frame will display two buffers - current buffer and BUFFER.
ALIST is an association list of action symbols and values. See
Info node `(elisp) Buffer Display Action Alists' for details of
such alists.
Use `display-buffer-in-direction' internally.
This is an action function for buffer display, see Info
node `(elisp) Buffer Display Action Functions'. It should be
called only by `display-buffer' or a function directly or
indirectly called by the latter."
(let ((window-configuration (current-window-configuration)))
(ignore-errors (delete-other-windows))
(or (display-buffer-in-direction buffer alist)
(display-buffer-pop-up-window buffer alist)
(prog1 nil
(set-window-configuration window-configuration)))))
(defun org-display-buffer-in-window (buffer alist)
"Display BUFFER in specific window.
The window is defined according to the `window' slot in the ALIST.
Then `same-frame' slot in the ALIST is set, only display buffer when
window is present in the current frame.
This is an action function for buffer display, see Info
node `(elisp) Buffer Display Action Functions'. It should be
called only by `display-buffer' or a function directly or
indirectly called by the latter."
(let ((window (alist-get 'window alist)))
(when (and window
(window-live-p window)
(or (not (alist-get 'same-frame alist))
(eq (window-frame) (window-frame window))))
(window--display-buffer buffer window 'reuse alist))))
(provide 'org-macs)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; org-macs.el ends here
org-mode-9.7.29+dfsg/lisp/org-mobile.el 0000664 0000000 0000000 00000124047 15004304337 0017606 0 ustar 00root root 0000000 0000000 ;;; org-mobile.el --- Code for Asymmetric Sync With a Mobile Device -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2025 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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 <https://www.gnu.org/licenses/>.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;; This file contains the code to interact with a mobile application,
;; such as Richard Moreland's iPhone application MobileOrg, or the
;; Android version by Matthew Jones. This code is documented in
;; Appendix B of the Org manual. The code is not specific for the
;; iPhone and Android - any external viewer/flagging/editing
;; application that uses the same conventions could be used.
(require 'org-macs)
(org-assert-version)
(require 'cl-lib)
(require 'org)
(require 'org-agenda)
(require 'ol)
;;; Code:
(defgroup org-mobile nil
"Options concerning support for a viewer/editor on a mobile device."
:tag "Org Mobile"
:group 'org)
(defcustom org-mobile-files '(org-agenda-files)
"Files to be staged for the mobile application.
This is basically a list of files and directories. Files will be staged
directly. Directories will be search for files with the extension \".org\".
In addition to this, the list may also contain the following symbols:
`org-agenda-files'
This means include the complete, unrestricted list of files given in
the variable `org-agenda-files'.
`org-agenda-text-search-extra-files'
Include the files given in the variable
`org-agenda-text-search-extra-files'."
:group 'org-mobile
:type '(list :greedy t
(option (const :tag "org-agenda-files" org-agenda-files))
(option (const :tag "org-agenda-text-search-extra-files"
org-agenda-text-search-extra-files))
(repeat :inline t :tag "Additional files"
(file))))
(defcustom org-mobile-files-exclude-regexp ""
"A regexp to exclude files from `org-mobile-files'."
:group 'org-mobile
:version "24.1"
:type 'regexp)
(defcustom org-mobile-directory ""
"The WebDAV directory where the interaction with the mobile takes place."
:group 'org-mobile
:type 'directory)
(defcustom org-mobile-allpriorities "A B C"
"Default set of priority cookies for the index file."
:version "24.4"
:package-version '(Org . "8.0")
:type 'string
:group 'org-mobile)
(defcustom org-mobile-use-encryption nil
"Non-nil means keep only encrypted files on the WebDAV server.
Encryption uses AES-256, with a password given in
`org-mobile-encryption-password'. When nil, plain files are kept
on the server.
Turning on encryption requires setting the same password in the
mobile application. Before turning this on, check if the mobile
application does support it."
:group 'org-mobile
:version "24.1"
:type 'boolean)
(defcustom org-mobile-encryption-tempfile "~/orgtmpcrypt"
"File that is being used as a temporary file for encryption.
This must be local file on your local machine (not on the WebDAV server).
You might want to put this file into a directory where only you have access."
:group 'org-mobile
:version "24.1"
:type 'directory)
(defcustom org-mobile-encryption-password ""
"Password for encrypting files uploaded to the server.
This is a single password which is used for AES-256 encryption. The same
password must also be set in the mobile application. All Org files,
including \"mobileorg.org\" will be encrypted using this password.
SECURITY CONSIDERATIONS:
Note that, when Org runs the encryption commands, the password could
be visible briefly on your system with the `ps' command. So this method is
only intended to keep the files secure on the server, not on your own machine.
Also, if you set this variable in an init file (.emacs or .emacs.d/init.el
or custom.el...) and if that file is stored in a way so that other can read
it, this also limits the security of this approach. You can also leave
this variable empty - Org will then ask for the password once per Emacs
session."
:group 'org-mobile
:version "24.1"
:type '(string :tag "Password"))
(defvar org-mobile-encryption-password-session nil)
(defun org-mobile-encryption-password ()
(or (org-string-nw-p org-mobile-encryption-password)
(org-string-nw-p org-mobile-encryption-password-session)
(setq org-mobile-encryption-password-session
(read-passwd "Password for mobile application: " t))))
(defcustom org-mobile-inbox-for-pull "~/org/from-mobile.org"
"The file where captured notes and flags will be appended to.
During the execution of `org-mobile-pull', the file
`org-mobile-capture-file' is emptied as soon as its contents have
been appended to the file given here. This file should be in
`org-directory', and not in the staging area or on the web server."
:group 'org-mobile
:type 'file)
(defconst org-mobile-capture-file "mobileorg.org"
"The capture file where the mobile stores captured notes and flags.
This must not be changed, because the mobile application assumes this name.")
(defcustom org-mobile-index-file "index.org"
"Index file with links to all Org files.
It should be loaded by the mobile application. The file name is
relative to `org-mobile-directory'. The \"Address\" field in the
mobile application setup should point to this file."
:group 'org-mobile
:type 'file)
(defcustom org-mobile-agendas 'all
"The agendas that should be pushed to the mobile application.
Allowed values:
`default' the weekly agenda and the global TODO list
`custom' all custom agendas defined by the user
`all' the custom agendas and the default ones
`list' a list of selection key(s) as string."
:group 'org-mobile
:version "24.1"
:type '(choice
(const :tag "Default Agendas" default)
(const :tag "Custom Agendas" custom)
(const :tag "Default and Custom Agendas" all)
(repeat :tag "Selected"
(string :tag "Selection Keys"))))
(defcustom org-mobile-force-id-on-agenda-items t
"Non-nil means make all agenda items carry an ID."
:group 'org-mobile
:type 'boolean)
(defcustom org-mobile-force-mobile-change nil
"Non-nil means force the change made on the mobile device.
So even if there have been changes to the computer version of the entry,
force the new value set on the mobile.
When nil, mark the entry from the mobile with an error message.
Instead of nil or t, this variable can also be a list of symbols, indicating
the editing types for which the mobile version should always dominate."
:group 'org-mobile
:type '(choice
(const :tag "Always" t)
(const :tag "Never" nil)
(set :greedy t :tag "Specify"
(const todo)
(const tags)
(const priority)
(const heading)
(const body))))
(defcustom org-mobile-checksum-binary (or (executable-find "shasum")
(executable-find "sha1sum")
(executable-find "md5sum")
(executable-find "md5"))
"Executable used for computing checksums of agenda files."
:group 'org-mobile
:type 'string)
(defvar org-mobile-pre-push-hook nil
"Hook run before running `org-mobile-push'.
This could be used to clean up `org-mobile-directory', for example to
remove files that used to be included in the agenda but no longer are.
The presence of such files would not really be a problem, but after time
they may accumulate.")
(defvar org-mobile-post-push-hook nil
"Hook run after running `org-mobile-push'.
If Emacs does not have direct write access to the WebDAV directory used
by the mobile device, this hook should be used to copy all files from the
local staging directory `org-mobile-directory' to the WebDAV directory,
for example using `rsync' or `scp'.")
(defvar org-mobile-pre-pull-hook nil
"Hook run before executing `org-mobile-pull'.
If Emacs does not have direct write access to the WebDAV directory used
by the mobile device, this hook should be used to copy the capture file
`mobileorg.org' from the WebDAV location to the local staging
directory `org-mobile-directory'.")
(defvar org-mobile-post-pull-hook nil
"Hook run after running `org-mobile-pull', only if new items were found.
If Emacs does not have direct write access to the WebDAV directory used
by the mobile device, this hook should be used to copy the emptied
capture file `mobileorg.org' back to the WebDAV directory, for example
using `rsync' or `scp'.")
(defconst org-mobile-action-alist '(("edit" . org-mobile-edit))
"Alist with flags and actions for mobile sync.
When flagging an entry, the mobile application creates entries
that look like
* F(action:data) [[id:entry-id][entry title]]
This alist defines that the ACTION in the parentheses of F()
should mean, i.e. what action should be taken. The :data part in
the parenthesis is optional. If present, the string after the
colon will be passed to the action function as the first argument
variable.
The car of each elements of the alist is an actions string. The
cdr is a function that is called with the cursor on the headline
of that entry. It should accept three arguments, the :data part,
the old and new values for the entry.")
(defvar org-mobile-last-flagged-files nil
"List of files containing entries flagged in the latest pull.")
(defvar org-mobile-files-alist nil)
(defvar org-mobile-checksum-files nil)
;; Add org mobile commands to the main org menu
(easy-menu-add-item
org-org-menu
nil
'("MobileOrg"
["Push Files and Views" org-mobile-push t]
["Get Captured and Flagged" org-mobile-pull t]
["Find FLAGGED Tasks" (org-agenda nil "?") :active t :keys "\\[org-agenda] ?"]
"--"
["Setup" (customize-group 'org-mobile) t]))
(defun org-mobile-prepare-file-lists ()
(setq org-mobile-files-alist (org-mobile-files-alist))
(setq org-mobile-checksum-files nil))
(defun org-mobile-files-alist ()
"Expand the list in `org-mobile-files' to a list of existing files.
Also exclude files matching `org-mobile-files-exclude-regexp'."
(let* ((include-archives
(and (member 'org-agenda-text-search-extra-files org-mobile-files)
(member 'agenda-archives org-agenda-text-search-extra-files)
t))
(files
(apply 'append
(mapcar
(lambda (f)
(cond
((eq f 'org-agenda-files)
(org-agenda-files t include-archives))
((eq f 'org-agenda-text-search-extra-files)
(delq 'agenda-archives
(copy-sequence
org-agenda-text-search-extra-files)))
((and (stringp f) (file-directory-p f))
(directory-files f 'full "\\.org\\'"))
((and (stringp f) (file-exists-p f))
(list f))
(t nil)))
org-mobile-files)))
(files (delq
nil
(mapcar (lambda (f)
(unless (and (not (string= org-mobile-files-exclude-regexp ""))
(string-match org-mobile-files-exclude-regexp f))
(identity f)))
files)))
(orgdir-uname (file-name-as-directory (file-truename org-directory)))
(orgdir-re (concat "\\`" (regexp-quote orgdir-uname)))
uname seen rtn file link-name)
;; Make the files unique, and determine the name under which they will
;; be listed.
(while (setq file (pop files))
(if (not (file-name-absolute-p file))
(setq file (expand-file-name file org-directory)))
(setq uname (file-truename file))
(unless (member uname seen)
(push uname seen)
(if (string-match orgdir-re uname)
(setq link-name (substring uname (match-end 0)))
(setq link-name (file-name-nondirectory uname)))
(push (cons file link-name) rtn)))
(nreverse rtn)))
;;;###autoload
(defun org-mobile-push ()
"Push the current state of Org affairs to the target directory.
This will create the index file, copy all agenda files there, and also
create all custom agenda views, for upload to the mobile phone."
(interactive)
(let ((org-agenda-buffer-name "*SUMO*")
(org-agenda-tag-filter org-agenda-tag-filter)
(org-agenda-redo-command org-agenda-redo-command))
;; Offer to save agenda-related buffers before pushing, preventing
;; "Non-existent agenda file" prompt for lock files (see #19448).
(let ((agenda-buffers (org-buffer-list 'agenda)))
(save-some-buffers nil
(lambda () (memq (current-buffer) agenda-buffers))))
(save-excursion
(save-restriction
(save-window-excursion
(run-hooks 'org-mobile-pre-push-hook)
(org-mobile-check-setup)
(org-mobile-prepare-file-lists)
(message "Creating agendas...")
(let ((inhibit-redisplay t)
(org-agenda-files (mapcar 'car org-mobile-files-alist)))
(org-mobile-create-sumo-agenda))
(message "Creating agendas...done")
(org-save-all-org-buffers) ; to save any IDs created by this process
(message "Copying files...")
(org-mobile-copy-agenda-files)
(message "Writing index file...")
(org-mobile-create-index-file)
(message "Writing checksums...")
(org-mobile-write-checksums)
(run-hooks 'org-mobile-post-push-hook)))))
(org-agenda-maybe-redo)
(message "Files for mobile viewer staged"))
(defvar org-mobile-before-process-capture-hook nil
"Hook that is run after content was moved to `org-mobile-inbox-for-pull'.
The inbox file is visited by the current buffer, and the buffer is
narrowed to the newly captured data.")
;;;###autoload
(defun org-mobile-pull ()
"Pull the contents of `org-mobile-capture-file' and integrate them.
Apply all flagged actions, flag entries to be flagged and then call an
agenda view showing the flagged items."
(interactive)
(org-mobile-check-setup)
(run-hooks 'org-mobile-pre-pull-hook)
(let ((insertion-marker (org-mobile-move-capture)))
(if (not (markerp insertion-marker))
(message "No new items")
(org-with-point-at insertion-marker
(save-restriction
(narrow-to-region (point) (point-max))
(run-hooks 'org-mobile-before-process-capture-hook)))
(org-with-point-at insertion-marker
(org-mobile-apply (point) (point-max)))
(move-marker insertion-marker nil)
(run-hooks 'org-mobile-post-pull-hook)
(when org-mobile-last-flagged-files
;; Make an agenda view of flagged entries, but only in the files
;; where stuff has been added.
(put 'org-agenda-files 'org-restrict org-mobile-last-flagged-files)
(let ((org-agenda-keep-restricted-file-list t))
(org-agenda nil "?"))))))
(defun org-mobile-check-setup ()
"Check if `org-mobile-directory' has been set up."
(org-mobile-cleanup-encryption-tempfile)
(unless (and org-directory
(stringp org-directory)
(string-match "\\S-" org-directory)
(file-exists-p org-directory)
(file-directory-p org-directory))
(error
"Please set `org-directory' to the directory where your org files live"))
(unless (and org-mobile-directory
(stringp org-mobile-directory)
(string-match "\\S-" org-mobile-directory)
(file-exists-p org-mobile-directory)
(file-directory-p org-mobile-directory))
(error
"Variable `org-mobile-directory' must point to an existing directory"))
(unless (and org-mobile-inbox-for-pull
(stringp org-mobile-inbox-for-pull)
(string-match "\\S-" org-mobile-inbox-for-pull)
(file-exists-p
(file-name-directory org-mobile-inbox-for-pull)))
(error
"Variable `org-mobile-inbox-for-pull' must point to a file in an existing directory"))
(unless (and org-mobile-checksum-binary
(string-match "\\S-" org-mobile-checksum-binary))
(error "No executable found to compute checksums"))
(when org-mobile-use-encryption
(unless (string-match "\\S-" (org-mobile-encryption-password))
(error
"To use encryption, you must set `org-mobile-encryption-password'"))
(unless (file-writable-p org-mobile-encryption-tempfile)
(error "Cannot write to encryption tempfile %s"
org-mobile-encryption-tempfile))
(unless (executable-find "openssl")
(error "OpenSSL is needed to encrypt files"))))
(defun org-mobile-create-index-file ()
"Write the index file in the WebDAV directory."
(let ((files-alist (sort (copy-sequence org-mobile-files-alist)
(lambda (a b) (string< (cdr a) (cdr b)))))
(def-todo (default-value 'org-todo-keywords))
(def-tags org-tag-alist)
(target-file (expand-file-name org-mobile-index-file
org-mobile-directory))
todo-kwds done-kwds tags)
(when (stringp (car def-todo))
(setq def-todo (list (cons 'sequence def-todo))))
(org-agenda-prepare-buffers (mapcar 'car files-alist))
(setq done-kwds (org-uniquify org-done-keywords-for-agenda))
(setq todo-kwds (org-delete-all
done-kwds
(org-uniquify org-todo-keywords-for-agenda)))
(setq tags (mapcar 'car (org-global-tags-completion-table
(mapcar 'car files-alist))))
(with-temp-file (if org-mobile-use-encryption org-mobile-encryption-tempfile
target-file)
(insert "#+READONLY\n")
(dolist (entry def-todo)
(let ((kwds (mapcar (lambda (x)
(if (string-match "(" x)
(substring x 0 (match-beginning 0))
x))
(cdr entry))))
(insert "#+TODO: " (mapconcat #'identity kwds " ") "\n")
(let* ((dwds (or (member "|" kwds) (last kwds)))
(twds (org-delete-all dwds kwds)))
(setq todo-kwds (org-delete-all twds todo-kwds))
(setq done-kwds (org-delete-all dwds done-kwds)))))
(when (or todo-kwds done-kwds)
(insert "#+TODO: " (mapconcat 'identity todo-kwds " ") " | "
(mapconcat 'identity done-kwds " ") "\n"))
(setq def-tags (split-string (org-tag-alist-to-string def-tags t)))
(setq tags (org-delete-all def-tags tags))
(setq tags (sort tags (lambda (a b) (string< (downcase a) (downcase b)))))
(setq tags (append def-tags tags nil))
(insert "#+TAGS: " (mapconcat 'identity tags " ") "\n")
(insert "#+ALLPRIORITIES: " org-mobile-allpriorities "\n")
(when (file-exists-p (expand-file-name
"agendas.org" org-mobile-directory))
(insert "* [[file:agendas.org][Agenda Views]]\n"))
(pcase-dolist (`(,_ . ,link-name) files-alist)
(insert (format "* [[file:%s][%s]]\n" link-name link-name)))
(push (cons org-mobile-index-file (md5 (buffer-string)))
org-mobile-checksum-files))
(when org-mobile-use-encryption
(org-mobile-encrypt-and-move org-mobile-encryption-tempfile
target-file)
(org-mobile-cleanup-encryption-tempfile))))
(defun org-mobile-copy-agenda-files ()
"Copy all agenda files to the stage or WebDAV directory."
(let ((files-alist org-mobile-files-alist)
file buf entry link-name target-path target-dir check)
(while (setq entry (pop files-alist))
(setq file (car entry) link-name (cdr entry))
(when (file-exists-p file)
(setq target-path (expand-file-name link-name org-mobile-directory)
target-dir (file-name-directory target-path))
(unless (file-directory-p target-dir)
(make-directory target-dir 'parents))
(if org-mobile-use-encryption
(org-mobile-encrypt-and-move file target-path)
(copy-file file target-path 'ok-if-already-exists))
(setq check (shell-command-to-string
(concat (shell-quote-argument org-mobile-checksum-binary)
" "
(shell-quote-argument (expand-file-name file)))))
(when (string-match "[[:xdigit:]]\\{30,40\\}" check)
(push (cons link-name (match-string 0 check))
org-mobile-checksum-files))))
(setq file (expand-file-name org-mobile-capture-file
org-mobile-directory))
(save-excursion
(setq buf (find-file file))
(when (and (= (point-min) (point-max)))
(insert "\n")
(save-buffer)
(when org-mobile-use-encryption
(write-file org-mobile-encryption-tempfile)
(org-mobile-encrypt-and-move org-mobile-encryption-tempfile file)))
(push (cons org-mobile-capture-file (md5 (buffer-string)))
org-mobile-checksum-files))
(org-mobile-cleanup-encryption-tempfile)
(kill-buffer buf)))
(defun org-mobile-write-checksums ()
"Create checksums for all files in `org-mobile-directory'.
The table of checksums is written to the file mobile-checksums."
(let ((sumfile (expand-file-name "checksums.dat" org-mobile-directory))
(files org-mobile-checksum-files)
entry file sum)
(with-temp-file sumfile
(set-buffer-file-coding-system 'undecided-unix nil)
(while (setq entry (pop files))
(setq file (car entry) sum (cdr entry))
(insert (format "%s %s\n" sum file))))))
(defun org-mobile-sumo-agenda-command ()
"Return an agenda custom command that comprises all custom commands."
(let ((custom-list
;; normalize different versions
(delq nil
(mapcar
(lambda (x)
(cond ((stringp (cdr x)) nil)
((stringp (nth 1 x)) x)
((not (nth 1 x)) (cons (car x) (cons "" (cddr x))))
(t (cons (car x) (cons "" (cdr x))))))
org-agenda-custom-commands)))
(default-list '(("a" "Agenda" agenda) ("t" "All TODO" alltodo)))
thelist atitle new e key desc type match settings cmds gkey gdesc gsettings cnt)
(cond
((eq org-mobile-agendas 'custom)
(setq thelist custom-list))
((eq org-mobile-agendas 'default)
(setq thelist default-list))
((eq org-mobile-agendas 'all)
(setq thelist custom-list)
(unless (assoc "t" thelist) (push '("t" "ALL TODO" alltodo) thelist))
(unless (assoc "a" thelist) (push '("a" "Agenda" agenda) thelist)))
((listp org-mobile-agendas)
(setq thelist (append custom-list default-list))
(setq thelist (delq nil (mapcar (lambda (k) (assoc k thelist))
org-mobile-agendas)))))
(while (setq e (pop thelist))
(cond
((stringp (cdr e))
;; this is a description entry - skip it
)
((eq (nth 2 e) 'search)
;; Search view is interactive, skip
)
((memq (nth 2 e) '(todo-tree tags-tree occur-tree))
;; These are trees, not really agenda commands
)
((and (memq (nth 2 e) '(todo tags tags-todo))
(or (null (nth 3 e))
(not (string-match "\\S-" (nth 3 e)))))
;; These would be interactive because the match string is empty
)
((memq (nth 2 e) '(agenda alltodo todo tags tags-todo))
;; a normal command
(setq key (car e) desc (nth 1 e) type (nth 2 e) match (nth 3 e)
settings (nth 4 e))
(setq settings
(cons (list 'org-agenda-title-append
(concat "<after>KEYS=" key " TITLE: "
(if (and (stringp desc) (> (length desc) 0))
desc (symbol-name type))
"</after>"))
settings))
(push (list type match settings) new))
((or (functionp (nth 2 e)) (symbolp (nth 2 e)))
;; A user-defined function, which can do anything, so simply
;; ignore it.
)
(t
;; a block agenda
(setq gkey (car e) gdesc (nth 1 e) gsettings (nth 3 e) cmds (nth 2 e))
(setq cnt 0)
(while (setq e (pop cmds))
(setq type (car e) match (nth 1 e) settings (nth 2 e))
(setq atitle (if (string= "" gdesc) match gdesc))
(setq settings (append gsettings settings))
(setq settings
(cons (list 'org-agenda-title-append
(concat "<after>KEYS=" gkey "#" (number-to-string
(setq cnt (1+ cnt)))
" TITLE: " atitle "</after>"))
settings))
(push (list type match settings) new)))))
(and new (list "X" "SUMO" (reverse new)
'((org-agenda-compact-blocks nil))))))
(defvar org-mobile-creating-agendas nil)
(defun org-mobile-write-agenda-for-mobile (file)
(let ((all (buffer-string)) in-date id pl prefix line app short m sexp)
(with-temp-file file
(org-mode)
(insert "#+READONLY\n")
(insert all)
(goto-char (point-min))
(while (not (eobp))
(cond
((looking-at "[ \t]*$")) ; keep empty lines
((looking-at "=+$")
;; remove underlining
(delete-region (point) (line-end-position)))
((get-text-property (point) 'org-agenda-structural-header)
(setq in-date nil)
(setq app (get-text-property (point) 'org-agenda-title-append))
(setq short (get-text-property (point) 'short-heading))
(when (and short (looking-at ".+"))
(replace-match short nil t)
(forward-line 0))
(when app
(end-of-line 1)
(insert app)
(forward-line 0))
(insert "* "))
((get-text-property (point) 'org-agenda-date-header)
(setq in-date t)
(insert "** "))
((setq m (or (get-text-property (point) 'org-hd-marker)
(get-text-property (point) 'org-marker)))
(setq sexp (member (get-text-property (point) 'type)
'("diary" "sexp")))
(if (setq pl (text-property-any (point) (line-end-position) 'org-heading t))
(progn
(setq prefix (org-trim (buffer-substring
(point) pl))
line (org-trim (buffer-substring
pl
(line-end-position))))
(delete-region (line-beginning-position) (line-end-position))
(insert line "<before>" prefix "</before>")
(forward-line 0))
(and (looking-at "[ \t]+") (replace-match "")))
(insert (if in-date "*** " "** "))
(end-of-line 1)
(insert "\n")
(unless sexp
(insert (org-agenda-get-some-entry-text
m 10 " " 'planning)
"\n")
(when (setq id
(if (bound-and-true-p
org-mobile-force-id-on-agenda-items)
(org-id-get m 'create)
(or (org-entry-get m "ID")
(org-mobile-get-outline-path-link m))))
(insert " :PROPERTIES:\n :ORIGINAL_ID: " id
"\n :END:\n")))))
(forward-line 1))
(push (cons "agendas.org" (md5 (buffer-string)))
org-mobile-checksum-files))
(message "Agenda written to Org file %s" file)))
(defun org-mobile-get-outline-path-link (pom)
(org-with-point-at pom
(concat "olp:"
(org-mobile-escape-olp (file-name-nondirectory buffer-file-name))
":"
(mapconcat 'org-mobile-escape-olp
(org-get-outline-path)
"/")
"/"
(org-mobile-escape-olp (nth 4 (org-heading-components))))))
(defun org-mobile-escape-olp (s)
(org-link-encode s '(?: ?/)))
(defun org-mobile-create-sumo-agenda ()
"Create a file that contains all custom agenda views."
(interactive)
(let* ((file (expand-file-name "agendas.org"
org-mobile-directory))
(file1 (if org-mobile-use-encryption
org-mobile-encryption-tempfile
file))
(sumo (org-mobile-sumo-agenda-command))
(org-agenda-custom-commands
(list (append sumo (list (list file1)))))
(org-mobile-creating-agendas t))
(unless (file-writable-p file1)
(error "Cannot write to file %s" file1))
(when sumo
(org-store-agenda-views))
(when org-mobile-use-encryption
(org-mobile-encrypt-and-move file1 file)
(delete-file file1)
(org-mobile-cleanup-encryption-tempfile))))
(defun org-mobile-encrypt-and-move (infile outfile)
"Encrypt INFILE locally to INFILE_enc, then move it to OUTFILE.
We do this in two steps so that remote paths will work, even if the
encryption program does not understand them."
(let ((encfile (concat infile "_enc")))
(org-mobile-encrypt-file infile encfile)
(when outfile
(copy-file encfile outfile 'ok-if-already-exists)
(delete-file encfile))))
(defun org-mobile-encrypt-file (infile outfile)
"Encrypt INFILE to OUTFILE, using `org-mobile-encryption-password'."
(shell-command
(format "openssl enc -md md5 -aes-256-cbc -salt -pass %s -in %s -out %s"
(shell-quote-argument (concat "pass:"
(org-mobile-encryption-password)))
(shell-quote-argument (expand-file-name infile))
(shell-quote-argument (expand-file-name outfile)))))
(defun org-mobile-decrypt-file (infile outfile)
"Decrypt INFILE to OUTFILE, using `org-mobile-encryption-password'."
(shell-command
(format "openssl enc -md md5 -d -aes-256-cbc -salt -pass %s -in %s -out %s"
(shell-quote-argument (concat "pass:"
(org-mobile-encryption-password)))
(shell-quote-argument (expand-file-name infile))
(shell-quote-argument (expand-file-name outfile)))))
(defun org-mobile-cleanup-encryption-tempfile ()
"Remove the encryption tempfile if it exists."
(and (stringp org-mobile-encryption-tempfile)
(file-exists-p org-mobile-encryption-tempfile)
(delete-file org-mobile-encryption-tempfile)))
(defun org-mobile-move-capture ()
"Move the contents of the capture file to the inbox file.
Return a marker to the location where the new content has been added.
If nothing new has been added, return nil."
(interactive)
(let* ((encfile nil)
(capture-file (expand-file-name org-mobile-capture-file
org-mobile-directory))
(inbox-buffer (find-file-noselect org-mobile-inbox-for-pull))
(capture-buffer
(if (not org-mobile-use-encryption)
(find-file-noselect capture-file)
(org-mobile-cleanup-encryption-tempfile)
(setq encfile (concat org-mobile-encryption-tempfile "_enc"))
(copy-file capture-file encfile)
(org-mobile-decrypt-file encfile org-mobile-encryption-tempfile)
(find-file-noselect org-mobile-encryption-tempfile)))
(insertion-point (make-marker))
not-empty content)
(with-current-buffer capture-buffer
(setq content (buffer-string))
(setq not-empty (string-match "\\S-" content))
(when not-empty
(set-buffer inbox-buffer)
(widen)
(goto-char (point-max))
(or (bolp) (newline))
(move-marker insertion-point
(prog1 (point) (insert content)))
(save-buffer)
(set-buffer capture-buffer)
(erase-buffer)
(save-buffer)
(org-mobile-update-checksum-for-capture-file (buffer-string))))
(kill-buffer capture-buffer)
(when org-mobile-use-encryption
(org-mobile-encrypt-and-move org-mobile-encryption-tempfile
capture-file)
(org-mobile-cleanup-encryption-tempfile))
(if not-empty insertion-point)))
(defun org-mobile-update-checksum-for-capture-file (buffer-string)
"Find the checksum line and modify it to match BUFFER-STRING."
(let* ((file (expand-file-name "checksums.dat" org-mobile-directory))
(buffer (find-file-noselect file)))
(when buffer
(with-current-buffer buffer
(when (re-search-forward (concat "\\([[:xdigit:]]\\{30,\\}\\).*?"
(regexp-quote org-mobile-capture-file)
"[ \t]*$") nil t)
(goto-char (match-beginning 1))
(delete-region (match-beginning 1) (match-end 1))
(insert (md5 buffer-string))
(save-buffer)))
(kill-buffer buffer))))
(defun org-mobile-apply (&optional beg end)
"Apply all change requests in the current buffer.
If BEG and END are given, only do this in that region."
(interactive)
(require 'org-archive)
(setq org-mobile-last-flagged-files nil)
(setq beg (or beg (point-min)) end (or end (point-max)))
;; Remove all Note IDs
(goto-char beg)
(while (re-search-forward "^\\*\\* Note ID: [-0-9A-F]+[ \t]*\n" end t)
(replace-match ""))
;; Find all the referenced entries, without making any changes yet
(let ((marker (make-marker))
(bos-marker (make-marker))
(end (move-marker (make-marker) end))
(cnt-new 0)
(cnt-edit 0)
(cnt-flag 0)
(cnt-error 0)
buf-list
org-mobile-error)
;; Count the new captures
(goto-char beg)
(while (re-search-forward "^\\* \\(.*\\)" end t)
(and (>= (- (match-end 1) (match-beginning 1)) 2)
(not (equal (downcase (substring (match-string 1) 0 2)) "f("))
(cl-incf cnt-new)))
;; Find and apply the edits
(goto-char beg)
(while (re-search-forward
"^\\*+[ \t]+F(\\([^():\n]*\\)\\(:\\([^()\n]*\\)\\)?)[ \t]+\\[\\[\\(\\(id\\|olp\\):\\([^]\n]+\\)\\)" end t)
(catch 'next
(let* ((action (match-string 1))
(data (and (match-end 3) (match-string 3)))
(id-pos (condition-case msg
(org-mobile-locate-entry (match-string 4))
(error (nth 1 msg))))
(bos (line-beginning-position))
(eos (save-excursion (org-end-of-subtree t t)))
(cmd (if (equal action "")
(let ((note (buffer-substring-no-properties
(line-beginning-position 2) eos)))
(lambda (_data _old _new)
(cl-incf cnt-flag)
(org-toggle-tag "FLAGGED" 'on)
(org-entry-put
nil "THEFLAGGINGNOTE"
(replace-regexp-in-string "\n" "\\\\n" note))))
(cl-incf cnt-edit)
(cdr (assoc action org-mobile-action-alist))))
;; Do not take notes interactively.
(org-inhibit-logging 'note)
old new)
(goto-char bos)
(when (and (markerp id-pos)
(not (member (marker-buffer id-pos) buf-list)))
(org-mobile-timestamp-buffer (marker-buffer id-pos))
(push (marker-buffer id-pos) buf-list))
(unless (markerp id-pos)
(goto-char (+ 2 (line-beginning-position)))
(if (stringp id-pos)
(insert id-pos " ")
(insert "BAD REFERENCE "))
(cl-incf cnt-error)
(throw 'next t))
(unless cmd
(insert "BAD FLAG ")
(cl-incf cnt-error)
(throw 'next t))
(move-marker bos-marker (point))
(if (re-search-forward "^\\** Old value[ \t]*$" eos t)
(setq old (buffer-substring
(1+ (match-end 0))
(progn (outline-next-heading) (point)))))
(if (re-search-forward "^\\** New value[ \t]*$" eos t)
(setq new (buffer-substring
(1+ (match-end 0))
(progn (outline-next-heading)
(if (eobp) (org-back-over-empty-lines))
(point)))))
(setq old (org-string-nw-p old))
(setq new (org-string-nw-p new))
(unless (equal data "body")
(setq new (and new (org-trim new)))
(setq old (and old (org-trim old))))
(goto-char (+ 2 bos-marker))
;; Remember this place so that we can return
(move-marker marker (point))
(setq org-mobile-error nil)
(condition-case msg
(org-with-point-at id-pos
(funcall cmd data old new)
(unless (member data '("delete" "archive" "archive-sibling"
"addheading"))
(when (member "FLAGGED" (org-get-tags nil t))
(add-to-list 'org-mobile-last-flagged-files
(buffer-file-name)))))
(error (setq org-mobile-error msg)))
(when org-mobile-error
(pop-to-buffer-same-window (marker-buffer marker))
(goto-char marker)
(cl-incf cnt-error)
(insert (if (stringp (nth 1 org-mobile-error))
(nth 1 org-mobile-error)
"EXECUTION FAILED")
" ")
(throw 'next t))
;; If we get here, the action has been applied successfully
;; So remove the entry
(goto-char bos-marker)
(delete-region (point) (org-end-of-subtree t t)))))
(save-buffer)
(move-marker marker nil)
(move-marker end nil)
(message "%d new, %d edits, %d flags, %d errors"
cnt-new cnt-edit cnt-flag cnt-error)
(sit-for 1)))
(defun org-mobile-timestamp-buffer (buf)
"Time stamp buffer BUF, just to make sure its checksum will change."
(with-current-buffer buf
(save-excursion
(save-restriction
(widen)
(goto-char (point-min))
(if (re-search-forward
"^\\([ \t]*\\)#\\+LAST_MOBILE_CHANGE:.*\n?" nil t)
(progn
(goto-char (match-end 1))
(delete-region (point) (match-end 0)))
(if (looking-at ".*?-\\*-.*-\\*-")
(forward-line 1)))
(insert "#+LAST_MOBILE_CHANGE: "
(format-time-string "%Y-%m-%d %T") "\n")))))
(defun org-mobile-smart-read ()
"Parse the entry at point for shortcuts and expand them.
These shortcuts are meant for fast and easy typing on the limited
keyboards of a mobile device. Below we show a list of the shortcuts
currently implemented.
The entry is expected to contain an inactive time stamp indicating when
the entry was created. When setting dates and
times (for example for deadlines), the time strings are interpreted
relative to that creation date.
Abbreviations are expected to take up entire lines, just because it is so
easy to type RET on a mobile device. Abbreviations start with one or two
letters, followed immediately by a dot and then additional information.
Generally the entire shortcut line is removed after action have been taken.
Time stamps will be constructed using `org-read-date'. So for example a
line \"dd. 2tue\" will set a deadline on the second Tuesday after the
creation date.
Here are the shortcuts currently implemented:
dd. string set deadline
ss. string set scheduling
tt. string set time tamp, here.
ti. string set inactive time
tg. tag1 tag2 tag3 set all these tags, change case where necessary
td. kwd set this todo keyword, change case where necessary
FIXME: Hmmm, not sure if we can make his work against the
auto-correction feature. Needs a bit more thinking. So this function
is currently a noop.")
(defun org-mobile-locate-entry (link)
(if (string-match "\\`id:\\(.*\\)$" link)
(org-id-find (match-string 1 link) 'marker)
(if (not (string-match "\\`olp:\\(.*?\\):\\(.*\\)$" link))
; not found with path, but maybe it is to be inserted
; in top level of the file?
(if (not (string-match "\\`olp:\\(.*?\\)$" link))
nil
(let ((file (match-string 1 link)))
(setq file (org-link-decode file))
(setq file (expand-file-name file org-directory))
(save-excursion
(find-file file)
(goto-char (point-max))
(newline)
(goto-char (point-max))
(point-marker))))
(let ((file (match-string 1 link))
(path (match-string 2 link)))
(setq file (org-link-decode file))
(setq file (expand-file-name file org-directory))
(setq path (mapcar #'org-link-decode
(org-split-string path "/")))
(org-find-olp (cons file path))))))
(defun org-mobile-edit (what old new)
"Edit item WHAT in the current entry by replacing OLD with NEW.
WHAT can be \"heading\", \"todo\", \"tags\", \"priority\", or \"body\".
The edit only takes place if the current value is equal (except for
white space) the OLD. If this is so, OLD will be replace by NEW
and the command will return t. If something goes wrong, a string will
be returned that indicates what went wrong."
(let (current old1 new1 level)
(if (stringp what) (setq what (intern what)))
(cond
((memq what '(todo todostate))
(setq current (org-get-todo-state))
(cond
((equal new "DONEARCHIVE")
(org-todo 'done)
(org-archive-subtree-default))
((equal new current) t) ; nothing needs to be done
((or (equal current old)
(eq org-mobile-force-mobile-change t)
(memq 'todo org-mobile-force-mobile-change))
(org-todo (or new 'none)) t)
(t (error "State before change was expected as \"%s\", but is \"%s\""
old current))))
((eq what 'tags)
(setq current (org-get-tags nil t)
new1 (and new (org-split-string new ":+"))
old1 (and old (org-split-string old ":+")))
(cond
((org-mobile-tags-same-p current new1) t) ; no change needed
((or (org-mobile-tags-same-p current old1)
(eq org-mobile-force-mobile-change t)
(memq 'tags org-mobile-force-mobile-change))
(org-set-tags new1) t)
(t (error "Tags before change were expected as \"%s\", but are \"%s\""
(or old "") (or current "")))))
((eq what 'priority)
(let ((case-fold-search nil))
(when (looking-at org-complex-heading-regexp)
(let ((current (and (match-end 3) (substring (match-string 3) 2 3))))
(cond
((equal current new) t) ;no action required
((or (equal current old)
(eq org-mobile-force-mobile-change t)
(memq 'tags org-mobile-force-mobile-change))
(org-priority (and new (string-to-char new))))
(t (error "Priority was expected to be %s, but is %s"
old current)))))))
((eq what 'heading)
(let ((case-fold-search nil))
(when (looking-at org-complex-heading-regexp)
(let ((current (match-string 4)))
(cond
((equal current new) t) ;no action required
((or (equal current old)
(eq org-mobile-force-mobile-change t)
(memq 'heading org-mobile-force-mobile-change))
(goto-char (match-beginning 4))
(insert new)
(delete-region (point) (+ (point) (length current)))
(when org-auto-align-tags (org-align-tags)))
(t
(error
"Heading changed in the mobile device and on the computer")))))))
((eq what 'addheading)
(if (org-at-heading-p) ; if false we are in top-level of file
(progn
;; Workaround a `org-insert-heading-respect-content' bug
;; which prevents correct insertion when point is invisible
(org-fold-show-subtree)
(end-of-line 1)
(org-insert-heading-respect-content t)
(org-demote))
(forward-line 0)
(insert "* "))
(insert new))
((eq what 'refile)
(org-copy-subtree)
(org-with-point-at (org-mobile-locate-entry new)
(if (org-at-heading-p) ; if false we are in top-level of file
(progn
(setq level (org-get-valid-level (funcall outline-level) 1))
(org-end-of-subtree t t)
(org-paste-subtree level))
(org-paste-subtree 1)))
(org-cut-subtree))
((eq what 'delete)
(org-cut-subtree))
((eq what 'archive)
(org-archive-subtree))
((eq what 'archive-sibling)
(org-archive-to-archive-sibling))
((eq what 'body)
(setq current (buffer-substring (min (1+ (line-end-position)) (point-max))
(save-excursion (outline-next-heading)
(point))))
(if (not (string-match "\\S-" current)) (setq current nil))
(cond
((org-mobile-bodies-same-p current new) t) ; no action necessary
((or (org-mobile-bodies-same-p current old)
(eq org-mobile-force-mobile-change t)
(memq 'body org-mobile-force-mobile-change))
(save-excursion
(end-of-line 1)
(insert "\n" new)
(or (bolp) (insert "\n"))
(delete-region (point) (progn (org-back-to-heading t)
(outline-next-heading)
(point))))
t)
(t (error
"Body was changed in the mobile device and on the computer")))))))
(defun org-mobile-tags-same-p (list1 list2)
"Are the two tag lists the same?"
(not (or (org-delete-all list1 list2)
(org-delete-all list2 list1))))
(defun org-mobile-bodies-same-p (a b)
"Compare if A and B are visually equal strings.
We first remove leading and trailing white space from the entire strings.
Then we split the strings into lines and remove leading/trailing whitespace
from each line. Then we compare.
A and B must be strings or nil."
(cond
((and (not a) (not b)) t)
((or (not a) (not b)) nil)
(t (setq a (org-trim a) b (org-trim b))
(setq a (mapconcat 'identity (org-split-string a "[ \t]*\n[ \t]*") "\n"))
(setq b (mapconcat 'identity (org-split-string b "[ \t]*\n[ \t]*") "\n"))
(equal a b))))
(provide 'org-mobile)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; org-mobile.el ends here
org-mode-9.7.29+dfsg/lisp/org-mouse.el 0000664 0000000 0000000 00000115256 15004304337 0017471 0 ustar 00root root 0000000 0000000 ;;; org-mouse.el --- Better mouse support for Org -*- lexical-binding: t; -*-
;; Copyright (C) 2006-2025 Free Software Foundation, Inc.
;; Author: Piotr Zielinski <piotr dot zielinski at gmail dot com>
;; Maintainer: Carsten Dominik <carsten.dominik@gmail.com>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; Org-mouse provides mouse support for org-mode.
;;
;; https://orgmode.org
;;
;; Org mouse implements the following features:
;; * following links with the left mouse button
;; * subtree expansion/collapse (org-cycle) with the left mouse button
;; * several context menus on the right mouse button:
;; + general text
;; + headlines
;; + timestamps
;; + priorities
;; + links
;; + tags
;; * promoting/demoting/moving subtrees with mouse-3
;; + if the drag starts and ends in the same line then promote/demote
;; + otherwise move the subtree
;;
;; Use
;; ---
;;
;; To use this package, put the following line in your .emacs:
;;
;; (require 'org-mouse)
;;
;; FIXME:
;; + deal with folding / unfolding issues
;; TODO (This list is only theoretical, if you'd like to have some
;; feature implemented or a bug fix please send me an email, even if
;; something similar appears in the list below. This will help me get
;; the priorities right.):
;;
;; + org-store-link, insert link
;; + org tables
;; + occur with the current word/tag (same menu item)
;; + ctrl-c ctrl-c, for example, renumber the current list
;; + internal links
;; Please email the maintainer with new feature suggestions / bugs
;; History:
;;
;; Since version 5.10: Changes are listed in the general Org docs.
;;
;; Version 5.09;; + Version number synchronization with Org mode.
;;
;; Version 0.25
;; + made compatible with Org 4.70 (thanks to Carsten for the patch)
;;
;; Version 0.24
;; + minor changes to the table menu
;;
;; Version 0.23
;; + preliminary support for tables and calculation marks
;; + context menu support for org-agenda-undo & org-sort-entries
;;
;; Version 0.22
;; + handles undo support for the agenda buffer (requires Org >=4.58)
;;
;; Version 0.21
;; + selected text activates its context menu
;; + shift-middleclick or right-drag inserts the text from the clipboard in the form of a link
;;
;; Version 0.20
;; + the new "TODO Status" submenu replaces the "Cycle TODO" menu item
;; + the TODO menu can now list occurrences of a specific TODO keyword
;; + #+STARTUP line is now recognized
;;
;; Version 0.19
;; + added support for dragging URLs to the org-buffer
;;
;; Version 0.18
;; + added support for agenda blocks
;;
;; Version 0.17
;; + toggle checkboxes with a single click
;;
;; Version 0.16
;; + added support for checkboxes
;;
;; Version 0.15
;; + Org now works with the Agenda buffer as well
;;
;; Version 0.14
;; + added a menu option that converts plain list items to outline items
;;
;; Version 0.13
;; + "Insert Heading" now inserts a sibling heading if the point is
;; on "***" and a child heading otherwise
;;
;; Version 0.12
;; + compatible with Emacs 21
;; + custom agenda commands added to the main menu
;; + moving trees should now work between windows in the same frame
;;
;; Version 0.11
;; + fixed org-mouse-at-link (thanks to Carsten)
;; + removed [follow-link] bindings
;;
;; Version 0.10
;; + added a menu option to remove highlights
;; + compatible with Org 4.21 now
;;
;; Version 0.08:
;; + trees can be moved/promoted/demoted by dragging with the right
;; mouse button (mouse-3)
;; + small changes in the above function
;;
;; Versions 0.01 -- 0.07: (I don't remember)
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'org)
(require 'cl-lib)
(defvar org-agenda-allow-remote-undo)
(defvar org-agenda-undo-list)
(defvar org-agenda-custom-commands)
(declare-function org-agenda-change-all-lines "org-agenda"
(newhead hdmarker &optional fixface just-this))
(declare-function org-verify-change-for-undo "org-agenda" (l1 l2))
(declare-function org-apply-on-list "org-list" (function init-value &rest args))
(declare-function org-agenda-earlier "org-agenda" (arg))
(declare-function org-agenda-later "org-agenda" (arg))
(defvar org-mouse-main-buffer nil
"Active buffer for mouse operations.")
(defvar org-mouse-plain-list-regexp "\\([ \t]*\\)\\([-+*]\\|[0-9]+[.)]\\) "
"Regular expression that matches a plain list.")
(defvar org-mouse-direct t
"Internal variable indicating whether the current action is direct.
If t, then the current action has been invoked directly through the buffer
it is intended to operate on. If nil, then the action has been invoked
indirectly, for example, through the agenda buffer.")
(defgroup org-mouse nil
"Mouse support for `org-mode'."
:tag "Org Mouse"
:group 'org)
(defcustom org-mouse-punctuation ":"
"Punctuation used when inserting text by drag and drop."
:type 'string)
(defcustom org-mouse-features
'(context-menu yank-link activate-stars activate-bullets activate-checkboxes)
"The features of org-mouse that should be activated.
Changing this variable requires a restart of Emacs to get activated."
:type '(set :greedy t
(const :tag "Mouse-3 shows context menu" context-menu)
(const :tag "C-mouse-1 and mouse-3 move trees" move-tree)
(const :tag "S-mouse-2 and drag-mouse-3 yank link" yank-link)
(const :tag "Activate headline stars" activate-stars)
(const :tag "Activate item bullets" activate-bullets)
(const :tag "Activate checkboxes" activate-checkboxes)))
(defun org-mouse-re-search-line (regexp)
"Search the current line for a given regular expression REGEXP."
(forward-line 0)
(re-search-forward regexp (line-end-position) t))
(defun org-mouse-end-headline ()
"Go to the end of current headline (ignoring tags)."
(interactive)
(end-of-line)
(skip-chars-backward "\t ")
(when (looking-back ":[A-Za-z]+:" (line-beginning-position))
(skip-chars-backward ":A-Za-z")
(skip-chars-backward "\t ")))
(defvar-local org-mouse-context-menu-function nil
"Function to create the context menu.
The value of this variable is the function invoked by
`org-mouse-context-menu' as the context menu.")
(defun org-mouse-show-context-menu (event prefix)
"Invoke the context menu.
If the value of `org-mouse-context-menu-function' is a function, then
this function is called. Otherwise, the current major mode menu is used."
(interactive "@e \nP")
(if (and (= (event-click-count event) 1)
(or (not mark-active)
(sit-for
(/ (if (fboundp 'mouse-double-click-time) ; Emacs >= 29
(mouse-double-click-time)
double-click-time)
1000.0))))
(progn
(select-window (posn-window (event-start event)))
(when (not (org-mouse-mark-active))
(goto-char (posn-point (event-start event)))
(when (not (eolp)) (save-excursion (run-hooks 'post-command-hook)))
(sit-for 0))
(if (functionp org-mouse-context-menu-function)
(funcall org-mouse-context-menu-function event)
(popup-menu (mouse-menu-major-mode-map) event prefix)))
(setq this-command 'mouse-save-then-kill)
(mouse-save-then-kill event)))
(defun org-mouse-line-position ()
"Return `:beginning' or `:middle' or `:end', depending on the point position.
If the point is at the end of the line, return `:end'.
If the point is separated from the beginning of the line only by white
space and *'s (`org-mouse-bolp'), return `:beginning'. Otherwise,
return `:middle'."
(cond
((eolp) :end)
((org-mouse-bolp) :beginning)
(t :middle)))
(defun org-mouse-empty-line ()
"Return non-nil if the line contains only white space."
(save-excursion (forward-line 0) (looking-at "[ \t]*$")))
(defun org-mouse-next-heading ()
"Go to the next heading.
If there is none, ensure that the point is at the beginning of an empty line."
(unless (outline-next-heading)
(forward-line 0)
(unless (org-mouse-empty-line)
(end-of-line)
(newline))))
(defun org-mouse-insert-heading ()
"Insert a new heading, as `org-insert-heading'.
If the point is at the :beginning (`org-mouse-line-position') of the line,
insert the new heading before the current line. Otherwise, insert it
after the current heading."
(interactive)
(cl-case (org-mouse-line-position)
(:beginning (forward-line 0)
(org-insert-heading))
(t (org-mouse-next-heading)
(org-insert-heading))))
(defun org-mouse-timestamp-today (&optional shift units)
"Change the timestamp into SHIFT UNITS in the future.
For the acceptable UNITS, see `org-timestamp-change'."
(interactive)
(org-timestamp nil)
(when shift (org-timestamp-change shift units)))
(defun org-mouse-keyword-menu (keywords function &optional selected itemformat)
"A helper function.
Returns a menu fragment consisting of KEYWORDS. When a keyword
is selected by the user, FUNCTION is called with the selected
keyword as the only argument.
If SELECTED is nil, then all items are normal menu items. If
SELECTED is a function, then each item is a checkbox, which is
enabled for a given keyword if (funcall SELECTED keyword) return
non-nil. If SELECTED is neither nil nor a function, then the
items are radio buttons. A radio button is enabled for the
keyword `equal' to SELECTED.
ITEMFORMAT governs formatting of the elements of KEYWORDS. If it
is a function, it is invoked with the keyword as the only
argument. If it is a string, it is interpreted as the format
string to (format ITEMFORMAT keyword). If it is neither a string
nor a function, elements of KEYWORDS are used directly."
(mapcar
(lambda (keyword)
(vector (cond
((functionp itemformat) (funcall itemformat keyword))
((stringp itemformat) (format itemformat keyword))
(t keyword))
`(funcall #',function ,keyword)
:style (cond
((null selected) t)
((functionp selected) 'toggle)
(t 'radio))
:selected (if (functionp selected)
(and (funcall selected keyword) t)
(equal selected keyword))))
keywords))
(defun org-mouse-remove-match-and-spaces ()
"Remove the match, make just one space around the point."
(interactive)
(replace-match "")
(just-one-space))
(defvar org-mouse-rest)
(defun org-mouse-replace-match-and-surround
(_newtext &optional _fixedcase _literal _string subexp)
"The same as `replace-match', but surrounds the replacement with spaces."
(apply #'replace-match org-mouse-rest)
(save-excursion
(goto-char (match-beginning (or subexp 0)))
(just-one-space)
(goto-char (match-end (or subexp 0)))
(just-one-space)))
(defun org-mouse-keyword-replace-menu (keywords &optional group itemformat
nosurround)
"A helper function.
Returns a menu fragment consisting of KEYWORDS. When a keyword
is selected, group GROUP of the current match is replaced by the
keyword. The method ensures that both ends of the replacement
are separated from the rest of the text in the buffer by
individual spaces (unless NOSURROUND is non-nil).
The final entry of the menu is always \"None\", which removes the
match.
ITEMFORMAT governs formatting of the elements of KEYWORDS. If it
is a function, it is invoked with the keyword as the only
argument. If it is a string, it is interpreted as the format
string to (format ITEMFORMAT keyword). If it is neither a string
nor a function, elements of KEYWORDS are used directly."
(setq group (or group 0))
(let ((replace (org-mouse-match-closure
(if nosurround #'replace-match
#'org-mouse-replace-match-and-surround))))
(append
(org-mouse-keyword-menu
keywords
(lambda (keyword) (funcall replace keyword t t nil group))
(match-string group)
itemformat)
`(["None" org-mouse-remove-match-and-spaces
:style radio
:selected ,(not (member (match-string group) keywords))]))))
(defun org-mouse-show-headlines ()
"Change the visibility of the current org buffer to only show headlines."
(interactive)
(let ((this-command 'org-cycle)
(last-command 'org-cycle)
(org-cycle-global-status nil))
(org-cycle '(4))
(org-cycle '(4))))
(defun org-mouse-show-overview ()
"Change visibility of current org buffer to first-level headlines only."
(interactive)
(let ((org-cycle-global-status nil))
(org-cycle '(4))))
(defun org-mouse-set-priority (priority)
"Set the priority of the current headline to PRIORITY."
(org-priority priority))
(defvar org-mouse-priority-regexp "\\[#\\([A-Z]\\)\\]"
"Regular expression matching the priority indicator.
Differs from `org-priority-regexp' in that it doesn't contain the
leading `.*?'.")
(defun org-mouse-get-priority (&optional default)
"Return the priority of the current headline.
DEFAULT is returned if no priority is given in the headline."
(save-excursion
(if (org-mouse-re-search-line org-mouse-priority-regexp)
(match-string 1)
(when default (char-to-string org-priority-default)))))
(defun org-mouse-delete-timestamp ()
"Deletes the current timestamp as well as the preceding keyword.
SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
(when (or (org-at-date-range-p) (org-at-timestamp-p 'lax))
(replace-match "") ;delete the timestamp
(skip-chars-backward " :A-Z")
(when (looking-at " *[A-Z][A-Z]+:")
(replace-match ""))))
(defun org-mouse-looking-at (regexp skipchars &optional movechars)
(save-excursion
(let ((point (point)))
(if (looking-at regexp) t
(skip-chars-backward skipchars)
(forward-char (or movechars 0))
(when (looking-at regexp)
(> (match-end 0) point))))))
(defun org-mouse-priority-list ()
(cl-loop for priority from ?A to org-priority-lowest
collect (char-to-string priority)))
(defun org-mouse-todo-menu (state)
"Create the menu with TODO keywords."
(append
(let ((kwds org-todo-keywords-1))
(org-mouse-keyword-menu
kwds
#'org-todo
(lambda (kwd) (equal state kwd))))))
(defun org-mouse-tag-menu () ;todo
"Create the tags menu."
(append
(let ((tags (org-get-tags nil t)))
(org-mouse-keyword-menu
(sort (mapcar #'car (org-get-buffer-tags))
(or org-tags-sort-function #'org-string<))
(lambda (tag)
(org-mouse-set-tags
(sort (if (member tag tags)
(delete tag tags)
(cons tag tags))
(or org-tags-sort-function #'org-string<))))
(lambda (tag) (member tag tags))
))
'("--"
["Align Tags Here" (org-align-tags) t]
["Align Tags in Buffer" (org-align-tags t) t]
["Set Tags ..." (org-set-tags-command) t])))
(defun org-mouse-set-tags (tags)
(org-set-tags tags))
(defun org-mouse-insert-checkbox ()
(interactive)
(and (org-at-item-p)
(goto-char (match-end 0))
(unless (org-at-item-checkbox-p)
(delete-horizontal-space)
(insert " [ ] "))))
(defun org-mouse-agenda-type (type)
(pcase type
(`tags "Tags: ")
(`todo "TODO: ")
(`tags-tree "Tags tree: ")
(`todo-tree "TODO tree: ")
(`occur-tree "Occur tree: ")
(_ "Agenda command ???")))
(defun org-mouse-list-options-menu (alloptions &optional function)
(let ((options (save-match-data
(split-string (match-string-no-properties 1)))))
(print options)
(cl-loop for name in alloptions
collect
(vector name
`(progn
(replace-match
(mapconcat 'identity
(sort (if (member ',name ',options)
(delete ',name ',options)
(cons ',name ',options))
#'org-string<)
" ")
nil nil nil 1)
(when (functionp ',function) (funcall ',function)))
:style 'toggle
:selected (and (member name options) t)))))
(defun org-mouse-clip-text (text maxlength)
(if (> (length text) maxlength)
(concat (substring text 0 (- maxlength 3)) "...")
text))
(defun org-mouse-popup-global-menu ()
(popup-menu
`("Main Menu"
["Show Overview" org-mouse-show-overview t]
["Show Headlines" org-mouse-show-headlines t]
["Show All" org-show-all t]
["Remove Highlights" org-remove-occur-highlights
:visible org-occur-highlights]
"--"
["Check Deadlines"
(if (functionp 'org-check-deadlines-and-todos)
(org-check-deadlines-and-todos org-deadline-warning-days)
(org-check-deadlines org-deadline-warning-days))
t]
["Check TODOs" org-show-todo-tree t]
("Check Tags"
,@(org-mouse-keyword-menu
(sort (mapcar #'car (org-get-buffer-tags))
(or org-tags-sort-function #'org-string<))
(lambda (tag) (org-tags-sparse-tree nil tag)))
"--"
["Custom Tag ..." org-tags-sparse-tree t])
["Check Phrase ..." org-occur]
"--"
["Display Agenda" org-agenda-list t]
["Display TODO List" org-todo-list t]
("Display Tags"
,@(org-mouse-keyword-menu
(sort (mapcar #'car (org-get-buffer-tags))
(or org-tags-sort-function #'org-string<))
(lambda (tag) (org-tags-view nil tag)))
"--"
["Custom Tag ..." org-tags-view t])
["Display Calendar" org-goto-calendar t]
"--"
,@(org-mouse-keyword-menu
(mapcar #'car org-agenda-custom-commands)
(lambda (key)
(org-agenda nil (string-to-char key)))
nil
(lambda (key)
(let ((entry (assoc key org-agenda-custom-commands)))
(org-mouse-clip-text
(cond
((stringp (nth 1 entry)) (nth 1 entry))
((stringp (nth 2 entry))
(concat (org-mouse-agenda-type (nth 1 entry))
(nth 2 entry)))
(t "Agenda Command `%s'"))
30))))
"--"
["Delete Blank Lines" delete-blank-lines
:visible (org-mouse-empty-line)]
["Insert Checkbox" org-mouse-insert-checkbox
:visible (and (org-at-item-p) (not (org-at-item-checkbox-p)))]
["Insert Checkboxes"
(org-mouse-for-each-item 'org-mouse-insert-checkbox)
:visible (and (org-at-item-p) (not (org-at-item-checkbox-p)))]
["Plain List to Outline" org-mouse-transform-to-outline
:visible (org-at-item-p)])))
(defun org-mouse-get-context (contextlist context)
(let ((contextdata (assq context contextlist)))
(when contextdata
(save-excursion
(goto-char (nth 1 contextdata))
(re-search-forward ".*" (nth 2 contextdata))))))
(defun org-mouse-for-each-item (funct)
;; Functions called by `org-apply-on-list' need an argument.
(let ((wrap-fun (lambda (_) (funcall funct))))
(when (ignore-errors (goto-char (org-in-item-p)))
(save-excursion (org-apply-on-list wrap-fun nil)))))
(defun org-mouse-bolp ()
"Return non-nil if there only spaces, tabs, and `*' before point.
This means, between the beginning of line and the point."
(save-excursion
(skip-chars-backward " \t*") (bolp)))
(defun org-mouse-insert-item (text)
(cl-case (org-mouse-line-position)
(:beginning ; insert before
(forward-line 0)
(looking-at "[ \t]*")
(open-line 1)
(indent-to-column (- (match-end 0) (match-beginning 0)))
(insert "+ "))
(:middle ; insert after
(end-of-line)
(newline t)
(indent-relative)
(insert "+ "))
(:end ; insert text here
(skip-chars-backward " \t")
(kill-region (point) (line-end-position))
(unless (looking-back org-mouse-punctuation (line-beginning-position))
(insert (concat org-mouse-punctuation " ")))))
(insert text)
(forward-line 0))
(advice-add 'dnd-insert-text :around #'org--mouse-dnd-insert-text)
(defun org--mouse-dnd-insert-text (orig-fun window action text &rest args)
(if (derived-mode-p 'org-mode)
(org-mouse-insert-item text)
(apply orig-fun window action text args)))
(advice-add 'dnd-open-file :around #'org--mouse-dnd-open-file)
(defun org--mouse-dnd-open-file (orig-fun uri &rest args)
(if (derived-mode-p 'org-mode)
(org-mouse-insert-item uri)
(apply orig-fun uri args)))
(defun org-mouse-match-closure (function)
(let ((match (match-data t)))
(lambda (&rest rest)
(save-match-data
(set-match-data match)
(apply function rest)))))
(defun org-mouse-yank-link (click)
(interactive "e")
;; Give temporary modes such as isearch a chance to turn off.
(run-hooks 'mouse-leave-buffer-hook)
(mouse-set-point click)
(setq mouse-selection-click-count 0)
(delete-horizontal-space)
(insert-for-yank (concat " [[" (current-kill 0) "]] ")))
(defun org-mouse-context-menu (&optional event)
(let* ((stamp-prefixes (list org-deadline-string org-scheduled-string))
(contextlist (org-context))
(get-context (lambda (context) (org-mouse-get-context contextlist context))))
(cond
((org-mouse-mark-active)
(let ((region-string (buffer-substring (region-beginning) (region-end))))
(popup-menu
`(nil
["Sparse Tree" (org-occur ',region-string)]
["Find in Buffer" (occur ',region-string)]
["Grep in Current Dir"
(grep (format "grep -rnH -e '%s' *" ',region-string))]
["Grep in Parent Dir"
(grep (format "grep -rnH -e '%s' ../*" ',region-string))]
"--"
["Convert to Link"
(progn (save-excursion (goto-char (region-beginning)) (insert "[["))
(save-excursion (goto-char (region-end)) (insert "]]")))]
["Insert Link Here" (org-mouse-yank-link ',event)]))))
((save-excursion (forward-line 0) (looking-at "[ \t]*#\\+STARTUP: \\(.*\\)"))
(popup-menu
`(nil
,@(org-mouse-list-options-menu (mapcar #'car org-startup-options)
'org-mode-restart))))
((or (eolp)
(and (looking-at "\\( \\|\t\\)\\(\\+:[0-9a-zA-Z_:]+\\)?\\( \\|\t\\)+$")
(looking-back " \\|\t" (- (point) 2)
(line-beginning-position))))
(org-mouse-popup-global-menu))
((funcall get-context :checkbox)
(popup-menu
'(nil
["Toggle" org-toggle-checkbox t]
["Remove" org-mouse-remove-match-and-spaces t]
""
["All Clear" (org-mouse-for-each-item
(lambda ()
(when (save-excursion (org-at-item-checkbox-p))
(replace-match "[ ] "))))]
["All Set" (org-mouse-for-each-item
(lambda ()
(when (save-excursion (org-at-item-checkbox-p))
(replace-match "[X] "))))]
["All Toggle" (org-mouse-for-each-item 'org-toggle-checkbox) t]
["All Remove" (org-mouse-for-each-item
(lambda ()
(when (save-excursion (org-at-item-checkbox-p))
(org-mouse-remove-match-and-spaces))))]
)))
((and (org-mouse-looking-at "\\b\\w+" "a-zA-Z0-9_")
(member (match-string 0) org-todo-keywords-1))
(popup-menu
`(nil
,@(org-mouse-todo-menu (match-string 0))
"--"
["Check TODOs" org-show-todo-tree t]
["List all TODO keywords" org-todo-list t]
[,(format "List only %s" (match-string 0))
(org-todo-list (match-string 0)) t]
)))
((and (org-mouse-looking-at "\\b[A-Z]+:" "A-Z")
(member (match-string 0) stamp-prefixes))
(popup-menu
`(nil
,@(org-mouse-keyword-replace-menu stamp-prefixes)
"--"
["Check Deadlines" org-check-deadlines t]
)))
((org-mouse-looking-at org-mouse-priority-regexp "[]A-Z#") ; priority
(popup-menu `(nil ,@(org-mouse-keyword-replace-menu
(org-mouse-priority-list) 1 "Priority %s" t))))
((funcall get-context :link)
(popup-menu
'(nil
["Open" org-open-at-point t]
["Open in Emacs" (org-open-at-point t) t]
"--"
["Copy link" (org-kill-new (match-string 0))]
["Cut link"
(progn
(kill-region (match-beginning 0) (match-end 0))
(just-one-space))]
"--"
["Grep for TODOs"
(grep (format "grep -nH -i 'todo\\|fixme' %s*" (match-string 2)))]
; ["Paste file link" ((insert "file:") (yank))]
)))
((org-mouse-looking-at ":\\([A-Za-z0-9_]+\\):" "A-Za-z0-9_" -1) ;tags
(popup-menu
`(nil
[,(format-message "Display `%s'" (match-string 1))
(org-tags-view nil ,(match-string 1))]
[,(format-message "Sparse Tree `%s'" (match-string 1))
(org-tags-sparse-tree nil ,(match-string 1))]
"--"
,@(org-mouse-tag-menu))))
((org-at-timestamp-p 'lax)
(popup-menu
'(nil
["Show Day" org-open-at-point t]
["Change Timestamp" org-timestamp t]
["Delete Timestamp" (org-mouse-delete-timestamp) t]
["Compute Time Range" org-evaluate-time-range (org-at-date-range-p)]
"--"
["Set for Today" org-mouse-timestamp-today]
["Set for Tomorrow" (org-mouse-timestamp-today 1 'day)]
["Set in 1 Week" (org-mouse-timestamp-today 7 'day)]
["Set in 2 Weeks" (org-mouse-timestamp-today 14 'day)]
["Set in a Month" (org-mouse-timestamp-today 1 'month)]
"--"
["+ 1 Day" (org-timestamp-change 1 'day)]
["+ 1 Week" (org-timestamp-change 7 'day)]
["+ 1 Month" (org-timestamp-change 1 'month)]
"--"
["- 1 Day" (org-timestamp-change -1 'day)]
["- 1 Week" (org-timestamp-change -7 'day)]
["- 1 Month" (org-timestamp-change -1 'month)])))
((funcall get-context :table-special)
(let ((mdata (match-data)))
(cl-incf (car mdata) 2)
(store-match-data mdata))
(message "match: %S" (match-string 0))
(popup-menu `(nil ,@(org-mouse-keyword-replace-menu
'(" " "!" "^" "_" "$" "#" "*" "'") 0
(lambda (mark)
(cl-case (string-to-char mark)
(? "( ) Nothing Special")
(?! "(!) Column Names")
(?^ "(^) Field Names Above")
(?_ "(^) Field Names Below")
(?$ "($) Formula Parameters")
(?# "(#) Recalculation: Auto")
(?* "(*) Recalculation: Manual")
(?' "(') Recalculation: None")))
t))))
((assq :table contextlist)
(popup-menu
'(nil
["Align Table" org-ctrl-c-ctrl-c]
["Blank Field" org-table-blank-field]
["Edit Field" org-table-edit-field]
"--"
("Column"
["Move Column Left" org-metaleft]
["Move Column Right" org-metaright]
["Delete Column" org-shiftmetaleft]
["Insert Column" org-shiftmetaright]
"--"
["Enable Narrowing" (setq org-table-limit-column-width (not org-table-limit-column-width)) :selected org-table-limit-column-width :style toggle])
("Row"
["Move Row Up" org-metaup]
["Move Row Down" org-metadown]
["Delete Row" org-shiftmetaup]
["Insert Row" org-shiftmetadown]
["Sort lines in region" org-table-sort-lines (org-at-table-p)]
"--"
["Insert Hline" org-table-insert-hline])
("Rectangle"
["Copy Rectangle" org-copy-special]
["Cut Rectangle" org-cut-special]
["Paste Rectangle" org-paste-special]
["Fill Rectangle" org-table-wrap-region])
"--"
["Set Column Formula" org-table-eval-formula]
["Set Field Formula" (org-table-eval-formula '(4))]
["Edit Formulas" org-table-edit-formulas]
"--"
["Recalculate Line" org-table-recalculate]
["Recalculate All" (org-table-recalculate '(4))]
["Iterate All" (org-table-recalculate '(16))]
"--"
["Toggle Recalculate Mark" org-table-rotate-recalc-marks]
["Sum Column/Rectangle" org-table-sum
:active (or (org-at-table-p) (org-region-active-p))]
["Field Info" org-table-field-info]
["Debug Formulas"
(setq org-table-formula-debug (not org-table-formula-debug))
:style toggle :selected org-table-formula-debug]
)))
((and (assq :headline contextlist) (not (eolp)))
(let ((priority (org-mouse-get-priority t)))
(popup-menu
`("Headline Menu"
("Tags and Priorities"
,@(org-mouse-keyword-menu
(org-mouse-priority-list)
(lambda (keyword)
(org-mouse-set-priority (string-to-char keyword)))
priority "Priority %s")
"--"
,@(org-mouse-tag-menu))
("TODO Status"
,@(org-mouse-todo-menu (org-get-todo-state)))
["Show Tags"
(with-current-buffer org-mouse-main-buffer (org-agenda-show-tags))
:visible (not org-mouse-direct)]
["Show Priority"
(with-current-buffer org-mouse-main-buffer (org-agenda-show-priority))
:visible (not org-mouse-direct)]
,@(if org-mouse-direct '("--") nil)
["New Heading" org-mouse-insert-heading :visible org-mouse-direct]
["Set Deadline"
(progn (org-mouse-end-headline) (insert " ") (org-deadline))
:active (not (save-excursion
(org-mouse-re-search-line org-deadline-regexp)))]
["Schedule Task"
(progn (org-mouse-end-headline) (insert " ") (org-schedule))
:active (not (save-excursion
(org-mouse-re-search-line org-scheduled-regexp)))]
["Insert Timestamp"
(progn (org-mouse-end-headline) (insert " ") (org-timestamp nil)) t]
; ["Timestamp (inactive)" org-timestamp-inactive t]
"--"
["Archive Subtree" org-archive-subtree]
["Cut Subtree" org-cut-special]
["Copy Subtree" org-copy-special]
["Paste Subtree" org-paste-special :visible org-mouse-direct]
("Sort Children"
["Alphabetically" (org-sort-entries nil ?a)]
["Numerically" (org-sort-entries nil ?n)]
["By Time/Date" (org-sort-entries nil ?t)]
"--"
["Reverse Alphabetically" (org-sort-entries nil ?A)]
["Reverse Numerically" (org-sort-entries nil ?N)]
["Reverse By Time/Date" (org-sort-entries nil ?T)])
"--"
["Move Trees" org-mouse-move-tree :active nil]
))))
(t
(org-mouse-popup-global-menu)))))
(defun org-mouse-mark-active ()
(and mark-active transient-mark-mode))
(defun org-mouse-in-region-p (pos)
(and (org-mouse-mark-active)
(>= pos (region-beginning))
(< pos (region-end))))
(defun org-mouse-down-mouse (event)
(interactive "e")
(setq this-command last-command)
(unless (and (= 1 (event-click-count event))
(org-mouse-in-region-p (posn-point (event-start event))))
(mouse-drag-region event)))
;; This function conflicts with touch screen gestures as it relays
;; events to `mouse-drag-region'.
(put 'org-mouse-down-mouse 'ignored-mouse-command t)
(add-hook 'org-mode-hook
(lambda ()
(setq org-mouse-context-menu-function #'org-mouse-context-menu)
(when (memq 'context-menu org-mouse-features)
(org-defkey org-mouse-map [mouse-3] nil)
(org-defkey org-mode-map [mouse-3] #'org-mouse-show-context-menu))
(org-defkey org-mode-map [down-mouse-1] #'org-mouse-down-mouse)
(when (memq 'context-menu org-mouse-features)
(org-defkey org-mouse-map [C-drag-mouse-1] #'org-mouse-move-tree)
(org-defkey org-mouse-map [C-down-mouse-1] #'org-mouse-move-tree-start))
(when (memq 'yank-link org-mouse-features)
(org-defkey org-mode-map [S-mouse-2] #'org-mouse-yank-link)
(org-defkey org-mode-map [drag-mouse-3] #'org-mouse-yank-link))
(when (memq 'move-tree org-mouse-features)
(org-defkey org-mouse-map [drag-mouse-3] #'org-mouse-move-tree)
(org-defkey org-mouse-map [down-mouse-3] #'org-mouse-move-tree-start))
(when (memq 'activate-stars org-mouse-features)
(font-lock-add-keywords
nil
`((,org-outline-regexp
0 `(face org-link mouse-face highlight keymap ,org-mouse-map)
'prepend))
t))
(when (memq 'activate-bullets org-mouse-features)
(font-lock-add-keywords
nil
`(("^[ \t]*\\([-+*]\\|[0-9]+[.)]\\) +"
(1 `(face org-link keymap ,org-mouse-map mouse-face highlight)
'prepend)))
t))
(when (memq 'activate-checkboxes org-mouse-features)
(font-lock-add-keywords
nil
`(("^[ \t]*\\(?:[-+*]\\|[0-9]+[.)]\\)[ \t]+\\(?:\\[@\\(?:start:\\)?[0-9]+\\][ \t]*\\)?\\(\\[[- X]\\]\\)"
(1 `(face nil keymap ,org-mouse-map mouse-face highlight) prepend)))
t))
(advice-add 'org-open-at-point :around #'org--mouse-open-at-point)))
(defun org--mouse-open-at-point (orig-fun &rest args)
(let ((context (org-context)))
(cond
((assq :headline-stars context) (org-cycle))
((assq :checkbox context) (org-toggle-checkbox))
((assq :item-bullet context)
(let ((org-cycle-include-plain-lists t)) (org-cycle)))
((org-footnote-at-reference-p) nil)
(t (apply orig-fun args)))))
(defun org-mouse-move-tree-start (_event)
(interactive "e")
(message "Same line: promote/demote, (***):move before, (text): make a child"))
(defun org-mouse-make-marker (position)
(with-current-buffer (window-buffer (posn-window position))
(copy-marker (posn-point position))))
(defun org-mouse-move-tree (event)
;; todo: handle movements between different buffers
(interactive "e")
(save-excursion
(let* ((start (org-mouse-make-marker (event-start event)))
(end (org-mouse-make-marker (event-end event)))
(sbuf (marker-buffer start))
(ebuf (marker-buffer end)))
(when (and sbuf ebuf)
(set-buffer sbuf)
(goto-char start)
(org-back-to-heading)
(if (and (eq sbuf ebuf)
(equal
(point)
(save-excursion (goto-char end) (org-back-to-heading) (point))))
;; if the same line then promote/demote
(if (>= end start) (org-demote-subtree) (org-promote-subtree))
;; if different lines then move
(org-cut-subtree)
(set-buffer ebuf)
(goto-char end)
(org-back-to-heading)
(when (and (eq sbuf ebuf)
(equal
(point)
(save-excursion (goto-char start)
(org-back-to-heading) (point))))
(progn (org-end-of-subtree nil t)
(unless (eobp) (backward-char)))
(end-of-line)
(if (eobp) (newline) (forward-char)))
(when (looking-at org-outline-regexp)
(let ((level (- (match-end 0) (match-beginning 0))))
(when (> end (match-end 0))
(progn (org-end-of-subtree nil t)
(unless (eobp) (backward-char)))
(end-of-line)
(if (eobp) (newline) (forward-char))
(setq level (1+ level)))
(org-paste-subtree level)
(save-excursion
(progn (org-end-of-subtree nil t)
(unless (eobp) (backward-char)))
(when (bolp) (delete-char -1))))))))))
(defun org-mouse-transform-to-outline ()
(interactive)
(org-back-to-heading)
(let ((minlevel 1000)
(replace-text (concat (make-string (org-current-level) ?*) "* ")))
(forward-line 1)
(save-excursion
(while (not (or (eobp) (looking-at org-outline-regexp)))
(when (looking-at org-mouse-plain-list-regexp)
(setq minlevel (min minlevel (- (match-end 1) (match-beginning 1)))))
(forward-line)))
(while (not (or (eobp) (looking-at org-outline-regexp)))
(when (and (looking-at org-mouse-plain-list-regexp)
(eq minlevel (- (match-end 1) (match-beginning 1))))
(replace-match replace-text))
(forward-line))))
(defvar org-mouse-cmd) ;dynamically scoped from `org-with-remote-undo'.
(defun org-mouse-do-remotely (command)
;; (org-agenda-check-no-diary)
(when (get-text-property (point) 'org-marker)
(let* ((anticol (- (line-end-position) (point)))
(marker (get-text-property (point) 'org-marker))
(buffer (marker-buffer marker))
(pos (marker-position marker))
(hdmarker (get-text-property (point) 'org-hd-marker))
(buffer-read-only nil)
(newhead "--- removed ---")
(org-mouse-direct nil)
(org-mouse-main-buffer (current-buffer)))
(when (eq (with-current-buffer buffer major-mode) 'org-mode)
(let ((endmarker (with-current-buffer buffer
(org-end-of-subtree nil t)
(unless (eobp) (forward-char 1))
(point-marker))))
(org-with-remote-undo buffer
(with-current-buffer buffer
(widen)
(goto-char pos)
(org-fold-show-hidden-entry)
(save-excursion
(and (outline-next-heading)
(org-fold-heading nil))) ; show the next heading
(org-back-to-heading)
(setq marker (point-marker))
(goto-char (max (line-beginning-position) (- (line-end-position) anticol)))
(funcall command)
(message "_cmd: %S" org-mouse-cmd)
(message "this-command: %S" this-command)
(unless (eq (marker-position marker) (marker-position endmarker))
(setq newhead (org-get-heading))))
(forward-line 1)
(save-excursion
(org-agenda-change-all-lines newhead hdmarker 'fixface))))
t))))
(defun org-mouse-agenda-context-menu (&optional _event)
(or (org-mouse-do-remotely 'org-mouse-context-menu)
(popup-menu
'("Agenda"
("Agenda Files")
"--"
["Undo" (progn (message "last command: %S" last-command) (setq this-command 'org-agenda-undo) (org-agenda-undo))
:visible (if (eq last-command 'org-agenda-undo)
org-agenda-pending-undo-list
org-agenda-undo-list)]
["Rebuild Buffer" org-agenda-redo t]
["New Diary Entry"
org-agenda-diary-entry (org-agenda-check-type nil 'agenda) t]
"--"
["Goto Today" org-agenda-goto-today
(org-agenda-check-type nil 'agenda) t]
["Display Calendar" org-agenda-goto-calendar
(org-agenda-check-type nil 'agenda) t]
("Calendar Commands"
["Phases of the Moon" org-agenda-phases-of-moon
(org-agenda-check-type nil 'agenda)]
["Sunrise/Sunset" org-agenda-sunrise-sunset
(org-agenda-check-type nil 'agenda)]
["Holidays" org-agenda-holidays
(org-agenda-check-type nil 'agenda)]
["Convert" org-agenda-convert-date
(org-agenda-check-type nil 'agenda)]
"--"
["Create iCalendar file" org-icalendar-combine-agenda-files t])
"--"
["Day View" org-agenda-day-view
:active (org-agenda-check-type nil 'agenda)
:style radio :selected (eq org-agenda-current-span 'day)]
["Week View" org-agenda-week-view
:active (org-agenda-check-type nil 'agenda)
:style radio :selected (eq org-agenda-current-span 'week)]
"--"
["Show Logbook entries" org-agenda-log-mode
:style toggle :selected org-agenda-show-log
:active (org-agenda-check-type nil 'agenda)]
["Include Diary" org-agenda-toggle-diary
:style toggle :selected org-agenda-include-diary
:active (org-agenda-check-type nil 'agenda)]
["Use Time Grid" org-agenda-toggle-time-grid
:style toggle :selected org-agenda-use-time-grid
:active (org-agenda-check-type nil 'agenda)]
["Follow Mode" org-agenda-follow-mode
:style toggle :selected org-agenda-follow-mode]
"--"
["Quit" org-agenda-quit t]
["Exit and Release Buffers" org-agenda-exit t]
))))
(defun org-mouse-get-gesture (event)
(let ((startxy (posn-x-y (event-start event)))
(endxy (posn-x-y (event-end event))))
(if (< (car startxy) (car endxy)) :right :left)))
; (setq org-agenda-mode-hook nil)
(defvar org-agenda-mode-map)
(add-hook 'org-agenda-mode-hook
(lambda ()
(setq org-mouse-context-menu-function #'org-mouse-agenda-context-menu)
(org-defkey org-agenda-mode-map [mouse-3] #'org-mouse-show-context-menu)
(org-defkey org-agenda-mode-map [down-mouse-3] #'org-mouse-move-tree-start)
(org-defkey org-agenda-mode-map [C-mouse-4] #'org-agenda-earlier)
(org-defkey org-agenda-mode-map [C-mouse-5] #'org-agenda-later)
(org-defkey org-agenda-mode-map [drag-mouse-3]
(lambda (event) (interactive "e")
(cl-case (org-mouse-get-gesture event)
(:left (org-agenda-earlier 1))
(:right (org-agenda-later 1)))))))
(provide 'org-mouse)
;;; org-mouse.el ends here
org-mode-9.7.29+dfsg/lisp/org-num.el 0000664 0000000 0000000 00000045624 15004304337 0017141 0 ustar 00root root 0000000 0000000 ;;; org-num.el --- Dynamic Headlines Numbering -*- lexical-binding: t; -*-
;; Copyright (C) 2018-2025 Free Software Foundation, Inc.
;; Author: Nicolas Goaziou <mail@nicolasgoaziou.fr>
;; Keywords: outlines, hypermedia, calendar, text
;; 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;; This library provides dynamic numbering for Org headlines. Use
;;
;; <M-x org-num-mode>
;;
;; to toggle it.
;;
;; You can select what is numbered according to level, tags, COMMENT
;; keyword, or UNNUMBERED property. You can also skip footnotes
;; sections. See `org-num-max-level', `org-num-skip-tags',
;; `org-num-skip-commented', `org-num-skip-unnumbered', and
;; `org-num-skip-footnotes' for details.
;;
;; You can also control how the numbering is displayed by setting
;;`org-num-face' and `org-num-format-function'.
;;
;; Internally, the library handles an ordered list, per buffer
;; position, of overlays in `org-num--overlays'. These overlays are
;; marked with the `org-num' property set to a non-nil value.
;;
;; Overlays store the level of the headline in the `level' property,
;; and the face used for the numbering in `numbering-face'.
;;
;; The `skip' property is set to t when the corresponding headline has
;; some characteristic -- e.g., a node property, or a tag -- that
;; prevents it from being numbered.
;;
;; An overlay with `org-num' property set to `invalid' is called an
;; invalid overlay. Modified overlays automatically become invalid
;; and set `org-num--invalid-flag' to a non-nil value. After
;; a change, `org-num--invalid-flag' indicates numbering needs to be
;; updated and invalid overlays indicate where the buffer needs to be
;; parsed. So does `org-num--missing-overlay' variable. See
;; `org-num--verify' function for details.
;;
;; Numbering display is done through the `after-string' property.
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'cl-lib)
(require 'org-macs)
(require 'org) ;Otherwise `org-num--comment-re' burps on `org-comment-string'
(defvar org-comment-string)
(defvar org-complex-heading-regexp)
(defvar org-cycle-level-faces)
(defvar org-footnote-section)
(defvar org-level-faces)
(defvar org-n-level-faces)
(defvar org-odd-levels-only)
(declare-function org-back-to-heading "org" (&optional invisible-ok))
(declare-function org-entry-get "org" (pom property &optional inherit literal-nil))
(declare-function org-reduced-level "org" (l))
;;; Customization
;;;###autoload
(defcustom org-num-face nil
"Face to use for numbering.
When nil, use the same face as the headline. This value is
ignored if `org-num-format-function' specifies a face for its
output."
:group 'org-appearance
:package-version '(Org . "9.3")
:type '(choice (const :tag "Like the headline" nil)
(face :tag "Use face"))
:safe (lambda (val) (or (null val) (facep val))))
(defcustom org-num-format-function #'org-num-default-format
"Function used to display numbering.
It is called with one argument, a list of numbers, and should
return a string, or nil. When nil, no numbering is displayed.
Any `face' text property on the returned string overrides
`org-num-face'."
:group 'org-appearance
:package-version '(Org . "9.3")
:type 'function)
;;;###autoload
(defcustom org-num-max-level nil
"Level below which headlines are not numbered.
When set to nil, all headlines are numbered."
:group 'org-appearance
:package-version '(Org . "9.3")
:type '(choice (const :tag "Number everything" nil)
(integer :tag "Stop numbering at level"))
:safe (lambda (val) (or (null val) (wholenump val))))
;;;###autoload
(defcustom org-num-skip-commented nil
"Non-nil means commented sub-trees are not numbered."
:group 'org-appearance
:package-version '(Org . "9.3")
:type 'boolean
:safe #'booleanp)
;;;###autoload
(defcustom org-num-skip-footnotes nil
"Non-nil means footnotes sections are not numbered."
:group 'org-appearance
:package-version '(Org . "9.3")
:type 'boolean
:safe #'booleanp)
;;;###autoload
(defcustom org-num-skip-tags nil
"List of tags preventing the numbering of sub-trees.
For example, add \"ARCHIVE\" to this list to avoid numbering
archived sub-trees.
Tag in this list prevent numbering the whole sub-tree,
irrespective to `org-use-tag-inheritance', or other means to
control tag inheritance."
:group 'org-appearance
:package-version '(Org . "9.3")
:type '(repeat (string :tag "Tag"))
:safe #'org-list-of-strings-p)
;;;###autoload
(defcustom org-num-skip-unnumbered nil
"Non-nil means numbering obeys to UNNUMBERED property."
:group 'org-appearance
:package-version '(Org . "9.3")
:type 'boolean
:safe #'booleanp)
;;; Internal Variables
(defconst org-num--comment-re (format "\\`%s\\(?: \\|$\\)" org-comment-string)
"Regexp matching a COMMENT keyword at headline beginning.")
(defvar-local org-num--overlays nil
"Ordered list of overlays used for numbering outlines.")
(put 'org-num--overlays 'permanent-local t)
(defvar-local org-num--skip-level nil
"Level below which headlines from current tree are not numbered.
When nil, all headlines are numbered. It is used to handle
inheritance of no-numbering attributes.")
(defvar-local org-num--numbering nil
"Current headline numbering.
A numbering is a list of integers, in reverse order. So numbering
for headline \"1.2.3\" is (3 2 1).")
(defvar-local org-num--missing-overlay nil
"Buffer position signaling a headline without an overlay.")
(defvar-local org-num--invalid-flag nil
"Non-nil means an overlay became invalid since last update.")
;;; Internal Functions
(defsubst org-num--headline-regexp ()
"Return regexp matching a numbered headline."
(if (null org-num-max-level) (org-with-limited-levels org-outline-regexp-bol)
(format "^\\*\\{1,%d\\} "
(if org-odd-levels-only (1- (* 2 org-num-max-level))
org-num-max-level))))
(defsubst org-num--overlay-p (o)
"Non-nil if overlay O is a numbering overlay."
(overlay-get o 'org-num))
(defsubst org-num--valid-overlay-p (o)
"Non-nil if overlay O is still active in the buffer."
(not (eq 'invalid (overlay-get o 'org-num))))
(defsubst org-num--invalidate-overlay (o)
"Mark overlay O as invalid.
Update `org-num--invalid-flag' accordingly."
(overlay-put o 'org-num 'invalid)
(setq org-num--invalid-flag t))
(defun org-num--clear ()
"Remove all numbering overlays in current buffer."
(mapc #'delete-overlay org-num--overlays)
(setq org-num--overlays nil))
(defun org-num--make-overlay (numbering level skip)
"Return overlay for numbering headline at point.
NUMBERING is the numbering to use, as a list of integers, or nil
if nothing should be displayed. LEVEL is the level of the
headline. SKIP is its skip value.
Assume point is at a headline."
(let ((after-edit-functions
(list (lambda (o &rest _) (org-num--invalidate-overlay o))))
(o (save-excursion
(forward-line 0)
(skip-chars-forward "*")
(make-overlay (line-beginning-position) (1+ (point))))))
(overlay-put o 'org-num t)
(overlay-put o 'skip skip)
(overlay-put o 'level level)
(overlay-put o 'numbering-face
(or org-num-face
;; Compute face that would be used at the
;; headline. We cannot extract it from the
;; buffer: at the time the overlay is created,
;; Font Lock has not proceeded yet.
(nth (if org-cycle-level-faces
(% (1- level) org-n-level-faces)
(1- (min level org-n-level-faces)))
org-level-faces)))
(overlay-put o 'modification-hooks after-edit-functions)
(overlay-put o 'insert-in-front-hooks after-edit-functions)
(org-num--refresh-display o numbering)
o))
(defun org-num--refresh-display (overlay numbering)
"Refresh OVERLAY's display.
NUMBERING specifies the new numbering, as a list of integers, or
nil if nothing should be displayed. Assume OVERLAY is valid."
(let ((display (and numbering
(funcall org-num-format-function (reverse numbering)))))
(when (and display (not (get-text-property 0 'face display)))
(org-add-props display `(face ,(overlay-get overlay 'numbering-face))))
(overlay-put overlay 'after-string display)))
(defun org-num--skip-value ()
"Return skip value for headline at point.
Value is t when headline should not be numbered, and nil
otherwise."
(org-match-line org-complex-heading-regexp)
(let ((title (match-string 4))
(tags (and org-num-skip-tags
(match-end 5)
(org-split-string (match-string 5) ":"))))
(or (and org-num-skip-footnotes
org-footnote-section
(equal title org-footnote-section))
(and org-num-skip-commented
title
(let ((case-fold-search nil))
(string-match org-num--comment-re title))
t)
(and org-num-skip-tags
(cl-some (lambda (tag) (member tag org-num-skip-tags))
tags)
t)
(and org-num-skip-unnumbered
(org-entry-get (point) "UNNUMBERED" 'selective)
t))))
(defun org-num--current-numbering (level skip)
"Return numbering for current headline.
LEVEL is headline's level, and SKIP its skip value. Return nil
if headline should be skipped."
(cond
;; Skipped by inheritance.
((and org-num--skip-level (> level org-num--skip-level)) nil)
;; Skipped by a non-nil skip value; set `org-num--skip-level'
;; to skip the whole sub-tree later on.
(skip (setq org-num--skip-level level) nil)
(t
(setq org-num--skip-level nil)
;; Compute next numbering, and update `org-num--numbering'.
(let ((last-level (length org-num--numbering)))
(setq org-num--numbering
(cond
;; First headline : nil => (1), or (1 0)...
((null org-num--numbering) (cons 1 (make-list (1- level) 0)))
;; Sibling: (1 1) => (2 1).
((= level last-level)
(cons (1+ (car org-num--numbering)) (cdr org-num--numbering)))
;; Parent: (1 1 1) => (2 1), or (2).
((< level last-level)
(let ((suffix (nthcdr (- last-level level) org-num--numbering)))
(cons (1+ (car suffix)) (cdr suffix))))
;; Child: (1 1) => (1 1 1), or (1 0 1 1)...
(t
(append (cons 1 (make-list (- level last-level 1) 0))
org-num--numbering))))))))
(defun org-num--number-region (start end)
"Add numbering overlays between START and END positions.
When START or END are nil, use buffer boundaries. Narrowing, if
any, is ignored. Return the list of created overlays, newest
first."
(org-with-point-at (or start 1)
;; Do not match headline starting at START.
(when start (end-of-line))
(let ((regexp (org-num--headline-regexp))
(new nil))
(while (re-search-forward regexp end t)
(let* ((level (org-reduced-level
(- (match-end 0) (match-beginning 0) 1)))
(skip (org-num--skip-value))
(numbering (org-num--current-numbering level skip)))
;; Apply numbering to current headline. Store overlay for
;; the return value.
(push (org-num--make-overlay numbering level skip)
new)))
new)))
(defun org-num--update ()
"Update buffer's numbering.
This function removes invalid overlays and refreshes numbering
for the valid ones in the numbering overlays list. It also adds
missing overlays to that list."
(setq org-num--skip-level nil)
(setq org-num--numbering nil)
(let ((new-overlays nil)
(overlay nil))
(while (setq overlay (pop org-num--overlays))
(cond
;; Valid overlay.
;;
;; First handle possible missing overlays OVERLAY. If missing
;; overlay marker is pointing before next overlay and after the
;; last known overlay, make sure to parse the buffer between
;; these two overlays.
((org-num--valid-overlay-p overlay)
(let ((next (overlay-start overlay))
(last (and new-overlays (overlay-start (car new-overlays)))))
(cond
((null org-num--missing-overlay))
((> org-num--missing-overlay next))
((or (null last) (> org-num--missing-overlay last))
(setq org-num--missing-overlay nil)
(setq new-overlays (nconc (org-num--number-region last next)
new-overlays)))
;; If it is already after the last known overlay, reset it:
;; some previous invalid overlay already triggered the
;; necessary parsing.
(t
(setq org-num--missing-overlay nil))))
;; Update OVERLAY's numbering.
(let* ((level (overlay-get overlay 'level))
(skip (overlay-get overlay 'skip))
(numbering (org-num--current-numbering level skip)))
(org-num--refresh-display overlay numbering)
(push overlay new-overlays)))
;; Invalid overlay. It indicates that the buffer needs to be
;; parsed again between the two surrounding valid overlays or
;; buffer boundaries.
(t
;; Delete all consecutive invalid overlays: we re-create all
;; overlays between last valid overlay and the next one.
(delete-overlay overlay)
(while (and org-num--overlays
(not (org-num--valid-overlay-p (car org-num--overlays))))
(delete-overlay (pop org-num--overlays)))
;; Create and register new overlays.
(let ((last (and new-overlays (overlay-start (car new-overlays))))
(next (and org-num--overlays
(overlay-start (car org-num--overlays)))))
(setq new-overlays (nconc (org-num--number-region last next)
new-overlays))))))
;; If invalid position hasn't been handled yet, it must be located
;; between last valid overlay and end of the buffer. Parse that
;; area before returning.
(when org-num--missing-overlay
(let ((last (and new-overlays (overlay-start (car new-overlays)))))
(setq new-overlays (nconc (org-num--number-region last nil)
new-overlays))))
;; Numbering is now up-to-date. Reset invalid flag. Also return
;; `org-num--overlays' in a sorted fashion.
(setq org-num--invalid-flag nil)
(setq org-num--overlays (nreverse new-overlays))))
(defun org-num--verify (beg end _)
"Check numbering integrity; update it if necessary.
This function is meant to be used in `after-change-functions'.
See this variable for the meaning of BEG and END."
(setq org-num--missing-overlay nil)
(save-match-data
(org-with-point-at beg
(let ((regexp (org-num--headline-regexp)))
;; At this point, directly altered overlays between BEG and
;; END are marked as invalid and will trigger a full update.
;; However, there are still two cases to handle.
;;
;; First, some valid overlays may need to be invalidated, due
;; to an indirect change. That happens when the skip value --
;; see `org-num--skip-value' -- of the heading BEG belongs to
;; is altered, or when deleting the newline character right
;; before the next headline.
(save-excursion
;; Bail out if we're before first headline or within
;; a headline too deep to be numbered.
(when (and (org-with-limited-levels
(ignore-errors (org-back-to-heading t)))
(looking-at regexp))
(pcase (get-char-property-and-overlay (point) 'org-num)
(`(nil)
;; At a headline, without a numbering overlay: change
;; just created one. Mark it for parsing.
(setq org-num--missing-overlay (point)))
(`(t . ,o)
;; Check if skip value changed. Invalidate overlay
;; accordingly.
(unless (eq (org-num--skip-value) (overlay-get o 'skip))
(org-num--invalidate-overlay o)))
(_ nil))))
;; Deleting the newline character before a numbering overlay
;; doesn't invalidate it, even though it could land in the
;; middle of a line. Be sure to catch this case.
(when (and (= beg end) (not (bolp)))
(pcase (get-char-property-and-overlay (point) 'org-num)
(`(t . ,o) (org-num--invalidate-overlay o))
(_ nil)))
;; Second, if nothing is marked as invalid, and therefore if
;; no full update is due so far, changes may still have
;; created new headlines, at BEG -- which is actually handled
;; by the previous phase --, or, in case of a multi-line
;; insertion, at END, or in-between.
(unless (or org-num--invalid-flag
org-num--missing-overlay
(<= end (line-end-position))) ;single line change
(forward-line)
(when (or (re-search-forward regexp end 'move)
;; Check if change created a headline after END.
(progn (skip-chars-backward "*") (looking-at regexp)))
(setq org-num--missing-overlay (line-beginning-position))))))
;; Update numbering only if a headline was altered or created.
(when (or org-num--missing-overlay org-num--invalid-flag)
(org-num--update))))
;;; Public Functions
;;;###autoload
(defun org-num-default-format (numbering)
"Default numbering display function.
NUMBERING is a list of numbers."
(concat (mapconcat #'number-to-string numbering ".") " "))
;;;###autoload
(define-minor-mode org-num-mode
"Dynamic numbering of headlines in an Org buffer."
:lighter " o#"
(cond
(org-num-mode
(unless (derived-mode-p 'org-mode)
(user-error "Cannot activate headline numbering outside Org mode"))
(org-num--clear)
(setq org-num--numbering nil)
(setq org-num--overlays (nreverse (org-num--number-region nil nil)))
(add-hook 'after-change-functions #'org-num--verify nil t)
(add-hook 'change-major-mode-hook #'org-num--clear nil t))
(t
(org-num--clear)
(remove-hook 'after-change-functions #'org-num--verify t)
(remove-hook 'change-major-mode-hook #'org-num--clear t))))
(provide 'org-num)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; org-num.el ends here
org-mode-9.7.29+dfsg/lisp/org-pcomplete.el 0000664 0000000 0000000 00000040614 15004304337 0020324 0 ustar 00root root 0000000 0000000 ;;; org-pcomplete.el --- In-buffer Completion Code -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2025 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
;; John Wiegley <johnw at gnu dot org>
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;; This library implements completion support in Org mode buffers.
;;; Code:
;;;; Require other packages
(require 'org-macs)
(org-assert-version)
(require 'org-macs)
(require 'org-compat)
(require 'pcomplete)
(declare-function org-at-heading-p "org" (&optional ignored))
(declare-function org-babel-combine-header-arg-lists "ob-core" (original &rest others))
(declare-function org-babel-get-src-block-info "ob-core" (&optional no-eval datum))
(declare-function org-before-first-heading-p "org" ())
(declare-function org-buffer-property-keys "org" (&optional specials defaults columns))
(declare-function org-element-at-point "org-element" (&optional pom cached-only))
(declare-function org-element-property "org-element-ast" (property node &optional dflt force-undefer))
(declare-function org-element-end "org-element" (node))
(declare-function org-element-type-p "org-element-ast" (node types))
(declare-function org-end-of-meta-data "org" (&optional full))
(declare-function org-entry-properties "org" (&optional pom which))
(declare-function org-export-backend-options "ox" (cl-x) t)
(declare-function org-get-buffer-tags "org" ())
(declare-function org-get-export-keywords "org" ())
(declare-function org-get-heading "org" (&optional no-tags no-todo no-priority no-comment))
(declare-function org-get-tags "org" (&optional pos local))
(declare-function org-link-heading-search-string "ol" (&optional string))
(declare-function org-tag-alist-to-string "org" (alist &optional skip-key))
(declare-function org-time-stamp-format "org" (&optional with-time inactive custom))
(defvar org-babel-common-header-args-w-values)
(defvar org-current-tag-alist)
(defvar org-priority-default)
(defvar org-drawer-regexp)
(defvar org-element-affiliated-keywords)
(defvar org-entities)
(defvar org-export-default-language)
(defvar org-export-exclude-tags)
(defvar org-export-select-tags)
(defvar org-file-tags)
(defvar org-priority-highest)
(defvar org-link-abbrev-alist)
(defvar org-link-abbrev-alist-local)
(defvar org-priority-lowest)
(defvar org-options-keywords)
(defvar org-outline-regexp)
(defvar org-property-re)
(defvar org-startup-options)
(defvar org-tag-re)
(defvar org-todo-keywords-1)
(defvar org-todo-line-regexp)
;;; Internal Functions
(defun org-thing-at-point ()
"Examine the thing at point and let the caller know what it is.
The return value is a string naming the thing at point."
(let ((line-to-here (org-current-line-string t))
(case-fold-search t))
(cond
;; Parameters on a clock table opening line.
((org-match-line "[ \t]*#\\+BEGIN: clocktable[ \t]")
(cons "block-option" "clocktable"))
;; Flags and parameters on a source block opening line.
((org-match-line "[ \t]*#\\+BEGIN_SRC[ \t]")
(cons "block-option" "src"))
;; Value for a known keyword.
((org-match-line "[ \t]*#\\+\\(\\S-+\\):")
(cons "file-option" (match-string-no-properties 1)))
;; Keyword name.
((and (org-match-line "[ \t]*#\\+[a-zA-Z_]*$")
(looking-at-p "[ \t]*$"))
(cons "file-option" nil))
;; Link abbreviation.
((save-excursion
(skip-chars-backward "-A-Za-z0-9_")
(and (eq ?\[ (char-before))
(eq ?\[ (char-before (1- (point))))))
(cons "link" nil))
;; Entities. Some of them accept numbers, but only at their end.
;; So, we first skip numbers, then letters.
((eq ?\\ (save-excursion
(skip-chars-backward "0-9")
(skip-chars-backward "a-zA-Z")
(char-before)))
(cons "tex" nil))
;; Tags on a headline.
((and (org-match-line
(format "\\*+ \\(?:.+? \\)?\\(:\\)\\(\\(?::\\|%s\\)+\\)?[ \t]*$"
org-tag-re))
(or (org-point-in-group (point) 2)
(= (point) (match-end 1))))
(cons "tag" nil))
;; TODO keywords on an empty headline.
((and (string-match "^\\*+ +\\S-*$" line-to-here)
(looking-at-p "[ \t]*$"))
(cons "todo" nil))
;; Heading after a star for search strings or links.
((save-excursion
(skip-chars-backward "^*" (line-beginning-position))
(and (eq ?* (char-before))
(eq (char-before (1- (point))) '?\[)
(eq (char-before (- (point) 2)) '?\[)))
(cons "searchhead" nil))
;; Property or drawer name, depending on point. If point is at
;; a valid location for a node property, offer completion on all
;; node properties in the buffer. Otherwise, offer completion on
;; all drawer names, including "PROPERTIES".
((and (string-match "^[ \t]*:\\S-*$" line-to-here)
(looking-at-p "[ \t]*$"))
(let ((origin (line-beginning-position)))
(if (org-before-first-heading-p) (cons "drawer" nil)
(save-excursion
(org-end-of-meta-data)
(if (or (= origin (point))
(not (org-match-line "[ \t]*:PROPERTIES:[ \t]*$")))
(cons "drawer" nil)
(while (org-match-line org-property-re)
(forward-line))
(if (= origin (point)) (cons "prop" nil)
(cons "drawer" nil)))))))
(t nil))))
(defun org-pcomplete-case-double (list)
"Return list with both upcase and downcase version of all strings in LIST."
(let (e res)
(while (setq e (pop list))
(setq res (cons (downcase e) (cons (upcase e) res))))
(nreverse res)))
;;; Completion API
(defun org-command-at-point ()
"Return the qualified name of the Org completion entity at point.
When completing for #+STARTUP, for example, this function returns
\"file-option/startup\"."
(let ((thing (org-thing-at-point)))
(cond
((string= "file-option" (car thing))
(concat (car thing)
(and (cdr thing) (concat "/" (downcase (cdr thing))))))
((string= "block-option" (car thing))
(concat (car thing) "/" (downcase (cdr thing))))
(t (car thing)))))
(defun org-parse-arguments ()
"Parse whitespace separated arguments in the current region."
(if (equal (cons "searchhead" nil) (org-thing-at-point))
;; [[* foo<point> bar link::search option.
;; Arguments are not simply space-separated.
(save-excursion
(let ((origin (point)))
(skip-chars-backward "^*" (line-beginning-position))
(cons (list (buffer-substring-no-properties (point) origin))
(list (point)))))
(let ((begin (line-beginning-position))
(end (line-end-position))
begins args)
(save-restriction
(narrow-to-region begin end)
(save-excursion
(goto-char (point-min))
(while (not (eobp))
(skip-chars-forward " \t\n[")
(setq begins (cons (point) begins))
(skip-chars-forward "^ \t\n[")
(setq args (cons (buffer-substring-no-properties
(car begins) (point))
args)))
(cons (reverse args) (reverse begins)))))))
(defun org-pcomplete-initial ()
"Call the right completion function for first argument completions."
(ignore
(funcall (or (pcomplete-find-completion-function
(car (org-thing-at-point)))
pcomplete-default-completion-function))))
;;; Completion functions
(defun pcomplete/org-mode/file-option ()
"Complete against all valid file options."
(require 'org-element)
(pcomplete-here
(org-pcomplete-case-double
(append (mapcar (lambda (keyword) (concat keyword " "))
org-options-keywords)
(mapcar (lambda (keyword) (concat keyword ": "))
org-element-affiliated-keywords)
(let (block-names)
(dolist (name
'("CENTER" "COMMENT" "EXAMPLE" "EXPORT" "QUOTE" "SRC"
"VERSE")
block-names)
(push (format "END_%s" name) block-names)
(push (concat "BEGIN_"
name
;; Since language is compulsory in
;; export blocks source blocks, add
;; a space.
(and (member name '("EXPORT" "SRC")) " "))
block-names)
(push (format "ATTR_%s: " name) block-names)))
(mapcar (lambda (keyword) (concat keyword ": "))
(org-get-export-keywords))))
(substring pcomplete-stub 2)))
(defun pcomplete/org-mode/file-option/author ()
"Complete arguments for the #+AUTHOR file option."
(pcomplete-here (list user-full-name)))
(defun pcomplete/org-mode/file-option/date ()
"Complete arguments for the #+DATE file option."
(pcomplete-here (list (format-time-string (org-time-stamp-format)))))
(defun pcomplete/org-mode/file-option/email ()
"Complete arguments for the #+EMAIL file option."
(pcomplete-here (list user-mail-address)))
(defun pcomplete/org-mode/file-option/exclude_tags ()
"Complete arguments for the #+EXCLUDE_TAGS file option."
(require 'ox)
(pcomplete-here
(and org-export-exclude-tags
(list (mapconcat #'identity org-export-exclude-tags " ")))))
(defun pcomplete/org-mode/file-option/filetags ()
"Complete arguments for the #+FILETAGS file option."
(pcomplete-here (and org-file-tags (mapconcat #'identity org-file-tags " "))))
(defun pcomplete/org-mode/file-option/language ()
"Complete arguments for the #+LANGUAGE file option."
(require 'ox)
(pcomplete-here
(pcomplete-uniquify-list
(list org-export-default-language "en"))))
(defun pcomplete/org-mode/file-option/priorities ()
"Complete arguments for the #+PRIORITIES file option."
(pcomplete-here (list (format "%c %c %c"
org-priority-highest
org-priority-lowest
org-priority-default))))
(defun pcomplete/org-mode/file-option/select_tags ()
"Complete arguments for the #+SELECT_TAGS file option."
(require 'ox)
(pcomplete-here
(and org-export-select-tags
(list (mapconcat #'identity org-export-select-tags " ")))))
(defun pcomplete/org-mode/file-option/startup ()
"Complete arguments for the #+STARTUP file option."
(while (pcomplete-here
(let ((opts (pcomplete-uniquify-list
(mapcar #'car org-startup-options))))
;; Some options are mutually exclusive, and shouldn't be completed
;; against if certain other options have already been seen.
(dolist (arg pcomplete-args)
(cond
((string= arg "hidestars")
(setq opts (delete "showstars" opts)))))
opts))))
(defun pcomplete/org-mode/file-option/tags ()
"Complete arguments for the #+TAGS file option."
(pcomplete-here
(list (org-tag-alist-to-string org-current-tag-alist))))
(defun pcomplete/org-mode/file-option/title ()
"Complete arguments for the #+TITLE file option."
(pcomplete-here
(let ((visited-file (buffer-file-name (buffer-base-buffer))))
(list (or (and visited-file
(file-name-sans-extension
(file-name-nondirectory visited-file)))
(buffer-name (buffer-base-buffer)))))))
(defun pcomplete/org-mode/file-option/options ()
"Complete arguments for the #+OPTIONS file option."
(while (pcomplete-here
(pcomplete-uniquify-list
(append
;; Hard-coded OPTION items always available.
'("H:" "\\n:" "num:" "timestamp:" "arch:" "author:" "c:"
"creator:" "date:" "d:" "email:" "*:" "e:" "::" "f:"
"inline:" "tex:" "p:" "pri:" "':" "-:" "stat:" "^:" "toc:"
"|:" "tags:" "tasks:" "<:" "todo:")
;; OPTION items from registered backends.
(let (items)
(dolist (backend (bound-and-true-p
org-export-registered-backends))
(dolist (option (org-export-backend-options backend))
(let ((item (nth 2 option)))
(when item (push (concat item ":") items)))))
items))))))
(defun pcomplete/org-mode/file-option/infojs_opt ()
"Complete arguments for the #+INFOJS_OPT file option."
(while (pcomplete-here
(pcomplete-uniquify-list
(mapcar (lambda (item) (format "%s:" (car item)))
(bound-and-true-p org-html-infojs-opts-table))))))
(defun pcomplete/org-mode/file-option/bind ()
"Complete arguments for the #+BIND file option, which are variable names."
(let (vars)
(mapatoms
(lambda (a) (when (boundp a) (setq vars (cons (symbol-name a) vars)))))
(pcomplete-here vars)))
(defun pcomplete/org-mode/link ()
"Complete against defined #+LINK patterns."
(pcomplete-here
(pcomplete-uniquify-list
(copy-sequence
(mapcar (lambda (e) (concat (car e) ":"))
(append org-link-abbrev-alist-local
org-link-abbrev-alist))))))
(defun pcomplete/org-mode/tex ()
"Complete against TeX-style HTML entity names."
(require 'org-entities)
(while (pcomplete-here
(pcomplete-uniquify-list
(remove nil (mapcar #'car-safe org-entities)))
(substring pcomplete-stub 1))))
(defun pcomplete/org-mode/todo ()
"Complete against known TODO keywords."
(pcomplete-here (pcomplete-uniquify-list (copy-sequence org-todo-keywords-1))))
(defun pcomplete/org-mode/searchhead ()
"Complete against all headings.
This needs more work, to handle headings with lots of spaces in them."
(while (pcomplete-here
(save-excursion
(goto-char (point-min))
(let (tbl)
(while (re-search-forward org-outline-regexp nil t)
;; Remove the leading asterisk from
;; `org-link-heading-search-string' result.
(push (substring (org-link-heading-search-string) 1) tbl))
(pcomplete-uniquify-list tbl))))))
(defun pcomplete/org-mode/tag ()
"Complete a tag name. Omit tags already set."
(while (pcomplete-here
(mapcar (lambda (x) (concat x ":"))
(let ((lst (pcomplete-uniquify-list
(or (remq
nil
(mapcar (lambda (x) (org-string-nw-p (car x)))
org-current-tag-alist))
(mapcar #'car (org-get-buffer-tags))))))
(dolist (tag (org-get-tags nil t))
(setq lst (delete tag lst)))
lst))
(and (string-match ".*:" pcomplete-stub)
(substring pcomplete-stub (match-end 0)))
t)))
(defun pcomplete/org-mode/drawer ()
"Complete a drawer name, including \"PROPERTIES\"."
(pcomplete-here
(org-pcomplete-case-double
(mapcar (lambda (x) (concat x ":"))
(let ((names (list "PROPERTIES")))
(save-excursion
(goto-char (point-min))
(while (re-search-forward org-drawer-regexp nil t)
(let ((drawer (org-element-at-point)))
(when (org-element-type-p drawer '(drawer property-drawer))
(push (org-element-property :drawer-name drawer) names)
(goto-char (org-element-end drawer))))))
(pcomplete-uniquify-list names))))
(substring pcomplete-stub 1))) ;remove initial colon
(defun pcomplete/org-mode/prop ()
"Complete a property name. Omit properties already set."
(pcomplete-here
(org-pcomplete-case-double
(mapcar (lambda (x)
(concat x ": "))
(let ((lst (pcomplete-uniquify-list
(copy-sequence (org-buffer-property-keys nil t t)))))
(dolist (prop (org-entry-properties))
(setq lst (delete (car prop) lst)))
lst)))
(substring pcomplete-stub 1)))
(defun pcomplete/org-mode/block-option/src ()
"Complete the arguments of a source block.
Complete a language in the first field, the header arguments and
switches."
(pcomplete-here
(mapcar
(lambda(x) (symbol-name (nth 3 x)))
(cdr (car (cdr (memq :key-type (plist-get
(symbol-plist
'org-babel-load-languages)
'custom-type)))))))
(let* ((info (org-babel-get-src-block-info 'no-eval))
(lang (car info))
(lang-headers (intern (concat "org-babel-header-args:" lang)))
(headers (org-babel-combine-header-arg-lists
org-babel-common-header-args-w-values
(and (boundp lang-headers) (eval lang-headers t)))))
(while (pcomplete-here
(append (mapcar
(lambda (arg) (format ":%s" (symbol-name (car arg))))
headers)
'("-n" "-r" "-l"))))))
(defun pcomplete/org-mode/block-option/clocktable ()
"Complete keywords in a clocktable line."
(while (pcomplete-here '(":maxlevel" ":scope" ":lang"
":tstart" ":tend" ":block" ":step"
":stepskip0" ":fileskip0"
":emphasize" ":link" ":narrow" ":indent"
":hidefiles" ":tcolumns" ":level" ":compact"
":timestamp" ":formula" ":formatter"
":wstart" ":mstart"))))
;;; Finish up
(provide 'org-pcomplete)
;;; org-pcomplete.el ends here
org-mode-9.7.29+dfsg/lisp/org-persist.el 0000664 0000000 0000000 00000170325 15004304337 0020030 0 ustar 00root root 0000000 0000000 ;;; org-persist.el --- Persist cached data across Emacs sessions -*- lexical-binding: t; -*-
;; Copyright (C) 2021-2025 Free Software Foundation, Inc.
;; Author: Ihor Radchenko <yantar92 at posteo dot net>
;; Maintainer: Ihor Radchenko <yantar92 at posteo dot net>
;; Keywords: cache, storage
;; 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; This file implements persistent cache storage across Emacs sessions.
;; Both global and buffer-local data can be stored. This
;; implementation is not meant to be used to store important data -
;; all the caches should be safe to remove at any time.
;;
;; Entry points are `org-persist-register', `org-persist-write',
;; `org-persist-read', and `org-persist-load'.
;;
;; `org-persist-register' will mark the data to be stored. By
;; default, the data is written on disk before exiting Emacs session.
;; Optionally, the data can be written immediately.
;;
;; `org-persist-write' will immediately write the data onto disk.
;;
;; `org-persist-read' will read the data and return its value or list
;; of values for each requested container.
;;
;; `org-persist-load' will read the data with side effects. For
;; example, loading `elisp' container will assign the values to
;; variables.
;;
;; Example usage:
;;
;; 1. Temporarily cache Elisp symbol value to disk. Remove upon
;; closing Emacs:
;; (org-persist-write 'variable-symbol)
;; (org-persist-read 'variable-symbol) ;; read the data later
;;
;; 2. Temporarily cache a remote URL file to disk. Remove upon
;; closing Emacs:
;; (org-persist-write 'url "https://static.fsf.org/common/img/logo-new.png")
;; (org-persist-read 'url "https://static.fsf.org/common/img/logo-new.png")
;; `org-persist-read' will return the cached file location or nil if cached file
;; has been removed.
;;
;; 3. Temporarily cache a file, including TRAMP path to disk:
;; (org-persist-write 'file "/path/to/file")
;;
;; 4. Cache file or URL while some other file exists.
;; (org-persist-register '(url "https://static.fsf.org/common/img/logo-new.png") '(:file "/path to the other file") :expiry 'never :write-immediately t)
;; or, if the other file is current buffer file
;; (org-persist-register '(url "https://static.fsf.org/common/img/logo-new.png") (current-buffer) :expiry 'never :write-immediately t)
;;
;; 5. Cache value of a Elisp variable to disk. The value will be
;; saved and restored automatically (except buffer-local
;; variables).
;; ;; Until `org-persist-default-expiry'
;; (org-persist-register 'variable-symbol)
;; ;; Specify expiry explicitly
;; (org-persist-register 'variable-symbol :expiry 'never)
;; ;; Save buffer-local variable (buffer-local will not be
;; ;; autoloaded!)
;; (org-persist-register 'org-element--cache (current-buffer))
;; ;; Save several buffer-local variables preserving circular links
;; ;; between:
;; (org-persist-register 'org-element--headline-cache (current-buffer)
;; :inherit 'org-element--cache)
;;
;; 6. Load variable by side effects assigning variable symbol:
;; (org-persist-load 'variable-symbol (current-buffer))
;;
;; 7. Version variable value:
;; (org-persist-register '((elisp variable-symbol) (version "2.0")))
;;
;; 8. Define a named container group:
;;
;; (let ((info1 "test")
;; (info2 "test 2"))
;; (org-persist-register
;; `("Named data" (elisp info1 local) (elisp info2 local))
;; nil :write-immediately t))
;; (org-persist-read
;; "Named data"
;; nil nil nil :read-related t) ; => ("Named data" "test" "test2")
;;
;; 9. Cancel variable persistence:
;; (org-persist-unregister 'variable-symbol 'all) ; in all buffers
;; (org-persist-unregister 'variable-symbol) ;; global variable
;; (org-persist-unregister 'variable-symbol (current-buffer)) ;; buffer-local
;;
;; Most common data type is variable data. However, other data types
;; can also be stored.
;;
;; Persistent data is stored in individual files. Each of the files
;; can contain a collection of related data, which is particularly
;; useful when, say, several variables cross-reference each-other's
;; data-cells and we want to preserve their circular structure.
;;
;; Each data collection can be associated with a local or remote file,
;; its inode number, contents hash. The persistent data collection
;; can later be accessed using either file buffer, file, inode, or
;; contents hash.
;;
;; The data collections can be versioned and removed upon expiry.
;;
;; In the code below, I will use the following naming conventions:
;;
;; 1. Container :: a type of data to be stored
;; Containers can store elisp variables, files, and version
;; numbers. Each container can be customized with container
;; options. For example, `elisp' container is customized with
;; variable symbol. (elisp variable) is a container storing
;; Lisp variable value. Similarly, (version "2.0") container
;; will store version number.
;;
;; Container can also refer to a group of containers:
;;
;; ;; Three containers stored together.
;; '((elisp variable) (file "/path") (version "x.x"))
;;
;; Providing a single container from the list to `org-persist-read'
;; is sufficient to retrieve all the containers (with appropriate
;; optional parameter).
;;
;; Example:
;;
;; (org-persist-register '((version "My data") (file "/path/to/file")) '(:key "key") :write-immediately t)
;; (org-persist-read '(version "My data") '(:key "key") :read-related t) ;; => '("My data" "/path/to/file/copy")
;;
;; Individual containers can also take a short form (not a list):
;;
;; '("String" file '(quoted elisp "value") :keyword)
;; is the same with
;; '((elisp-data "String") (file nil)
;; (elisp-data '(quoted elisp "value")) (elisp-data :keyword))
;;
;; Note that '(file "String" (elisp value)) would be interpreted as
;; `file' container with "String" path and extra options. See
;; `org-persist--normalize-container'.
;;
;; 2. Associated :: an object the container is associated with. The
;; object can be a buffer, file, inode number, file contents hash,
;; a generic key, or multiple of them. Associated can also be nil.
;;
;; Example:
;;
;; '(:file "/path/to/file" :inode number :hash buffer-hash :key arbitrary-key)
;;
;; When several objects are associated with a single container, it
;; is not necessary to provide them all to access the container.
;; Just using a single :file/:inode/:hash/:key is sufficient. This
;; way, one can retrieve cached data even when the file has moved -
;; by contents hash.
;;
;; 3. Data collection :: a list of containers, the associated
;; object/objects, expiry, access time, and information about where
;; the cache is stored. Each data collection can also have
;; auxiliary records. Their only purpose is readability of the
;; collection index.
;;
;; Example:
;;
;; (:container
;; ((index "2.7"))
;; :persist-file "ba/cef3b7-e31c-4791-813e-8bd0bf6c5f9c"
;; :associated nil :expiry never
;; :last-access 1672207741.6422956 :last-access-hr "2022-12-28T09:09:01+0300")
;;
;; 4. Index file :: a file listing all the stored data collections.
;;
;; 5. Persist file :: a file holding data values or references to
;; actual data values for a single data collection. This file
;; contains an alist associating each data container in data
;; collection with its value or a reference to the actual value.
;;
;; Example (persist file storing two elisp container values):
;;
;; (((elisp org-element--headline-cache) . #s(avl-tree- ...))
;; ((elisp org-element--cache) . #s(avl-tree- ...)))
;;
;; All the persistent data is stored in `org-persist-directory'. The data
;; collections are listed in `org-persist-index-file' and the actual data is
;; stored in UID-style subfolders.
;;
;; The `org-persist-index-file' stores the value of `org-persist--index'.
;;
;; Each collection is represented as a plist containing the following
;; properties:
;;
;; - `:container' : list of data containers to be stored in single
;; file;
;; - `:persist-file': data file name;
;; - `:associated' : list of associated objects;
;; - `:last-access' : last date when the container has been accessed;
;; - `:expiry' : list of expiry conditions.
;; - all other keywords are ignored
;;
;; The available types of data containers are:
;; 1. (elisp variable-symbol scope) or just variable-symbol :: Storing
;; elisp variable data. SCOPE can be
;;
;; - `nil' :: Use buffer-local value in associated :file or global
;; value if no :file is associated.
;; - string :: Use buffer-local value in buffer named STRING or
;; with STRING `buffer-file-name'.
;; - `local' :: Use symbol value in current scope.
;; Note: If `local' scope is used without writing the
;; value immediately, the actual stored value is
;; undefined.
;;
;; 2. (file) :: Store a copy of the associated file preserving the
;; extension.
;; (file "/path/to/a/file") :: Store a copy of the file in path.
;;
;; 3. (version "version number") :: Version the data collection.
;; If the stored collection has different version than "version
;; number", disregard it.
;;
;; 4. (url) :: Store a downloaded copy of URL object given by
;; associated :file.
;; (url "path") :: Use "path" instead of associated :file.
;;
;; The data collections can expire, in which case they will be removed
;; from the persistent storage at the end of Emacs session. The
;; expiry condition can be set when saving/registering data
;; containers. The expirty condition can be `never' - data will never
;; expire; nil - data will expire at the end of current Emacs session;
;; a number - data will expire after the number days from last access;
;; a function - data will expire if the function, called with a single
;; argument - collection, returns non-nil.
;;
;;
;; Data collections associated with files will automatically expire
;; when the file is removed. If the associated file is remote, the
;; expiry is controlled by `org-persist-remote-files' instead.
;;
;; Data loading/writing can be more accurately controlled using
;; `org-persist-before-write-hook', `org-persist-before-read-hook',
;; and `org-persist-after-read-hook'.
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'org-compat)
(require 'org-id)
(require 'xdg nil t)
(declare-function org-back-to-heading "org" (&optional invisible-ok))
(declare-function org-next-visible-heading "org" (arg))
(declare-function org-at-heading-p "org" (&optional invisible-not-ok))
;; Silence byte-compiler (used in `org-persist--write-elisp-file').
(defvar pp-use-max-width)
(defconst org-persist--storage-version "3.2"
"Persistent storage layout version.")
(defgroup org-persist nil
"Persistent cache for Org mode."
:tag "Org persist"
:group 'org)
(defcustom org-persist-directory
(expand-file-name
(org-file-name-concat
(let ((cache-dir (when (fboundp 'xdg-cache-home)
(xdg-cache-home))))
(if (or (seq-empty-p cache-dir)
(not (file-exists-p cache-dir))
(file-exists-p (org-file-name-concat
user-emacs-directory
"org-persist")))
user-emacs-directory
cache-dir))
"org-persist/"))
"Directory where the data is stored."
:group 'org-persist
:package-version '(Org . "9.6")
:type 'directory)
(defcustom org-persist-remote-files 100
"Whether to keep persistent data for remote files.
When this variable is nil, never save persistent data associated with
remote files. When t, always keep the data. When
`check-existence', contact remote server containing the file and only
keep the data when the file exists on the server. When a number, keep
up to that number persistent values for remote files.
Note that the last option `check-existence' may cause Emacs to show
password prompts to log in."
:group 'org-persist
:package-version '(Org . "9.6")
:type '(choice (const :tag "Never" nil)
(const :tag "Always" t)
(number :tag "Keep not more than X files")
(const :tag "Check if exist on remote" check-existence)))
(defcustom org-persist-default-expiry 30
"Default expiry condition for persistent data.
When this variable is nil, all the data vanishes at the end of Emacs
session. When `never', the data never vanishes. When a number, the
data is deleted that number days after last access. When a function,
it should be a function returning non-nil when the data is expired. The
function will be called with a single argument - collection."
:group 'org-persist
:package-version '(Org . "9.6")
:type '(choice (const :tag "Never" never)
(const :tag "Always" nil)
(number :tag "Keep N days")
(function :tag "Function")))
(defconst org-persist-index-file "index.eld"
"File name used to store the data index.")
(defconst org-persist-gc-lock-file "gc-lock.eld"
"File used to store information about active Emacs sessions.
The file contains an alist of (`before-init-time' . LAST-ACTIVE-TIME).
`before-init-time' uniquely identifies Emacs process and
LAST-ACTIVE-TIME is written every `org-persist-gc-lock-interval'
seconds. When LAST-ACTIVE-TIME is more than
`org-persist-gc-lock-expiry' seconds ago, that Emacs session is
considered not active.")
(defvar org-persist-gc-lock-interval (* 60 60) ; 1 hour
"Interval in seconds for refreshing `org-persist-gc-lock-file'.")
(defvar org-persist-gc-lock-expiry (* 60 60 24) ; 1 day
"Interval in seconds for expiring a record in `org-persist-gc-lock-file'.")
(defvar org-persist--disable-when-emacs-Q t
"Disable persistence when Emacs is called with -Q command line arg.
When non-nil, this sets `org-persist-directory' to temporary directory.
This variable must be set before loading org-persist library.")
(defvar org-persist-before-write-hook nil
"Abnormal hook ran before saving data.
The hook must accept the same arguments as `org-persist-write'.
The hooks will be evaluated until a hook returns non-nil.
If any of the hooks return non-nil, do not save the data.")
(defvar org-persist-before-read-hook nil
"Abnormal hook ran before reading data.
The hook must accept the same arguments as `org-persist-read'.
The hooks will be evaluated until a hook returns non-nil.
If any of the hooks return non-nil, do not read the data.")
(defvar org-persist-after-read-hook nil
"Abnormal hook ran after reading data.
The hook must accept the same arguments as `org-persist-read'.")
(defvar org-persist--index nil
"Global index.
The index is a list of plists. Each plist contains information about
persistent data storage. Each plist contains the following
properties:
- `:container' : list of data containers to be stored in single file
- `:persist-file': data file name
- `:associated' : list of associated objects
- `:last-access' : last date when the container has been read
- `:expiry' : list of expiry conditions
- all other keywords are ignored.")
(defvar org-persist--index-hash nil
"Hash table storing `org-persist--index'. Used for quick access.
The keys are conses of (container . associated).")
(defvar org-persist--index-age nil
"The modification time of the index file, when it was loaded.")
(defvar org-persist--report-time nil
"Whether to report read/write time.
When the value is a number, it is a threshold number of seconds. If
the read/write time of a single persist file exceeds the threshold, a
message is displayed.
When the value is a non-nil non-number, always display the message.
When the value is nil, never display the message.")
;;;; Common functions
(defun org-persist--display-time (duration format &rest args)
"Report DURATION according to FORMAT + ARGS message.
FORMAT and ARGS are passed to `message'."
(when (or (and org-persist--report-time
(numberp org-persist--report-time)
(>= duration org-persist--report-time))
(and org-persist--report-time
(not (numberp org-persist--report-time))))
(apply #'message
(format "org-persist: %s took %%.2f sec" format)
(append args (list duration)))))
(defun org-persist--read-elisp-file (&optional buffer-or-file)
"Read elisp data from BUFFER-OR-FILE or current buffer."
(let (;; UTF-8 is explicitly used in `org-persist--write-elisp-file'.
(coding-system-for-read 'emacs-internal)
(buffer-or-file (or buffer-or-file (current-buffer))))
(with-temp-buffer
(if (bufferp buffer-or-file)
(set-buffer buffer-or-file)
(insert-file-contents buffer-or-file))
(condition-case err
(let ((read-circle t)
(start-time (float-time)))
;; FIXME: Reading sometimes fails to read circular objects.
;; I suspect that it happens when we have object reference
;; #N# read before object definition #N=. If it is really
;; so, it should be Emacs bug - either in `read' or in
;; `prin1'. Meanwhile, just fail silently when `read'
;; fails to parse the saved cache object.
(prog1
(read (current-buffer))
(org-persist--display-time
(- (float-time) start-time)
"Reading from %S" buffer-or-file)))
;; Recover gracefully if index file is corrupted.
(error
;; Remove problematic file.
(unless (bufferp buffer-or-file) (delete-file buffer-or-file))
;; Do not report the known error to user.
(if (string-match-p "Invalid read syntax" (error-message-string err))
(message "Emacs reader failed to read data in %S. The error was: %S"
buffer-or-file (error-message-string err))
(warn "Emacs reader failed to read data in %S. The error was: %S"
buffer-or-file (error-message-string err)))
nil)))))
;; FIXME: `pp' is very slow when writing even moderately large datasets
;; We should probably drop it or find some fast formatter.
(defun org-persist--write-elisp-file (file data &optional no-circular pp)
"Write elisp DATA to FILE."
;; Fsync slightly reduces the chance of an incomplete filesystem
;; write, however on modern hardware its effectiveness is
;; questionable and it is insufficient to guarantee complete writes.
;; Coupled with the significant performance hit if writing many
;; small files, it simply does not make sense to use fsync here,
;; particularly as cache corruption is only a minor inconvenience.
;; With all this in mind, we ensure `write-region-inhibit-fsync' is
;; set.
;;
;; To read more about this, see the comments in Emacs's fileio.c, in
;; particular the large comment block in init_fileio.
(let ((write-region-inhibit-fsync t)
;; We set UTF-8 here and in `org-persist--read-elisp-file'
;; to avoid the overhead from `find-auto-coding'.
(coding-system-for-write 'emacs-internal)
(print-circle (not no-circular))
print-level
print-length
print-quoted
(print-escape-control-characters t)
(print-escape-nonascii t)
(print-continuous-numbering t)
print-number-table
(start-time (float-time)))
(unless (file-exists-p (file-name-directory file))
(make-directory (file-name-directory file) t))
;; Discard cache when there is a clash with other Emacs process.
;; This way, we make sure that cache is never mixing data & record
;; from different processes.
(cl-letf (((symbol-function #'ask-user-about-lock)
(lambda (&rest _)
(error "Other Emacs process is writing to cache"))))
(with-temp-file file
(insert ";; -*- mode: lisp-data; -*-\n")
(if pp
(let ((pp-use-max-width nil)) ; Emacs bug#58687
(pp data (current-buffer)))
(prin1 data (current-buffer)))))
(org-persist--display-time
(- (float-time) start-time)
"Writing to %S" file)))
(defmacro org-persist-gc:generic (container collection)
"Garbage collect CONTAINER data from COLLECTION."
`(let* ((c (org-persist--normalize-container ,container))
(gc-func-symbol (intern (format "org-persist-gc:%s" (car c)))))
(unless (fboundp gc-func-symbol)
(error "org-persist: GC function %s not defined"
gc-func-symbol))
(funcall gc-func-symbol c ,collection)))
(defmacro org-persist--gc-expired-p (cnd collection)
"Check if expiry condition CND triggers for COLLECTION."
`(pcase ,cnd
(`nil t)
(`never nil)
((pred numberp)
(when (plist-get ,collection :last-access)
(> (float-time) (+ (plist-get ,collection :last-access) (* ,cnd 24 60 60)))))
((pred functionp)
(funcall ,cnd ,collection))
(_ (error "org-persist: Unsupported expiry type %S" ,cnd))))
;;;; Working with index
(defmacro org-persist-collection-let (collection &rest body)
"Bind container and associated from COLLECTION and execute BODY."
(declare (debug (form body)) (indent 1))
`(with-no-warnings
(let* ((container (plist-get ,collection :container))
(associated (plist-get ,collection :associated))
(path (plist-get associated :file))
(inode (plist-get associated :inode))
(hash (plist-get associated :hash))
(key (plist-get associated :key)))
;; Suppress "unused variable" warnings.
(ignore container associated path inode hash key)
,@body)))
(defun org-persist--find-index (collection)
"Find COLLECTION in `org-persist--index'."
(org-persist-collection-let collection
(and org-persist--index-hash
(catch :found
(dolist (cont (cons container container))
(let (r)
(setq r (or (gethash (cons cont associated) org-persist--index-hash)
(and path (gethash (cons cont (list :file path)) org-persist--index-hash))
(and inode (gethash (cons cont (list :inode inode)) org-persist--index-hash))
(and hash (gethash (cons cont (list :hash hash)) org-persist--index-hash))
(and key (gethash (cons cont (list :key key)) org-persist--index-hash))))
(when r (throw :found r))))))))
(defun org-persist--add-to-index (collection &optional hash-only)
"Add or update COLLECTION in `org-persist--index'.
When optional HASH-ONLY is non-nil, only modify the hash table.
Return PLIST."
(org-persist-collection-let collection
(let ((existing (org-persist--find-index collection)))
(if existing
(progn
(plist-put existing :container container)
(plist-put (plist-get existing :associated) :file path)
(plist-put (plist-get existing :associated) :inode inode)
(plist-put (plist-get existing :associated) :hash hash)
(plist-put (plist-get existing :associated) :key key)
existing)
(unless hash-only (push collection org-persist--index))
(unless org-persist--index-hash (setq org-persist--index-hash (make-hash-table :test 'equal)))
(dolist (cont (cons container container))
(puthash (cons cont associated) collection org-persist--index-hash)
(when path (puthash (cons cont (list :file path)) collection org-persist--index-hash))
(when inode (puthash (cons cont (list :inode inode)) collection org-persist--index-hash))
(when hash (puthash (cons cont (list :hash inode)) collection org-persist--index-hash))
(when key (puthash (cons cont (list :key inode)) collection org-persist--index-hash)))
collection))))
(defun org-persist--remove-from-index (collection)
"Remove COLLECTION from `org-persist--index'."
(let ((existing (org-persist--find-index collection)))
(when existing
(org-persist-collection-let collection
(dolist (cont (cons container container))
(unless (listp (car container))
(org-persist-gc:generic cont collection)
(dolist (afile (org-persist-associated-files:generic cont collection))
(delete-file afile)))
(remhash (cons cont associated) org-persist--index-hash)
(when path (remhash (cons cont (list :file path)) org-persist--index-hash))
(when inode (remhash (cons cont (list :inode inode)) org-persist--index-hash))
(when hash (remhash (cons cont (list :hash hash)) org-persist--index-hash))
(when key (remhash (cons cont (list :key key)) org-persist--index-hash))))
(setq org-persist--index (delq existing org-persist--index)))))
(defun org-persist--get-collection (container &optional associated misc)
"Return or create collection used to store CONTAINER for ASSOCIATED.
When ASSOCIATED is nil, it is a global CONTAINER.
ASSOCIATED can also be a (:buffer buffer) or buffer, (:file file-path)
or file-path, (:inode inode), (:hash hash), or or (:key key).
MISC, if non-nil will be appended to the collection. It must be a plist."
(unless (and (listp container) (listp (car container)))
(setq container (list container)))
(setq associated (org-persist--normalize-associated associated))
(when (and misc (or (not (listp misc)) (= 1 (% (length misc) 2))))
(error "org-persist: Not a plist: %S" misc))
(or (org-persist--find-index
`( :container ,(org-persist--normalize-container container)
:associated ,associated))
(org-persist--add-to-index
(nconc
(list :container (org-persist--normalize-container container)
:persist-file
(replace-regexp-in-string "^.." "\\&/" (org-id-uuid))
:associated associated)
misc))))
;;;; Reading container data.
(defun org-persist--normalize-container (container &optional inner)
"Normalize CONTAINER representation into (type . settings).
When INNER is non-nil, do not try to match as list of containers."
(pcase container
((or `elisp `elisp-data `version `file `index `url)
`(,container nil))
((or (pred keywordp) (pred stringp) `(quote . ,_))
`(elisp-data ,container))
((pred symbolp)
`(elisp ,container))
(`(,(or `elisp `elisp-data `version `file `index `url) . ,_)
container)
((and (pred listp) (guard (not inner)))
(mapcar (lambda (c) (org-persist--normalize-container c 'inner)) container))
(_ (error "org-persist: Unknown container type: %S" container))))
(defvar org-persist--associated-buffer-cache (make-hash-table :weakness 'key)
"Buffer hash cache.")
(defun org-persist--normalize-associated (associated)
"Normalize ASSOCIATED representation into (:type value)."
(pcase associated
((or (pred stringp) `(:file ,_))
(unless (stringp associated)
(setq associated (cadr associated)))
(let* ((rtn `(:file ,associated))
(inode (and
;; Do not store :inode for remote files - it may
;; be time-consuming on slow connections or even
;; fail completely when ssh connection is closed.
(not (file-remote-p associated))
(fboundp 'file-attribute-inode-number)
(file-attribute-inode-number
(file-attributes associated)))))
(when inode (plist-put rtn :inode inode))
rtn))
((or (pred bufferp) `(:buffer ,_))
(unless (bufferp associated)
(setq associated (cadr associated)))
(let ((cached (gethash associated org-persist--associated-buffer-cache))
file inode hash)
(if (and cached (eq (buffer-modified-tick associated)
(car cached)))
(progn
(setq file (nth 1 cached)
inode (nth 2 cached)
hash (nth 3 cached)))
(setq file (buffer-file-name
(or (buffer-base-buffer associated)
associated)))
(setq inode (when (and file
;; Do not store :inode for remote files - it may
;; be time-consuming on slow connections or even
;; fail completely when ssh connection is closed.
(not (file-remote-p file))
(fboundp 'file-attribute-inode-number))
(file-attribute-inode-number
(file-attributes file))))
(setq hash
;; `secure-hash' may trigger interactive dialog when it
;; cannot determine the coding system automatically.
;; Force coding system that works reliably for any text
;; to avoid it. The hash will be consistent, as long
;; as we use the same coding system.
(let ((coding-system-for-write 'emacs-internal))
(secure-hash 'md5 associated)))
(puthash associated
(list (buffer-modified-tick associated)
file inode hash)
org-persist--associated-buffer-cache))
(let ((rtn `(:hash ,hash)))
(when file (setq rtn (plist-put rtn :file file)))
(when inode (setq rtn (plist-put rtn :inode inode)))
rtn)))
((pred listp)
associated)
(_ (error "Unknown associated object %S" associated))))
(defmacro org-persist-read:generic (container reference-data collection)
"Read and return the data stored in CONTAINER.
REFERENCE-DATA is associated with CONTAINER in the persist file.
COLLECTION is the plist holding data collection."
`(let* ((c (org-persist--normalize-container ,container))
(read-func-symbol (intern (format "org-persist-read:%s" (car c)))))
(setf ,collection (plist-put ,collection :last-access (float-time)))
(setf ,collection (plist-put ,collection :last-access-hr (format-time-string "%FT%T%z" (float-time))))
(unless (fboundp read-func-symbol)
(error "org-persist: Read function %s not defined"
read-func-symbol))
(funcall read-func-symbol c ,reference-data ,collection)))
(defun org-persist-read:elisp (_ lisp-value __)
"Read elisp container and return LISP-VALUE."
lisp-value)
(defun org-persist-read:elisp-data (container _ __)
"Read elisp-data CONTAINER."
(cadr container))
(defalias 'org-persist-read:version #'org-persist-read:elisp-data)
(defun org-persist-read:file (_ path __)
"Read file container from PATH."
(when (and path (file-exists-p (org-file-name-concat org-persist-directory path)))
(org-file-name-concat org-persist-directory path)))
(defun org-persist-read:url (_ path __)
"Read file container from PATH."
(when (and path (file-exists-p (org-file-name-concat org-persist-directory path)))
(org-file-name-concat org-persist-directory path)))
(defun org-persist-read:index (cont index-file _)
"Read index container CONT from INDEX-FILE."
(when (file-exists-p index-file)
(let ((index (org-persist--read-elisp-file index-file)))
(when index
(catch :found
(dolist (collection index)
(org-persist-collection-let collection
(when (and (not associated)
(pcase container
(`((index ,version))
(equal version (cadr cont)))
(_ nil)))
(throw :found index)))))))))
;;;; Applying container data for side effects.
(defmacro org-persist-load:generic (container reference-data collection)
"Load the data stored in CONTAINER for side effects.
REFERENCE-DATA is associated with CONTAINER in the persist file.
COLLECTION is the plist holding data collection."
`(let* ((container (org-persist--normalize-container ,container))
(load-func-symbol (intern (format "org-persist-load:%s" (car container)))))
(setf ,collection (plist-put ,collection :last-access (float-time)))
(setf ,collection (plist-put ,collection :last-access-hr (format-time-string "%FT%T%z" (float-time))))
(unless (fboundp load-func-symbol)
(error "org-persist: Load function %s not defined"
load-func-symbol))
(funcall load-func-symbol container ,reference-data ,collection)))
(defun org-persist-load:elisp (container lisp-value collection)
"Assign elisp CONTAINER in COLLECTION LISP-VALUE."
(let ((lisp-symbol (cadr container))
(buffer (when (plist-get (plist-get collection :associated) :file)
(get-file-buffer (plist-get (plist-get collection :associated) :file)))))
(if buffer
(with-current-buffer buffer
(make-variable-buffer-local lisp-symbol)
(set lisp-symbol lisp-value))
(set lisp-symbol lisp-value))))
(defalias 'org-persist-load:elisp-data #'org-persist-read:elisp-data)
(defalias 'org-persist-load:version #'org-persist-read:version)
(defalias 'org-persist-load:file #'org-persist-read:file)
(defun org-persist-load:index (container index-file _)
"Load `org-persist--index' from INDEX-FILE according to CONTAINER."
(unless org-persist--index
(setq org-persist--index (org-persist-read:index container index-file nil)
org-persist--index-hash nil
org-persist--index-age (file-attribute-modification-time
(file-attributes index-file)))
(if org-persist--index
(mapc (lambda (collection) (org-persist--add-to-index collection 'hash)) org-persist--index)
(setq org-persist--index nil)
(when (file-exists-p org-persist-directory)
(dolist (file (directory-files org-persist-directory 'absolute
"\\`[^.][^.]"))
(if (file-directory-p file)
(delete-directory file t)
(delete-file file))))
(plist-put (org-persist--get-collection container) :expiry 'never))))
(defun org-persist--load-index ()
"Load `org-persist--index'."
(org-persist-load:index
`(index ,org-persist--storage-version)
(org-file-name-concat org-persist-directory org-persist-index-file)
nil))
;;;; Writing container data
(defmacro org-persist-write:generic (container collection)
"Write CONTAINER in COLLECTION."
`(let* ((c (org-persist--normalize-container ,container))
(write-func-symbol (intern (format "org-persist-write:%s" (car c)))))
(unless (plist-get ,collection :last-access)
(setf ,collection (plist-put ,collection :last-access (float-time)))
(setf ,collection (plist-put ,collection :last-access-hr (format-time-string "%FT%T%z" (float-time)))))
(unless (fboundp write-func-symbol)
(error "org-persist: Write function %s not defined"
write-func-symbol))
(funcall write-func-symbol c ,collection)))
(defun org-persist-write:elisp (container collection)
"Write elisp CONTAINER according to COLLECTION."
(let ((scope (nth 2 container)))
(pcase scope
((pred stringp)
(when-let* ((buf (or (get-buffer scope)
(get-file-buffer scope))))
;; FIXME: There is `buffer-local-boundp' introduced in Emacs 28.
;; Not using it yet to keep backward compatibility.
(condition-case nil
(buffer-local-value (cadr container) buf)
(void-variable nil))))
(`local
(when (boundp (cadr container))
(symbol-value (cadr container))))
(`nil
(if-let* ((buf (and (plist-get (plist-get collection :associated) :file)
(get-file-buffer (plist-get (plist-get collection :associated) :file)))))
;; FIXME: There is `buffer-local-boundp' introduced in Emacs 28.
;; Not using it yet to keep backward compatibility.
(condition-case nil
(buffer-local-value (cadr container) buf)
(void-variable nil))
(when (boundp (cadr container))
(symbol-value (cadr container))))))))
(defalias 'org-persist-write:elisp-data #'ignore)
(defalias 'org-persist-write:version #'ignore)
(defun org-persist-write:file (c collection)
"Write file container C according to COLLECTION."
(org-persist-collection-let collection
(when (or (and path (file-exists-p path))
(and (stringp (cadr c)) (file-exists-p (cadr c))))
(when (and (stringp (cadr c)) (file-exists-p (cadr c)))
(setq path (cadr c)))
(let* ((persist-file (plist-get collection :persist-file))
(ext (file-name-extension path))
(file-copy (org-file-name-concat
org-persist-directory
(format "%s-%s.%s" persist-file (md5 path) ext))))
(unless (file-exists-p file-copy)
(unless (file-exists-p (file-name-directory file-copy))
(make-directory (file-name-directory file-copy) t))
(copy-file path file-copy 'overwrite))
(format "%s-%s.%s" persist-file (md5 path) ext)))))
(defun org-persist-write:url (c collection)
"Write url container C according to COLLECTION."
(org-persist-collection-let collection
(when (or path (cadr c))
(when (cadr c) (setq path (cadr c)))
(let* ((persist-file (plist-get collection :persist-file))
(ext (file-name-extension path))
(file-copy (org-file-name-concat
org-persist-directory
(format "%s-%s.%s" persist-file (md5 path) ext))))
(unless (file-exists-p file-copy)
(unless (file-exists-p (file-name-directory file-copy))
(make-directory (file-name-directory file-copy) t))
(if (org--should-fetch-remote-resource-p path)
(url-copy-file path file-copy 'overwrite)
(error "The remote resource %S is considered unsafe, and will not be downloaded"
path)))
(format "%s-%s.%s" persist-file (md5 path) ext)))))
(defun org-persist--check-write-access (path)
"Check write access to all missing directories in PATH.
Show message and return nil if there is no write access.
Otherwise, return t."
(let* ((dir (directory-file-name (file-name-as-directory path)))
(prev dir))
(while (and (not (file-exists-p dir))
(setq prev dir)
(not (equal dir (setq dir (directory-file-name
(file-name-directory dir)))))))
(if (file-writable-p prev) t ; return t
(message "org-persist: Missing write access rights to: %S" prev)
;; return nil
nil)))
(defun org-persist-write:index (container _)
"Write index CONTAINER."
(org-persist--get-collection container)
(unless (file-exists-p org-persist-directory)
(condition-case nil
(make-directory org-persist-directory 'parent)
(t
(warn "Failed to create org-persist storage in %s."
org-persist-directory)
(org-persist--check-write-access org-persist-directory))))
(when (file-exists-p org-persist-directory)
(let ((index-file
(org-file-name-concat org-persist-directory org-persist-index-file)))
(org-persist--merge-index-with-disk)
(org-persist--write-elisp-file index-file org-persist--index t)
(setq org-persist--index-age
(file-attribute-modification-time (file-attributes index-file)))
index-file)))
(defun org-persist--save-index ()
"Save `org-persist--index'."
(org-persist-write:index
`(index ,org-persist--storage-version) nil))
(defun org-persist--merge-index-with-disk ()
"Merge `org-persist--index' with the current index file on disk."
(let* ((index-file
(org-file-name-concat org-persist-directory org-persist-index-file))
(disk-index
(and (file-exists-p index-file)
(org-file-newer-than-p index-file org-persist--index-age)
(org-persist-read:index `(index ,org-persist--storage-version) index-file nil)))
(combined-index
(org-persist--merge-index org-persist--index disk-index)))
(when disk-index
(setq org-persist--index combined-index
org-persist--index-age
(file-attribute-modification-time (file-attributes index-file))))))
(defun org-persist--merge-index (base other)
"Attempt to merge new index items in OTHER into BASE.
Items with different details are considered too difficult, and skipped."
(if other
(let ((new (cl-set-difference other base :test #'equal))
(base-files (mapcar (lambda (s) (plist-get s :persist-file)) base))
(combined (reverse base)))
(dolist (item (nreverse new))
(unless (or (memq 'index (mapcar #'car (plist-get item :container)))
(not (file-exists-p
(org-file-name-concat org-persist-directory
(plist-get item :persist-file))))
(member (plist-get item :persist-file) base-files))
(push item combined)))
(nreverse combined))
base))
;;;; Public API
(cl-defun org-persist-register (container &optional associated &rest misc
&key inherit
&key (expiry org-persist-default-expiry)
&key (write-immediately nil)
&allow-other-keys)
"Register CONTAINER in ASSOCIATED to be persistent across Emacs sessions.
Optional key INHERIT makes CONTAINER dependent on another container.
Such dependency means that data shared between variables will be
preserved (see elisp#Circular Objects).
Optional key EXPIRY will set the expiry condition of the container.
It can be `never', nil - until end of session, a number of days since
last access, or a function accepting a single argument - collection.
EXPIRY key has no effect when INHERIT is non-nil.
Optional key WRITE-IMMEDIATELY controls whether to save the container
data immediately.
MISC will be appended to the collection. It must be alternating :KEY
VALUE pairs.
When WRITE-IMMEDIATELY is non-nil, the return value will be the same
with `org-persist-write'."
(unless org-persist--index (org-persist--load-index))
(setq container (org-persist--normalize-container container))
(when inherit
(setq inherit (org-persist--normalize-container inherit))
(let ((inherited-collection (org-persist--get-collection inherit associated))
new-collection)
(unless (member container (plist-get inherited-collection :container))
(setq new-collection
(plist-put (copy-sequence inherited-collection) :container
(cons container (plist-get inherited-collection :container))))
(org-persist--remove-from-index inherited-collection)
(org-persist--add-to-index new-collection))))
(let ((collection (org-persist--get-collection container associated misc)))
(when (and expiry (not inherit))
(when expiry (plist-put collection :expiry expiry))))
(when (or (bufferp associated) (bufferp (plist-get associated :buffer)))
(with-current-buffer (if (bufferp associated)
associated
(plist-get associated :buffer))
(add-hook 'kill-buffer-hook #'org-persist-write-all-buffer nil 'local)))
(when write-immediately (org-persist-write container associated)))
(cl-defun org-persist-unregister (container &optional associated &key remove-related)
"Unregister CONTAINER in ASSOCIATED to be persistent.
When ASSOCIATED is `all', unregister CONTAINER everywhere.
When REMOVE-RELATED is non-nil, remove all the containers stored with
the CONTAINER as well."
(unless org-persist--index (org-persist--load-index))
(setq container (org-persist--normalize-container container))
(if (eq associated 'all)
(mapc (lambda (collection)
(when (member container (plist-get collection :container))
(org-persist-unregister container (plist-get collection :associated) :remove-related remove-related)))
org-persist--index)
(setq associated (org-persist--normalize-associated associated))
(let ((collection (org-persist--find-index `(:container ,container :associated ,associated))))
(when collection
(if (or remove-related (= (length (plist-get collection :container)) 1))
(org-persist--remove-from-index collection)
(plist-put collection :container
(remove container (plist-get collection :container)))
(org-persist--add-to-index collection))))))
(cl-defun org-persist-read (container &optional associated hash-must-match load &key read-related)
"Restore CONTAINER data for ASSOCIATED.
When HASH-MUST-MATCH is non-nil, do not restore data if hash for
ASSOCIATED file or buffer does not match.
ASSOCIATED can be a plist, a buffer, or a string.
A buffer is treated as (:buffer ASSOCIATED).
A string is treated as (:file ASSOCIATED).
When LOAD is non-nil, load the data instead of reading.
When READ-RELATED is non-nil, return the data stored alongside with
CONTAINER as well. For example:
(let ((info \"test\"))
(org-persist-register
\\=`(\"My data\" (elisp-data ,info))
nil :write-immediately t))
(org-persist-read \"My data\") ; => \"My data\"
(org-persist-read \"My data\" nil nil nil
:read-related t) ; => (\"My data\" \"test\")"
(unless org-persist--index (org-persist--load-index))
(setq associated (org-persist--normalize-associated associated))
(setq container (org-persist--normalize-container container))
(let* ((collection (org-persist--find-index `(:container ,container :associated ,associated)))
(persist-file
(when collection
(org-file-name-concat
org-persist-directory
(plist-get collection :persist-file))))
(data nil))
(when (and collection
(or (not (plist-get collection :expiry)) ; current session
(not (org-persist--gc-expired-p
(plist-get collection :expiry) collection)))
(or (not hash-must-match)
(and (plist-get associated :hash)
(equal (plist-get associated :hash)
(plist-get (plist-get collection :associated) :hash))))
(or (file-exists-p persist-file)
;; Attempt to write data if it is not yet written.
(progn
(org-persist-write container associated 'no-read)
(file-exists-p persist-file))))
(unless (seq-find (lambda (v)
(run-hook-with-args-until-success 'org-persist-before-read-hook v associated))
(plist-get collection :container))
(setq data (org-persist--read-elisp-file persist-file))
(when data
(cl-loop for c in (plist-get collection :container)
with result = nil
do
(when (or read-related
(equal c container)
(member c container))
(if load
(push (org-persist-load:generic c (alist-get c data nil nil #'equal) collection) result)
(push (org-persist-read:generic c (alist-get c data nil nil #'equal) collection) result)))
(run-hook-with-args 'org-persist-after-read-hook c associated)
finally return (if (= 1 (length result)) (car result) (nreverse result))))))))
(cl-defun org-persist-load (container &optional associated hash-must-match &key read-related)
"Load CONTAINER data for ASSOCIATED.
The arguments CONTAINER, ASSOCIATED, HASH-MUST-MATCH, and READ-RELATED
have the same meaning as in `org-persist-read'."
(org-persist-read container associated hash-must-match t :read-related read-related))
(defun org-persist-load-all (&optional associated)
"Restore all the persistent data associated with ASSOCIATED."
(unless org-persist--index (org-persist--load-index))
(setq associated (org-persist--normalize-associated associated))
(let (all-containers)
(dolist (collection org-persist--index)
(when collection
(cl-pushnew (plist-get collection :container) all-containers :test #'equal)))
(dolist (container all-containers)
(condition-case err
(org-persist-load container associated t)
(error
(message "%s. Deleting bad index entry." err)
(org-persist--remove-from-index (org-persist--find-index `(:container ,container :associated ,associated)))
nil)))))
(defun org-persist-load-all-buffer ()
"Call `org-persist-load-all' in current buffer."
(org-persist-load-all (current-buffer)))
(defun org-persist-write (container &optional associated ignore-return)
"Save CONTAINER according to ASSOCIATED.
ASSOCIATED can be a plist, a buffer, or a string.
A buffer is treated as (:buffer ASSOCIATED).
A string is treated as (:file ASSOCIATED).
The return value is nil when writing fails and the written value (as
returned by `org-persist-read') on success.
When IGNORE-RETURN is non-nil, just return t on success without calling
`org-persist-read'."
(setq associated (org-persist--normalize-associated associated))
;; Update hash
(when (and (plist-get associated :file)
(plist-get associated :hash)
(get-file-buffer (plist-get associated :file)))
(setq associated (org-persist--normalize-associated (get-file-buffer (plist-get associated :file)))))
(let ((collection (org-persist--get-collection container associated)))
(setf collection (plist-put collection :associated associated))
(unless (or
;; Prevent data leakage from encrypted files.
;; We do it in somewhat paranoid manner and do not
;; allow anything related to encrypted files to be
;; written.
(and (plist-get associated :file)
(string-match-p epa-file-name-regexp (plist-get associated :file)))
(seq-find (lambda (v)
(run-hook-with-args-until-success 'org-persist-before-write-hook v associated))
(plist-get collection :container)))
(when (or (file-exists-p org-persist-directory) (org-persist--save-index))
(let ((file (org-file-name-concat org-persist-directory (plist-get collection :persist-file)))
(data (mapcar (lambda (c) (cons c (org-persist-write:generic c collection)))
(plist-get collection :container))))
(org-persist--write-elisp-file file data)
(or ignore-return (org-persist-read container associated)))))))
(defun org-persist-write-all (&optional associated)
"Save all the persistent data.
When ASSOCIATED is non-nil, only save the matching data."
(unless org-persist--index (org-persist--load-index))
(setq associated (org-persist--normalize-associated associated))
(if
(and (equal 1 (length org-persist--index))
;; The single collection only contains a single container
;; in the container list.
(equal 1 (length (plist-get (car org-persist--index) :container)))
;; The container is an `index' container.
(eq 'index (caar (plist-get (car org-persist--index) :container)))
(or (not (file-exists-p org-persist-directory))
(org-directory-empty-p org-persist-directory)))
;; Do not write anything, and clear up `org-persist-directory' to reduce
;; clutter.
(when (and (file-exists-p org-persist-directory)
(org-directory-empty-p org-persist-directory))
(delete-directory org-persist-directory))
;; Write the data.
(let (all-containers)
(dolist (collection org-persist--index)
(if associated
(when collection
(cl-pushnew (plist-get collection :container) all-containers :test #'equal))
(condition-case err
(org-persist-write (plist-get collection :container) (plist-get collection :associated) t)
(error
(message "%s. Deleting bad index entry." err)
(org-persist--remove-from-index collection)
nil))))
(dolist (container all-containers)
(let ((collection (org-persist--find-index `(:container ,container :associated ,associated))))
(when collection
(condition-case err
(org-persist-write container associated t)
(error
(message "%s. Deleting bad index entry." err)
(org-persist--remove-from-index collection)
nil))))))))
(defun org-persist-write-all-buffer ()
"Call `org-persist-write-all' in current buffer.
Do nothing in an indirect buffer."
(unless (buffer-base-buffer (current-buffer))
(org-persist-write-all (current-buffer))))
(defalias 'org-persist-gc:elisp #'ignore)
(defalias 'org-persist-gc:index #'ignore)
(defalias 'org-persist-gc:elisp-data #'ignore)
(defalias 'org-persist-gc:version #'ignore)
(defalias 'org-persist-gc:file #'ignore)
(defalias 'org-persist-gc:url #'ignore)
(defun org-persist--gc-persist-file (persist-file)
"Garbage collect PERSIST-FILE."
(when (file-exists-p persist-file)
(delete-file persist-file)
(when (org-directory-empty-p (file-name-directory persist-file))
(delete-directory (file-name-directory persist-file)))))
(defmacro org-persist-associated-files:generic (container collection)
"List associated files in `org-persist-directory' of CONTAINER in COLLECTION."
`(let* ((c (org-persist--normalize-container ,container))
(assocf-func-symbol (intern (format "org-persist-associated-files:%s" (car c)))))
(if (fboundp assocf-func-symbol)
(funcall assocf-func-symbol c ,collection)
(error "org-persist: Read function %s not defined"
assocf-func-symbol))))
(defalias 'org-persist-associated-files:elisp #'ignore)
(defalias 'org-persist-associated-files:index #'ignore)
(defalias 'org-persist-associated-files:elisp-data #'ignore)
(defalias 'org-persist-associated-files:version #'ignore)
(defun org-persist-associated-files:file (container collection)
"List file CONTAINER associated files of COLLECTION in `org-persist-directory'."
(let ((file (org-persist-read container (plist-get collection :associated))))
(when (and file (file-exists-p file))
(list file))))
(defun org-persist-associated-files:url (container collection)
"List url CONTAINER associated files of COLLECTION in `org-persist-directory'."
(let ((file (org-persist-read container (plist-get collection :associated))))
(when (file-exists-p file)
(list file))))
(defun org-persist--refresh-gc-lock ()
"Refresh session timestamp in `org-persist-gc-lock-file'.
Remove expired sessions timestamps."
(let* ((file (org-file-name-concat org-persist-directory org-persist-gc-lock-file))
(alist (when (file-exists-p file) (org-persist--read-elisp-file file)))
new-alist)
(setf (alist-get before-init-time alist nil nil #'equal)
(current-time))
(dolist (record alist)
(when (< (- (float-time (cdr record)) (float-time (current-time)))
org-persist-gc-lock-expiry)
(push record new-alist)))
(ignore-errors (org-persist--write-elisp-file file new-alist))))
(defun org-persist--gc-orphan-p ()
"Return non-nil, when orphan files should be garbage-collected.
Remove current sessions from `org-persist-gc-lock-file'."
(let* ((file (org-file-name-concat org-persist-directory org-persist-gc-lock-file))
(alist (when (file-exists-p file) (org-persist--read-elisp-file file))))
(setq alist (org-assoc-delete-all before-init-time alist))
(ignore-errors (org-persist--write-elisp-file file alist))
;; Only GC orphan files when there are no active sessions.
(not alist)))
(defun org-persist-gc ()
"Remove expired or unregistered containers and orphaned files.
Also, remove containers associated with non-existing files."
(if org-persist--index
(org-persist--merge-index-with-disk)
(org-persist--load-index))
(let (new-index
(remote-files-num 0)
(orphan-files
(when (org-persist--gc-orphan-p) ; also removes current session from lock file.
(delete (org-file-name-concat org-persist-directory org-persist-index-file)
(when (file-exists-p org-persist-directory)
(directory-files-recursively org-persist-directory ".+"))))))
(dolist (collection org-persist--index)
(let* ((file (plist-get (plist-get collection :associated) :file))
(web-file (and file (string-match-p "\\`https?://" file)))
(file-remote (when file (file-remote-p file)))
(persist-file (when (plist-get collection :persist-file)
(org-file-name-concat
org-persist-directory
(plist-get collection :persist-file))))
(expired? (org-persist--gc-expired-p
(plist-get collection :expiry) collection)))
(when persist-file
(setq orphan-files (delete persist-file orphan-files))
(when (and file (not web-file))
(when file-remote (cl-incf remote-files-num))
(unless (if (not file-remote)
(file-exists-p file)
(pcase org-persist-remote-files
('t t)
('check-existence
(file-exists-p file))
((pred numberp)
(< org-persist-remote-files remote-files-num))
(_ nil)))
(setq expired? t)))
(if expired?
(org-persist--gc-persist-file persist-file)
(push collection new-index)
(dolist (container (plist-get collection :container))
(dolist (associated-file
(org-persist-associated-files:generic
container collection))
(setq orphan-files (delete associated-file orphan-files))))))))
(mapc #'org-persist--gc-persist-file orphan-files)
(setq org-persist--index (nreverse new-index))))
(defun org-persist-clear-storage-maybe ()
"Clear `org-persist-directory' according to `org-persist--disable-when-emacs-Q'.
When `org-persist--disable-when-emacs-Q' is non-nil and Emacs is called with -Q
command line argument, `org-persist-directory' is created in potentially public
system temporary directory. Remove everything upon existing Emacs in
such scenario."
(when (and org-persist--disable-when-emacs-Q
;; FIXME: This is relying on undocumented fact that
;; Emacs sets `user-init-file' to nil when loaded with
;; "-Q" argument.
(not user-init-file)
(file-exists-p org-persist-directory))
(delete-directory org-persist-directory 'recursive)))
;; Point to temp directory when `org-persist--disable-when-emacs-Q' is set.
(when (and org-persist--disable-when-emacs-Q
;; FIXME: This is relying on undocumented fact that
;; Emacs sets `user-init-file' to nil when loaded with
;; "-Q" argument.
(not user-init-file))
(setq org-persist-directory
(make-temp-file "org-persist-" 'dir)))
;; Automatically write the data, but only when we have write access.
(when (org-persist--check-write-access org-persist-directory)
(add-hook 'kill-emacs-hook #'org-persist-clear-storage-maybe) ; Run last.
(add-hook 'kill-emacs-hook #'org-persist-write-all)
;; `org-persist-gc' should run before `org-persist-write-all'.
;; So we are adding the hook after `org-persist-write-all'.
(add-hook 'kill-emacs-hook #'org-persist-gc))
(add-hook 'after-init-hook #'org-persist-load-all)
(defvar org-persist--refresh-gc-lock-timer nil
"Timer used to refresh session timestamp in `org-persist-gc-lock-file'.")
(unless (and org-persist--disable-when-emacs-Q
;; FIXME: This is relying on undocumented fact that
;; Emacs sets `user-init-file' to nil when loaded with
;; "-Q" argument.
(not user-init-file))
(unless org-persist--refresh-gc-lock-timer
(setq org-persist--refresh-gc-lock-timer
(run-at-time nil org-persist-gc-lock-interval #'org-persist--refresh-gc-lock))))
(provide 'org-persist)
;;; org-persist.el ends here
org-mode-9.7.29+dfsg/lisp/org-plot.el 0000664 0000000 0000000 00000066272 15004304337 0017322 0 ustar 00root root 0000000 0000000 ;;; org-plot.el --- Support for Plotting from Org -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2025 Free Software Foundation, Inc.
;;
;; Author: Eric Schulte <schulte dot eric at gmail dot com>
;; Maintainer: TEC <orgmode@tec.tecosaur.net>
;; Keywords: tables, plotting
;; URL: https://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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Borrows ideas and a couple of lines of code from org-exp.el.
;; Thanks to the Org mailing list for testing and implementation and
;; feature suggestions
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'cl-lib)
(require 'org)
(require 'org-table)
(declare-function gnuplot-delchar-or-maybe-eof "ext:gnuplot" (arg))
(declare-function gnuplot-mode "ext:gnuplot" ())
(declare-function gnuplot-send-buffer-to-gnuplot "ext:gnuplot" ())
(defvar org-plot/gnuplot-default-options
'((:plot-type . 2d)
(:with . lines)
(:ind . 0))
"Default options to gnuplot used by `org-plot/gnuplot'.")
(defvar org-plot-timestamp-fmt nil)
(defun org-plot/add-options-to-plist (p options)
"Parse an OPTIONS line and set values in the property list P.
Returns the resulting property list."
(when options
(let ((op '(("type" . :plot-type)
("script" . :script)
("line" . :line)
("set" . :set)
("title" . :title)
("ind" . :ind)
("deps" . :deps)
("with" . :with)
("file" . :file)
("labels" . :labels)
("map" . :map)
("timeind" . :timeind)
("timefmt" . :timefmt)
("min" . :ymin)
("ymin" . :ymin)
("max" . :ymax)
("ymax" . :ymax)
("xmin" . :xmin)
("xmax" . :xmax)
("ticks" . :ticks)
("trans" . :transpose)
("transpose" . :transpose)))
(multiples '("set" "line"))
(regexp ":\\([\"][^\"]+?[\"]\\|[(][^)]+?[)]\\|[^ \t\n\r;,.]*\\)")
(start 0))
(dolist (o op)
(if (member (car o) multiples) ;; keys with multiple values
(while (string-match
(concat (regexp-quote (car o)) regexp)
options start)
(setq start (match-end 0))
(setq p (plist-put p (cdr o)
(cons (car (read-from-string
(match-string 1 options)))
(plist-get p (cdr o)))))
p)
(if (string-match (concat (regexp-quote (car o)) regexp)
options)
(setq p (plist-put p (cdr o)
(car (read-from-string
(match-string 1 options))))))))))
p)
(defun org-plot/goto-nearest-table ()
"Move the point forward to the beginning of nearest table.
Return value is the point at the beginning of the table."
(interactive) (move-beginning-of-line 1)
(while (not (or (org-at-table-p) (< 0 (forward-line 1)))))
(goto-char (org-table-begin)))
(defun org-plot/collect-options (&optional params)
"Collect options from an org-plot `#+Plot:' line.
Accepts an optional property list PARAMS, to which the options
will be added. Returns the resulting property list."
(interactive)
(let ((line (thing-at-point 'line)))
(if (string-match "#\\+PLOT: +\\(.*\\)$" line)
(org-plot/add-options-to-plist params (match-string 1 line))
params)))
(defun org-plot-quote-timestamp-field (s)
"Convert field S from timestamp to Unix time and export to gnuplot."
(format-time-string org-plot-timestamp-fmt (org-time-string-to-time s)))
(defun org-plot-quote-tsv-field (s)
"Quote field S for export to gnuplot."
(if (string-match org-table-number-regexp s) s
(if (string-match org-ts-regexp3 s)
(org-plot-quote-timestamp-field s)
(concat "\"" (mapconcat 'identity (split-string s "\"") "\"\"") "\""))))
(defun org-plot/gnuplot-to-data (table data-file params)
"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
(setq-local org-plot-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-plot-quote-tsv-field)
params))))
nil)
(defun org-plot/gnuplot-to-grid-data (table data-file params)
"Export the data in TABLE to DATA-FILE for gnuplot.
This means in a format appropriate for grid plotting by gnuplot.
PARAMS specifies which columns of TABLE should be plotted as independent
and dependent variables."
(interactive)
(let* ((ind (- (plist-get params :ind) 1))
(deps (if (plist-member params :deps)
(mapcar (lambda (val) (- val 1)) (plist-get params :deps))
(let (collector)
(dotimes (col (length (nth 0 table)))
(setf collector (cons col collector)))
collector)))
(counter 0)
row-vals)
(when (>= ind 0) ;; collect values of ind col
(setf row-vals (mapcar (lambda (row) (setf counter (+ 1 counter))
(cons counter (nth ind row)))
table)))
(when (or deps (>= ind 0)) ;; remove non-plotting columns
(setf deps (delq ind deps))
(setf table (mapcar (lambda (row)
(dotimes (col (length row))
(unless (memq col deps)
(setf (nth col row) nil)))
(delq nil row))
table)))
;; write table to gnuplot grid datafile format
(with-temp-file data-file
(let ((num-rows (length table)) (num-cols (length (nth 0 table)))
(gnuplot-row (lambda (col row value)
(setf col (+ 1 col)) (setf row (+ 1 row))
(format "%f %f %f\n%f %f %f\n"
col (- row 0.5) value ;; lower edge
col (+ row 0.5) value))) ;; upper edge
front-edge back-edge)
(dotimes (col num-cols)
(dotimes (row num-rows)
(setf back-edge
(concat back-edge
(funcall gnuplot-row (- col 1) row
(string-to-number (nth col (nth row table))))))
(setf front-edge
(concat front-edge
(funcall gnuplot-row col row
(string-to-number (nth col (nth row table)))))))
;; only insert once per row
(insert back-edge) (insert "\n") ;; back edge
(insert front-edge) (insert "\n") ;; front edge
(setf back-edge "") (setf front-edge ""))))
row-vals))
(defun org--plot/values-stats (nums &optional hard-min hard-max)
"Rudimentary statistics about NUMS, useful for guessing axis ticks.
If HARD-MIN or HARD-MAX are set, they will be used instead of the min/max
of the NUMS."
(let* ((minimum (or hard-min (apply #'min nums)))
(maximum (or hard-max (apply #'max nums)))
(range (- maximum minimum))
(rangeOrder (if (= range 0) 0
(ceiling (- 1 (log range 10)))))
(range-factor (expt 10 rangeOrder))
(nice-min (if (= range 0) (car nums)
(/ (float (floor (* minimum range-factor))) range-factor)))
(nice-max (if (= range 0) (car nums)
(/ (float (ceiling (* maximum range-factor))) range-factor))))
`(:min ,minimum :max ,maximum :range ,range
:range-factor ,range-factor
:nice-min ,nice-min :nice-max ,nice-max :nice-range ,(- nice-max nice-min))))
(defun org--plot/sensible-tick-num (table &optional hard-min hard-max)
"From a the values in a TABLE of data, guess an appropriate number of ticks.
If HARD-MIN and HARD-MAX can be used to fix the ends of the axis."
(let* ((row-data
(mapcar (lambda (row) (org--plot/values-stats
(mapcar #'string-to-number (cdr row))
hard-min
hard-max)) table))
(row-normalised-ranges (mapcar (lambda (r-data)
(let ((val (round (*
(plist-get r-data :range-factor)
(plist-get r-data :nice-range)))))
(if (= (% val 10) 0) (/ val 10) val)))
row-data))
(range-prime-decomposition (mapcar #'org--plot/prime-factors row-normalised-ranges))
(weighted-factors (sort (apply #'org--plot/merge-alists #'+ 0
(mapcar (lambda (factors) (org--plot/item-frequencies factors t))
range-prime-decomposition))
(lambda (a b) (> (cdr a) (cdr b))))))
(apply #'* (org--plot/nice-frequency-pick weighted-factors))))
(defun org--plot/nice-frequency-pick (frequencies)
"From a list of FREQUENCIES, try to sensibly pick a sample of the most frequent."
;; TODO this mosly works decently, but could do with some tweaking to work more consistently.
(cl-case (length frequencies)
(1 (list (car (nth 0 frequencies))))
(2 (if (<= 3 (/ (cdr (nth 0 frequencies))
(cdr (nth 1 frequencies))))
(make-list 2
(car (nth 0 frequencies)))
(list (car (nth 0 frequencies))
(car (nth 1 frequencies)))))
(t
(let* ((total-count (apply #'+ (mapcar #'cdr frequencies)))
(n-freq (mapcar (lambda (freq) `(,(car freq) . ,(/ (float (cdr freq)) total-count))) frequencies))
(f-pick (list (car (car n-freq))))
(1-2-ratio (/ (cdr (nth 0 n-freq))
(cdr (nth 1 n-freq))))
(2-3-ratio (/ (cdr (nth 1 n-freq))
(cdr (nth 2 n-freq))))
(1-3-ratio (* 1-2-ratio 2-3-ratio))
(1-val (car (nth 0 n-freq)))
(2-val (car (nth 1 n-freq)))
(3-val (car (nth 2 n-freq))))
(when (> 1-2-ratio 4) (push 1-val f-pick))
(when (and (< 1-2-ratio 2-val)
(< (* (apply #'* f-pick) 2-val) 30))
(push 2-val f-pick))
(when (and (< 1-3-ratio 3-val)
(< (* (apply #'* f-pick) 3-val) 30))
(push 3-val f-pick))
f-pick))))
(defun org--plot/merge-alists (function default alist1 alist2 &rest alists)
"Using FUNCTION, combine the elements of ALIST1, ALIST2 and any other ALISTS.
When an element is only present in one alist, DEFAULT is used as the second
argument for the FUNCTION."
(when (> (length alists) 0)
(setq alist2 (apply #'org--plot/merge-alists function default alist2 alists)))
(cl-flet ((keys (alist) (mapcar #'car alist))
(lookup (key alist) (or (cdr (assoc key alist)) default)))
(cl-loop with keys = (cl-union (keys alist1) (keys alist2) :test 'equal)
for k in keys collect
(cons k (funcall function (lookup k alist1) (lookup k alist2))))))
(defun org--plot/item-frequencies (values &optional normalize)
"Return an alist indicating the frequency of values in VALUES list.
When NORMALIZE is non-nil, the count is divided by the number of values."
(let ((normaliser (if normalize (float (length values)) 1)))
(cl-loop for (n . m) in (seq-group-by #'identity values)
collect (cons n (/ (length m) normaliser)))))
(defun org--plot/prime-factors (value)
"Return the prime decomposition of VALUE, e.g. for 12, (3 2 2)."
(let ((factors '(1)) (i 1))
(while (/= 1 value)
(setq i (1+ i))
(when (eq 0 (% value i))
(push i factors)
(setq value (/ value i))
(setq i (1- i))
))
(cl-subseq factors 0 -1)))
(defgroup org-plot nil
"Options for plotting in Org mode."
:tag "Org Plot"
:group 'org)
(defcustom org-plot/gnuplot-script-preamble ""
"String of function to be inserted before the gnuplot plot command is run.
Note that this is in addition to, not instead of other content generated in
`org-plot/gnuplot-script'. If a function, it is called with the plot type as
the argument, and must return a string to be used."
:group 'org-plot
:type '(choice string function))
(defcustom org-plot/preset-plot-types
'((2d :plot-cmd "plot"
:check-ind-type t
:plot-func
(lambda (_table data-file num-cols params plot-str)
(let* ((type (plist-get params :plot-type))
(with (if (eq type 'grid) 'pm3d (plist-get params :with)))
(ind (plist-get params :ind))
(deps (if (plist-member params :deps) (plist-get params :deps)))
(text-ind (or (plist-get params :textind)
(eq (plist-get params :with) 'histograms)))
(col-labels (plist-get params :labels))
res)
(dotimes (col num-cols res)
(unless (and (eq type '2d)
(or (and ind (equal (1+ col) ind))
(and deps (not (member (1+ col) deps)))))
(setf res
(cons
(format plot-str data-file
(or (and ind (> ind 0)
(not text-ind)
(format "%d:" ind)) "")
(1+ col)
(if text-ind (format ":xticlabel(%d)" ind) "")
with
(or (nth col col-labels)
(format "%d" (1+ col))))
res)))))))
(3d :plot-cmd "splot"
:plot-pre (lambda (_table _data-file _num-cols params _plot-str)
(if (plist-get params :map) "set map"))
:plot-func
(lambda (_table data-file _num-cols params _plot-str)
(let* ((type (plist-get params :plot-type))
(with (if (eq type 'grid) 'pm3d (plist-get params :with))))
(list (format "'%s' matrix with %s title ''"
data-file with)))))
(grid :plot-cmd "splot"
:plot-pre (lambda (_table _data-file _num-cols params _plot-str)
(if (plist-get params :map) "set pm3d map" "set map"))
:data-dump (lambda (table data-file params _num-cols)
(let ((y-labels (org-plot/gnuplot-to-grid-data
table data-file params)))
(when y-labels (plist-put params :ylabels y-labels))))
:plot-func
(lambda (table data-file _num-cols params _plot-str)
(let* ((type (plist-get params :plot-type))
(with (if (eq type 'grid) 'pm3d (plist-get params :with))))
(list (format "'%s' with %s title ''"
data-file with)))))
(radar :plot-func
(lambda (table _data-file _num-cols params plot-str)
(list (org--plot/radar table params)))))
"List of plists describing the available plot types.
The car is the type name, and the property :plot-func must be
set. The value of :plot-func is a lambda which yields plot-lines
\(a list of strings) as the cdr.
All lambda functions have the parameters of
`org-plot/gnuplot-script' and PLOT-STR passed to them. i.e. they
are called with the following signature: (TABLE DATA-FILE
NUM-COLS PARAMS PLOT-STR)
Potentially useful parameters in PARAMS include:
:set :line :map :title :file :ind :timeind :timefmt :textind
:deps :labels :xlabels :ylabels :xmin :xmax :ymin :ymax :ticks
In addition to :plot-func, the following optional properties may
be set.
- :plot-cmd - A gnuplot command appended to each plot-line.
Accepts string or nil. Default value: nil.
- :check-ind-type - Whether the types of ind values should be checked.
Accepts boolean.
- :plot-str - the formula string passed to :plot-func as PLOT-STR
Accepts string. Default value: \"'%s' using %s%d%s with %s title '%s'\"
- :data-dump - Function to dump the table to a datafile for ease of
use.
Accepts lambda function. Default lambda body:
(org-plot/gnuplot-to-data table data-file params)
- :plot-pre - Gnuplot code to be inserted early into the script, just
after term and output have been set.
Accepts string, nil, or lambda function which returns string
or nil. Defaults to nil."
:group 'org-plot
:type 'alist)
(defvar org--plot/radar-template
"### spider plot/chart with gnuplot
# also known as: radar chart, web chart, star chart, cobweb chart,
# radar plot, web plot, star plot, cobweb plot, etc. ...
set datafile separator ' '
set size square
unset tics
set angles degree
set key bmargin center horizontal
unset border
# Load data and setup
load \"%s\"
# General settings
DataColCount = words($Data[1])-1
AxesCount = |$Data|-HeaderLines-1
AngleOffset = 90
Max = 1
d=0.1*Max
Direction = -1 # counterclockwise=1, clockwise = -1
# Tic settings
TicCount = %s
TicOffset = 0.1
TicValue(axis,i) = real(i)*(word($Settings[axis],3)-word($Settings[axis],2)) \\
/ word($Settings[axis],4)+word($Settings[axis],2)
TicLabelPosX(axis,i) = PosX(axis,i/TicCount) + PosY(axis, TicOffset)
TicLabelPosY(axis,i) = PosY(axis,i/TicCount) - PosX(axis, TicOffset)
TicLen = 0.03
TicdX(axis,i) = 0.5*TicLen*cos(alpha(axis)-90)
TicdY(axis,i) = 0.5*TicLen*sin(alpha(axis)-90)
# Label
LabOffset = 0.10
LabX(axis) = PosX(axis+1,Max+2*d) + PosY(axis, LabOffset)
LabY(axis) = PosY($0+1,Max+2*d)
# Functions
alpha(axis) = (axis-1)*Direction*360.0/AxesCount+AngleOffset
PosX(axis,R) = R*cos(alpha(axis))
PosY(axis,R) = R*sin(alpha(axis))
Scale(axis,value) = real(value-word($Settings[axis],2))/(word($Settings[axis],3)-word($Settings[axis],2))
# Spider settings
set style arrow 1 dt 1 lw 1.0 @fgal head filled size 0.06,25 # style for axes
set style arrow 2 dt 2 lw 0.5 @fgal nohead # style for weblines
set style arrow 3 dt 1 lw 1 @fgal nohead # style for axis tics
set samples AxesCount
set isosamples TicCount
set urange[1:AxesCount]
set vrange[1:TicCount]
set style fill transparent solid 0.2
set xrange[-Max-4*d:Max+4*d]
set yrange[-Max-4*d:Max+4*d]
plot \\
'+' u (0):(0):(PosX($0,Max+d)):(PosY($0,Max+d)) w vec as 1 not, \\
$Data u (LabX($0)): \\
(LabY($0)):1 every ::HeaderLines w labels center enhanced @fgt not, \\
for [i=1:DataColCount] $Data u (PosX($0+1,Scale($0+1,column(i+1)))): \\
(PosY($0+1,Scale($0+1,column(i+1)))) every ::HeaderLines w filledcurves lt i title word($Data[1],i+1), \\
%s
# '++' u (PosX($1,$2/TicCount)-TicdX($1,$2/TicCount)): \\
# (PosY($1,$2/TicCount)-TicdY($1,$2/TicCount)): \\
# (2*TicdX($1,$2/TicCount)):(2*TicdY($1,$2/TicCount)) \\
# w vec as 3 not, \\
### end of code
")
(defvar org--plot/radar-ticks
" '++' u (PosX($1,$2/TicCount)):(PosY($1,$2/TicCount)): \\
(PosX($1+1,$2/TicCount)-PosX($1,$2/TicCount)): \\
(PosY($1+1,$2/TicCount)-PosY($1,$2/TicCount)) w vec as 2 not, \\
'++' u (TicLabelPosX(%s,$2)):(TicLabelPosY(%s,$2)): \\
(sprintf('%%g',TicValue(%s,$2))) w labels font ',8' @fgat not")
(defvar org--plot/radar-setup-template
"# Data
$Data <<HEREHAVESOMEDATA
%s
HEREHAVESOMEDATA
HeaderLines = 1
# Settings for scale and offset adjustments
# axis min max tics axisLabelXoff axisLabelYoff
$Settings <<EOD
%s
EOD
")
(defun org--plot/radar (table params)
"Create gnuplot code for a radar plot of TABLE with PARAMS."
(let* ((data
(concat "\"" (mapconcat #'identity (plist-get params :labels) "\" \"") "\""
"\n"
(mapconcat (lambda (row)
(format
"\"%s\" %s"
(car row)
(mapconcat #'identity (cdr row) " ")))
(append table (list (car table)))
"\n")))
(ticks (or (plist-get params :ticks)
(org--plot/sensible-tick-num table
(plist-get params :ymin)
(plist-get params :ymax))))
(settings
(mapconcat (lambda (row)
(let ((data (org--plot/values-stats
(mapcar #'string-to-number (cdr row)))))
(format
"\"%s\" %s %s %s"
(car row)
(or (plist-get params :ymin)
(plist-get data :nice-min))
(or (plist-get params :ymax)
(plist-get data :nice-max))
(if (eq ticks 0) 2 ticks)
)))
(append table (list (car table)))
"\n"))
(setup-file (make-temp-file "org-plot-setup")))
(let ((coding-system-for-write 'utf-8))
(write-region (format org--plot/radar-setup-template data settings) nil setup-file nil :silent))
(format org--plot/radar-template
setup-file
(if (eq ticks 0) 2 ticks)
(if (eq ticks 0) ""
(apply #'format org--plot/radar-ticks
(make-list 3 (if (and (plist-get params :ymin)
(plist-get params :ymax))
;; FIXME multi-drawing of tick labels with "1"
"1" "$1")))))))
(defcustom org-plot/gnuplot-term-extra ""
"String or function which provides the extra term options.
E.g. a value of \"size 1050,650\" would cause
\"set term ... size 1050,650\" to be used.
If a function, it is called with the plot type as the argument."
:group 'org-plot
:type '(choice string function))
(defun org-plot/gnuplot-script (table data-file num-cols params &optional preface)
"Write a gnuplot script for TABLE to DATA-FILE respecting options in PARAMS.
NUM-COLS controls the number of columns plotted in a 2-d plot.
Optional argument PREFACE returns only option parameters in a
manner suitable for prepending to a user-specified script."
(let* ((type-name (plist-get params :plot-type))
(type (cdr (assoc type-name org-plot/preset-plot-types))))
(unless type
(user-error "Org-plot type `%s' is undefined" type-name))
(let* ((sets (plist-get params :set))
(lines (plist-get params :line))
(title (plist-get params :title))
(file (plist-get params :file))
(time-ind (plist-get params :timeind))
(timefmt (plist-get params :timefmt))
(x-labels (plist-get params :xlabels))
(y-labels (plist-get params :ylabels))
(plot-str (or (plist-get type :plot-str)
"'%s' using %s%d%s with %s title '%s'"))
(plot-cmd (plist-get type :plot-cmd))
(plot-pre (plist-get type :plot-pre))
(script "reset")
;; ats = add-to-script
(ats (lambda (line) (when line (setf script (concat script "\n" line)))))
plot-lines)
;; handle output file, background, and size
(funcall ats (format "set term %s %s"
(if file (file-name-extension file) "GNUTERM")
(if (stringp org-plot/gnuplot-term-extra)
org-plot/gnuplot-term-extra
(funcall org-plot/gnuplot-term-extra type))))
(when file ; output file
(funcall ats (format "set output '%s'" (expand-file-name file))))
(when plot-pre
(funcall ats (funcall plot-pre table data-file num-cols params plot-str)))
(funcall ats
(if (stringp org-plot/gnuplot-script-preamble)
org-plot/gnuplot-script-preamble
(funcall org-plot/gnuplot-script-preamble type)))
(when title (funcall ats (format "set title '%s'" title))) ; title
(mapc ats lines) ; line
(dolist (el sets) (funcall ats (format "set %s" el))) ; set
;; Unless specified otherwise, values are TAB separated.
(unless (string-match-p "^set datafile separator" script)
(funcall ats "set datafile separator \"\\t\""))
(when x-labels ; x labels (xtics)
(funcall ats
(format "set xtics (%s)"
(mapconcat (lambda (pair)
(format "\"%s\" %d" (cdr pair) (car pair)))
x-labels ", "))))
(when y-labels ; y labels (ytics)
(funcall ats
(format "set ytics (%s)"
(mapconcat (lambda (pair)
(format "\"%s\" %d" (cdr pair) (car pair)))
y-labels ", "))))
(when time-ind ; timestamp index
(funcall ats "set xdata time")
(funcall ats (concat "set timefmt \""
(or timefmt ; timefmt passed to gnuplot
"%Y-%m-%d-%H:%M:%S") "\"")))
(unless preface
(let ((type-func (plist-get type :plot-func)))
(when type-func
(setq plot-lines
(funcall type-func table data-file num-cols params plot-str))))
(funcall ats
(concat plot-cmd
(when plot-cmd " ")
(mapconcat #'identity
(reverse plot-lines)
",\\\n "))))
script)))
(defun org-plot/redisplay-img-in-buffer (img-file)
"Find any overlays for IMG-FILE in the current Org buffer, and refresh them."
(dolist (img-overlay org-inline-image-overlays)
(when (string= img-file (plist-get (cdr (overlay-get img-overlay 'display)) :file))
(when (and (file-exists-p img-file)
(fboundp 'image-flush))
(image-flush (overlay-get img-overlay 'display))))))
;;-----------------------------------------------------------------------------
;; facade functions
;;;###autoload
(defun org-plot/gnuplot (&optional params)
"Plot table using gnuplot. Gnuplot options can be specified with PARAMS.
If not given options will be taken from the +PLOT
line directly before or after the table."
(interactive)
(org-require-package 'gnuplot)
(save-window-excursion
;; `gnuplot-send-buffer-to-gnuplot' will display *gnuplot* buffer
;; if `gnuplot-display-process' is non-nil. Make it visible while
;; gnuplot is processing the data, preferably as a split, and
;; restore old window configuration after gnuplot finishes.
(ignore-errors (delete-other-windows))
(when (get-buffer "*gnuplot*") ; reset *gnuplot* if it already running
(with-current-buffer "*gnuplot*"
(goto-char (point-max))))
(save-excursion
(org-plot/goto-nearest-table)
;; Set default options.
(dolist (pair org-plot/gnuplot-default-options)
(unless (plist-member params (car pair))
(setf params (plist-put params (car pair) (cdr pair)))))
;; Collect options.
(while (and (equal 0 (forward-line -1))
(looking-at "[[:space:]]*#\\+"))
(setf params (org-plot/collect-options params))))
;; collect table and table information
(let* ((data-file (make-temp-file "org-plot"))
(table (let ((tbl (save-excursion
(org-plot/goto-nearest-table)
(org-table-to-lisp))))
(when (pcase (plist-get params :transpose)
(`y t)
(`yes t)
(`t t))
(if (not (memq 'hline tbl))
(setq tbl (apply #'cl-mapcar #'list tbl))
;; When present, remove hlines as they can't (currentily) be easily transposed.
(setq tbl (apply #'cl-mapcar #'list
(remove 'hline tbl)))
(push 'hline (cdr tbl))))
tbl))
(num-cols (length (if (eq (nth 0 table) 'hline) (nth 1 table)
(nth 0 table))))
(type (assoc (plist-get params :plot-type)
org-plot/preset-plot-types))
gnuplot-script)
(unless type
(user-error "Org-plot type `%s' is undefined" (plist-get params :plot-type)))
(run-with-idle-timer 0.1 nil #'delete-file data-file)
(when (eq (cadr table) 'hline)
(setf params
(plist-put params :labels (car table))) ; headers to labels
(setf table (delq 'hline (cdr table)))) ; clean non-data from table
;; Collect options.
(save-excursion (while (and (equal 0 (forward-line -1))
(looking-at "[[:space:]]*#\\+"))
(setf params (org-plot/collect-options params))))
;; Dump table to datafile
(let ((dump-func (plist-get type :data-dump)))
(if dump-func
(funcall dump-func table data-file num-cols params)
(org-plot/gnuplot-to-data table data-file params)))
;; Check type of ind column (timestamp? text?)
(when (plist-get params :check-ind-type)
(let* ((ind (1- (plist-get params :ind)))
(ind-column (mapcar (lambda (row) (nth ind row)) table)))
(cond ((< ind 0) nil) ; ind is implicit
((cl-every (lambda (el)
(string-match org-ts-regexp3 el))
ind-column)
(plist-put params :timeind t)) ; ind holds timestamps
((or (string= (plist-get params :with) "hist")
(cl-notevery (lambda (el)
(string-match org-table-number-regexp el))
ind-column))
(plist-put params :textind t))))) ; ind holds text
;; Write script.
(setq gnuplot-script
(org-plot/gnuplot-script
table data-file num-cols params (plist-get params :script)))
(with-temp-buffer
(if (plist-get params :script) ; user script
(progn (insert gnuplot-script "\n")
(insert-file-contents (plist-get params :script))
(goto-char (point-min))
(while (re-search-forward "\\$datafile" nil t)
(replace-match data-file nil nil)))
(insert gnuplot-script))
;; Graph table.
(gnuplot-mode)
(condition-case nil
(gnuplot-send-buffer-to-gnuplot)
(buffer-read-only nil)))
;; Cleanup.
(bury-buffer (get-buffer "*gnuplot*"))
;; Refresh any displayed images
(when (plist-get params :file)
(org-plot/redisplay-img-in-buffer (expand-file-name (plist-get params :file)))))))
(provide 'org-plot)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; org-plot.el ends here
org-mode-9.7.29+dfsg/lisp/org-protocol.el 0000664 0000000 0000000 00000074774 15004304337 0020213 0 ustar 00root root 0000000 0000000 ;;; org-protocol.el --- Intercept Calls from Emacsclient to Trigger Custom Actions -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2008-2025 Free Software Foundation, Inc.
;;
;; Authors: Bastien Guerry <bzg@gnu.org>
;; Daniel M German <dmg AT uvic DOT org>
;; Sebastian Rose <sebastian_rose AT gmx DOT de>
;; Ross Patterson <me AT rpatterson DOT net>
;; Maintainer: Sebastian Rose <sebastian_rose AT gmx DOT de>
;; Keywords: org, emacsclient, text
;; 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 <https://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Commentary:
;;
;; Intercept calls from emacsclient to trigger custom actions.
;;
;; This is done by advising `server-visit-files' to scan the list of filenames
;; for `org-protocol-the-protocol' and sub-protocols defined in
;; `org-protocol-protocol-alist' and `org-protocol-protocol-alist-default'.
;;
;; Any application that supports calling external programs with an URL
;; as argument could use this functionality. For example, you can
;; configure bookmarks in your web browser to send a link to the
;; current page to Org and create a note from it using `org-capture'.
;; See Info node `(org) Protocols' for more information.
;;
;;
;; Usage:
;; ------
;;
;; 1.) Add this to your init file (.emacs probably):
;;
;; (require 'org-protocol)
;;
;; 2.) Ensure emacs-server is up and running.
;; 3.) Try this from the command line (adjust the URL as needed):
;;
;; $ emacsclient \
;; "org-protocol://store-link?url=http:%2F%2Flocalhost%2Findex.html&title=The%20title"
;;
;; 4.) Optionally, add custom sub-protocols and handlers:
;;
;; (setq org-protocol-protocol-alist
;; '(("my-protocol"
;; :protocol "my-protocol"
;; :function my-protocol-handler-function)))
;;
;; A "sub-protocol" will be found in URLs like this:
;;
;; org-protocol://sub-protocol?key=val&key2=val2
;;
;; If it works, you can now setup other applications for using this feature.
;;
;;
;; Firefox users follow the steps documented on
;; https://kb.mozillazine.org/Register_protocol, Opera setup is
;; described here: http://www.opera.com/support/kb/view/535/
;;
;; See also: https://orgmode.org/worg/org-contrib/org-protocol.html
;;
;; Documentation
;; -------------
;;
;; org-protocol.el comes with and installs handlers to open sources of published
;; online content, store and insert the browser's URLs and cite online content
;; by clicking on a bookmark in Firefox, Opera and probably other browsers and
;; applications:
;;
;; * `org-protocol-open-source' uses the sub-protocol \"open-source\" and maps
;; URLs to local filenames defined in `org-protocol-project-alist'.
;;
;; * `org-protocol-store-link' stores an Org link (if Org is present) and
;; pushes the browsers URL to the `kill-ring' for yanking. This handler is
;; triggered through the sub-protocol \"store-link\".
;;
;; * Call `org-protocol-capture' by using the sub-protocol \"capture\". If
;; Org is loaded, Emacs will pop-up a capture buffer and fill the
;; template with the data provided. I.e. the browser's URL is inserted as an
;; Org-link of which the page title will be the description part. If text
;; was select in the browser, that text will be the body of the entry.
;;
;; You may use the same bookmark URL for all those standard handlers and just
;; adjust the sub-protocol used:
;;
;; javascript:location.href='org-protocol://sub-protocol?'+
;; new URLSearchParams({
;; url: location.href,
;; title: document.title,
;; body: window.getSelection()});void(0)
;;
;; Alternatively use the following expression that encodes space as \"%20\"
;; instead of \"+\", so it is compatible with Org versions from 9.0 to 9.4:
;;
;; javascript:location.href='org-protocol://sub-protocol?url='+
;; encodeURIComponent(location.href)+'&title='+
;; encodeURIComponent(document.title)+'&body='+
;; encodeURIComponent(window.getSelection());void(0)
;;
;; The handler for the sub-protocol \"capture\" detects an optional template
;; char that, if present, triggers the use of a special template.
;; Example:
;;
;; location.href='org-protocol://capture?'+
;; new URLSearchParams({template:'x', /* ... */})
;;
;; or
;;
;; location.href='org-protocol://capture?template=x'+ ...
;;
;; uses template ?x.
;;
;; Note that using double slashes is optional from org-protocol.el's point of
;; view because emacsclient squashes the slashes to one.
;;
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'org)
(require 'ol)
(declare-function org-publish-get-project-from-filename "ox-publish"
(filename &optional up))
(defvar org-capture-link-is-already-stored)
(defvar org-capture-templates)
(defgroup org-protocol nil
"Intercept calls from emacsclient to trigger custom actions.
This is done by advising `server-visit-files' to scan the list of filenames
for `org-protocol-the-protocol' and sub-protocols defined in
`org-protocol-protocol-alist' and `org-protocol-protocol-alist-default'."
:version "22.1"
:group 'convenience
:group 'org)
;;; Variables:
(defconst org-protocol-protocol-alist-default
'(("org-capture" :protocol "capture" :function org-protocol-capture :kill-client t)
("org-store-link" :protocol "store-link" :function org-protocol-store-link)
("org-open-source" :protocol "open-source" :function org-protocol-open-source))
"Default protocols to use.
See `org-protocol-protocol-alist' for a description of this variable.")
(defconst org-protocol-the-protocol "org-protocol"
"This is the protocol to detect if org-protocol.el is loaded.
`org-protocol-protocol-alist-default' and `org-protocol-protocol-alist' hold
the sub-protocols that trigger the required action. You will have to define
just one protocol handler OS-wide (MS-Windows) or per application (Linux).
That protocol handler should call emacsclient.")
;;; User variables:
(defcustom org-protocol-reverse-list-of-files t
"Non-nil means re-reverse the list of filenames passed on the command line.
The filenames passed on the command line are passed to the emacs-server in
reverse order. Set to t (default) to re-reverse the list, i.e. use the
sequence on the command line. If nil, the sequence of the filenames is
unchanged."
:type 'boolean)
(defcustom org-protocol-project-alist nil
"Map URLs to local filenames for `org-protocol-open-source' (open-source).
Each element of this list must be of the form:
(module-name :property value property: value ...)
where module-name is an arbitrary name. All the values are strings.
Possible properties are:
:online-suffix - the suffix to strip from the published URLs
:working-suffix - the replacement for online-suffix
:base-url - the base URL, e.g. https://www.example.com/project/
Last slash required.
:working-directory - the local working directory. This is what
base-url will be replaced with.
:redirects - A list of cons cells, each of which maps a
regular expression to match to a path relative
to `:working-directory'.
Example:
(setq org-protocol-project-alist
\\='((\"https://orgmode.org/worg/\"
:online-suffix \".php\"
:working-suffix \".org\"
:base-url \"https://orgmode.org/worg/\"
:working-directory \"/home/user/org/Worg/\")
(\"localhost org-notes/\"
:online-suffix \".html\"
:working-suffix \".org\"
:base-url \"http://localhost/org/\"
:working-directory \"/home/user/org/\"
:rewrites ((\"org/?$\" . \"index.php\")))
(\"Hugo based blog\"
:base-url \"https://www.site.com/\"
:working-directory \"~/site/content/post/\"
:online-suffix \".html\"
:working-suffix \".md\"
:rewrites ((\"\\(https://site.com/[0-9]+/[0-9]+/[0-9]+/\\)\"
. \".md\")))
(\"GNU emacs OpenGrok\"
:base-url \"https://opengrok.housegordon.com/source/xref/emacs/\"
:working-directory \"~/dev/gnu-emacs/\")))
The :rewrites line of \"localhost org-notes\" entry tells
`org-protocol-open-source' to open /home/user/org/index.php,
if the URL cannot be mapped to an existing file, and ends with
either \"org\" or \"org/\". The \"GNU emacs OpenGrok\" entry
does not include any suffix properties, allowing local source
file to be opened as found by OpenGrok.
Consider using the interactive functions `org-protocol-create'
and `org-protocol-create-for-org' to help you filling this
variable with valid contents."
:type 'alist)
(defcustom org-protocol-protocol-alist nil
"Register custom handlers for org-protocol.
Each element of this list must be of the form:
(module-name :protocol protocol :function func :kill-client nil)
protocol - protocol to detect in a filename without trailing
colon and slashes. See rfc1738 section 2.1 for more
on this. If you define a protocol \"my-protocol\",
`org-protocol-check-filename-for-protocol' will search
filenames for \"org-protocol:/my-protocol\" and
trigger your action for every match. `org-protocol'
is defined in `org-protocol-the-protocol'. Double and
triple slashes are compressed to one by emacsclient.
function - function that handles requests with protocol and takes
one argument. If a new-style link (key=val&key2=val2)
is given, the argument will be a property list with
the values from the link. If an old-style link is
given (val1/val2), the argument will be the filename
with all protocols stripped.
If the function returns nil, emacsclient and -server
do nothing. Any non-nil return value is considered a
valid filename and thus passed to the server.
`org-protocol.el' provides some support for handling
old-style filenames, if you follow the conventions
used for the standard handlers in
`org-protocol-protocol-alist-default'. See
`org-protocol-parse-parameters'.
kill-client - If t, kill the client immediately, once the sub-protocol is
detected. This is necessary for actions that can be interrupted by
`C-g' to avoid dangling emacsclients. Note that all other command
line arguments but the this one will be discarded. Greedy handlers
still receive the whole list of arguments though.
Here is an example:
(setq org-protocol-protocol-alist
\\='((\"my-protocol\"
:protocol \"my-protocol\"
:function my-protocol-handler-function)
(\"your-protocol\"
:protocol \"your-protocol\"
:function your-protocol-handler-function)))"
:type '(alist))
(defcustom org-protocol-default-template-key nil
"The default template key to use.
This is usually a single character string but can also be a
string with two characters."
:type '(choice (const nil) (string)))
(defcustom org-protocol-data-separator "/+\\|\\?"
"The default data separator to use.
This should be a single regexp string."
:version "24.4"
:package-version '(Org . "8.0")
:type 'regexp)
;;; Helper functions:
(defun org-protocol-sanitize-uri (uri)
"Sanitize slashes to double-slashes in URI.
Emacsclient compresses double and triple slashes."
(when (string-match "^\\([a-z]+\\):/" uri)
(let* ((splitparts (split-string uri "/+")))
(setq uri (concat (car splitparts) "//"
(mapconcat #'identity (cdr splitparts) "/")))))
uri)
(defun org-protocol-split-data (data &optional unhexify separator)
"Split the DATA argument for an org-protocol handler function.
If UNHEXIFY is non-nil, hex-decode each split part. If UNHEXIFY
is a function, use that function to decode each split part. The
string is split at each occurrence of SEPARATOR (regexp). If no
SEPARATOR is specified or SEPARATOR is nil, assume \"/+\". The
results of that splitting are returned as a list."
(let* ((sep (or separator "/+\\|\\?"))
(split-parts (split-string data sep)))
(cond ((not unhexify) split-parts)
((fboundp unhexify) (mapcar unhexify split-parts))
(t (mapcar #'org-link-decode split-parts)))))
(defun org-protocol-flatten-greedy (param-list &optional strip-path replacement)
"Transform PARAM-LIST into a flat list for greedy handlers.
Greedy handlers might receive a list like this from emacsclient:
\((\"/dir/org-protocol:/greedy:/~/path1\" (23 . 12)) (\"/dir/param\"))
where \"/dir/\" is the absolute path to emacsclient's working directory. This
function transforms it into a flat list using `flatten-tree' and
transforms the elements of that list as follows:
If STRIP-PATH is non-nil, remove the \"/dir/\" prefix from all members of
param-list.
If REPLACEMENT is string, replace the \"/dir/\" prefix with it.
The first parameter, the one that contains the protocols, is always changed.
Everything up to the end of the protocols is stripped.
Note, that this function will always behave as if
`org-protocol-reverse-list-of-files' was set to t and the returned list will
reflect that. emacsclient's first parameter will be the first one in the
returned list."
(let* ((l (org--flatten-tree (if org-protocol-reverse-list-of-files
param-list
(reverse param-list))))
(trigger (car l))
(len 0)
dir
ret)
(when (string-match "^\\(.*\\)\\(org-protocol:/+[a-zA-Z0-9][-_a-zA-Z0-9]*:/+\\)\\(.*\\)" trigger)
(setq dir (match-string 1 trigger))
(setq len (length dir))
(setcar l (concat dir (match-string 3 trigger))))
(if strip-path
(progn
(dolist (e l ret)
(setq ret
(append ret
(list
(if (stringp e)
(if (stringp replacement)
(setq e (concat replacement (substring e len)))
(setq e (substring e len)))
e)))))
ret)
l)))
(define-obsolete-function-alias 'org-protocol-flatten
(if (fboundp 'flatten-tree) 'flatten-tree 'org--flatten-tree)
"9.7"
"Transform LIST into a flat list.
Greedy handlers might receive a list like this from emacsclient:
\((\"/dir/org-protocol:/greedy:/~/path1\" (23 . 12)) (\"/dir/param\"))
where \"/dir/\" is the absolute path to emacsclients working directory.
This function transforms it into a flat list.")
(defun org-protocol-parse-parameters (info &optional new-style default-order)
"Return a property list of parameters from INFO.
If NEW-STYLE is non-nil, treat INFO as a query string (ex:
url=URL&title=TITLE). If old-style links are used (ex:
org-protocol://store-link/url/title), assign them to attributes
following DEFAULT-ORDER.
If no DEFAULT-ORDER is specified, return the list of values.
If INFO is already a property list, return it unchanged."
(if (listp info)
info
(if new-style
(let ((data (org-protocol-convert-query-to-plist info))
result)
(while data
(setq result
(append result
(list (pop data) (org-link-decode (pop data))))))
result)
(let ((data (org-protocol-split-data info t org-protocol-data-separator)))
(if default-order
(org-protocol-assign-parameters data default-order)
data)))))
(defun org-protocol-assign-parameters (data default-order)
"Return a property list of parameters from DATA.
Key names are taken from DEFAULT-ORDER, which should be a list of
symbols. If DEFAULT-ORDER is shorter than the number of values
specified, the rest of the values are treated as :key value pairs."
(let (result)
(while default-order
(setq result
(append result
(list (pop default-order)
(pop data)))))
(while data
(setq result
(append result
(list (intern (concat ":" (pop data)))
(pop data)))))
result))
;;; Standard protocol handlers:
(defun org-protocol-store-link (fname)
"Process an org-protocol://store-link style url.
Additionally store a browser URL as an org link. Also pushes the
link's URL to the `kill-ring'.
Parameters: url, title (optional), body (optional)
Old-style links such as org-protocol://store-link://URL/TITLE are
also recognized.
The location for a browser's bookmark may look like this:
javascript:location.href = \\='org-protocol://store-link?\\=' +
new URLSearchParams({url:location.href, title:document.title});void(0);
or to keep compatibility with Org versions from 9.0 to 9.4 it may be:
javascript:location.href = \\
\\='org-protocol://store-link?url=\\=' + \\
encodeURIComponent(location.href) + \\='&title=\\=' + \\
encodeURIComponent(document.title);void(0);
Don't use `escape()'! Use `encodeURIComponent()' instead. The
title of the page could contain slashes and the location
definitely will. Org 9.4 and earlier could not decode \"+\"
to space, that is why less readable latter expression may be necessary
for backward compatibility.
The sub-protocol used to reach this function is set in
`org-protocol-protocol-alist'.
FNAME should be a property list. If not, an old-style link of the
form URL/TITLE can also be used."
(let* ((splitparts (org-protocol-parse-parameters fname nil '(:url :title)))
(uri (org-protocol-sanitize-uri (plist-get splitparts :url)))
(title (plist-get splitparts :title)))
(when (boundp 'org-stored-links)
(push (list uri title) org-stored-links))
(kill-new uri)
(message "`%s' to insert new Org link, `%s' to insert %S"
(substitute-command-keys "\\[org-insert-link]")
(substitute-command-keys "\\[yank]")
uri))
nil)
(defun org-protocol-capture (info)
"Process an org-protocol://capture style url with INFO.
The sub-protocol used to reach this function is set in
`org-protocol-protocol-alist'.
This function detects an URL, title and optional text, separated
by `/'. The location for a browser's bookmark looks like this:
javascript:location.href = \\='org-protocol://capture?\\=' +
new URLSearchParams({
url: location.href,
title: document.title,
body: window.getSelection()});void(0)
or to keep compatibility with Org versions from 9.0 to 9.4:
javascript:location.href = \\='org-protocol://capture?url=\\='+ \\
encodeURIComponent(location.href) + \\='&title=\\=' + \\
encodeURIComponent(document.title) + \\='&body=\\=' + \\
encodeURIComponent(window.getSelection());void(0)
By default, it uses the character `org-protocol-default-template-key',
which should be associated with a template in `org-capture-templates'.
You may specify the template with a template= query parameter, like this:
javascript:location.href
= \\='org-protocol://capture?template=b\\='+ ...;void(0)
Now template ?b will be used."
(let* ((parts
(pcase (org-protocol-parse-parameters info)
;; New style links are parsed as a plist.
((let `(,(pred keywordp) . ,_) info) info)
;; Old style links, with or without template key, are
;; parsed as a list of strings.
(p
(let ((k (if (= 1 (length (car p)))
'(:template :url :title :body)
'(:url :title :body))))
(org-protocol-assign-parameters p k)))))
(template (or (plist-get parts :template)
org-protocol-default-template-key))
(url (and (plist-get parts :url)
(org-protocol-sanitize-uri (plist-get parts :url))))
(type (and url
(string-match "^\\([a-z]+\\):" url)
(match-string 1 url)))
(title (or (plist-get parts :title) ""))
(region (or (plist-get parts :body) ""))
(orglink
(if (null url) title
(org-link-make-string url (or (org-string-nw-p title) url))))
;; Avoid call to `org-store-link'.
(org-capture-link-is-already-stored t))
;; Only store link if there's a URL to insert later on.
(when url (push (list url title) org-stored-links))
(org-link-store-props :type type
:link url
:description title
:annotation orglink
:initial region
:query parts)
(raise-frame)
(org-capture nil template)
(message "Item captured.")
;; Make sure we do not return a string, as `server-visit-files',
;; through `server-edit', would interpret it as a file name.
nil))
(defun org-protocol-convert-query-to-plist (query)
"Convert QUERY key=value pairs in the URL to a property list."
(when query
(let ((plus-decoded (replace-regexp-in-string "\\+" " " query t t)))
(cl-mapcan (lambda (x)
(let ((c (split-string x "=")))
(list (intern (concat ":" (car c))) (cadr c))))
(split-string plus-decoded "&")))))
(defun org-protocol-open-source (fname)
"Process an org-protocol://open-source?url= style URL with FNAME.
Change a filename by mapping URLs to local filenames as set
in `org-protocol-project-alist'.
The location for a browser's bookmark should look like this:
javascript:location.href = \\='org-protocol://open-source?\\=' +
new URLSearchParams({url: location.href});void(0)
or if you prefer to keep compatibility with older Org versions (9.0 to 9.4),
consider the following expression:
javascript:location.href = \\='org-protocol://open-source?url=\\=' + \\
encodeURIComponent(location.href);void(0)"
;; As we enter this function for a match on our protocol, the return value
;; defaults to nil.
(let (;; (result nil)
(f (org-protocol-sanitize-uri
(plist-get (org-protocol-parse-parameters fname nil '(:url))
:url))))
(catch 'result
(dolist (prolist org-protocol-project-alist)
(let* ((base-url (plist-get (cdr prolist) :base-url))
(wsearch (regexp-quote base-url)))
(when (string-match wsearch f)
(let* ((wdir (plist-get (cdr prolist) :working-directory))
(strip-suffix (plist-get (cdr prolist) :online-suffix))
(add-suffix (plist-get (cdr prolist) :working-suffix))
;; Strip "[?#].*$" if `f' is a redirect with another
;; ending than strip-suffix here:
(f1 (substring f 0 (string-match "\\([\\?#].*\\)?$" f)))
(start-pos (+ (string-match wsearch f1) (length base-url)))
(end-pos (if strip-suffix
(string-match (regexp-quote strip-suffix) f1)
(length f1)))
;; We have to compare redirects without suffix below:
(f2 (concat wdir (substring f1 start-pos end-pos)))
(the-file (if add-suffix (concat f2 add-suffix) f2)))
;; Note: the-file may still contain `%C3' et al here because browsers
;; tend to encode `ä' in URLs to `%25C3' - `%25' being `%'.
;; So the results may vary.
;; -- start redirects --
(unless (file-exists-p the-file)
(message "File %s does not exist.\nTesting for rewritten URLs." the-file)
(let ((rewrites (plist-get (cdr prolist) :rewrites)))
(when rewrites
(message "Rewrites found: %S" rewrites)
(dolist (rewrite rewrites)
;; Try to match a rewritten URL and map it to
;; a real file. Compare redirects without
;; suffix.
(when (string-match (car rewrite) f1)
(let ((replacement
(concat (directory-file-name
(replace-match "" nil nil f1 1))
(cdr rewrite))))
(throw 'result (concat wdir replacement))))))))
;; -- end of redirects --
(if (file-readable-p the-file)
(throw 'result the-file))
(if (file-exists-p the-file)
(message "%s: permission denied!" the-file)
(message "%s: no such file or directory." the-file))))))
nil))) ;; FIXME: Really?
;;; Core functions:
(defun org-protocol-check-filename-for-protocol (fname restoffiles _client)
"Check if `org-protocol-the-protocol' and a valid protocol are used in FNAME.
Sub-protocols are registered in `org-protocol-protocol-alist' and
`org-protocol-protocol-alist-default'. This is how the matching is done:
(string-match \"protocol:/+sub-protocol\\\\(://\\\\|\\\\?\\\\)\" ...)
protocol and sub-protocol are regexp-quoted.
Old-style links such as \"protocol://sub-protocol://param1/param2\" are
also recognized.
If a matching protocol is found, the protocol is stripped from
FNAME and the result is passed to the protocol function as the
first parameter. The second parameter will be non-nil if FNAME
uses key=val&key2=val2-type arguments, or nil if FNAME uses
val/val2-type arguments. If the function returns nil, the
filename is removed from the list of filenames passed from
emacsclient to the server. If the function returns a non-nil
value, that value is passed to the server as filename.
If the handler function is greedy, RESTOFFILES will also be passed to it.
CLIENT is ignored."
(let ((sub-protocols (append org-protocol-protocol-alist
org-protocol-protocol-alist-default)))
(catch 'fname
(let ((the-protocol (concat (regexp-quote org-protocol-the-protocol)
":/+")))
(when (string-match the-protocol fname)
(dolist (prolist sub-protocols)
(let ((proto
(concat the-protocol
(regexp-quote (plist-get (cdr prolist) :protocol))
"\\(:/+\\|/*\\?\\)")))
(when (string-match proto fname)
(let* ((func (plist-get (cdr prolist) :function))
(greedy (plist-get (cdr prolist) :greedy))
(split (split-string fname proto))
(result (if greedy restoffiles (cadr split)))
(new-style (not (= ?: (aref (match-string 1 fname) 0)))))
(when (plist-get (cdr prolist) :kill-client)
(message "Greedy org-protocol handler. Killing client.")
;; If not fboundp, there's no client to kill.
(if (fboundp 'server-edit) (server-edit)))
(when (fboundp func)
(unless greedy
(throw 'fname
(if new-style
(funcall func (org-protocol-parse-parameters
result new-style))
(warn "Please update your Org Protocol handler \
to deal with new-style links.")
(funcall func result))))
;; Greedy protocol handlers are responsible for
;; parsing their own filenames.
(funcall func result)
(throw 'fname t))))))))
fname)))
(advice-add 'server-visit-files :around #'org--protocol-detect-protocol-server)
(defun org--protocol-detect-protocol-server (orig-fun files client &rest args)
"Advice `server-visit-files' to call `org-protocol-check-filename-for-protocol'.
This function is indented to be used as :around advice for `server-visit-files'."
(let ((flist (if org-protocol-reverse-list-of-files
(reverse files)
files)))
(catch 'greedy
(dolist (var flist)
;; `\' to `/' on windows. FIXME: could this be done any better?
(let ((fname (expand-file-name (car var))))
(setq fname (org-protocol-check-filename-for-protocol
fname (member var flist) client))
(if (eq fname t) ;; greedy? We need the t return value.
(progn
;; FIXME: Doesn't this just ignore all the files before
;; this one (the remaining ones have been passed to
;; `org-protocol-check-filename-for-protocol' but not
;; the ones before).
(setq files nil)
(throw 'greedy t))
(if (stringp fname) ;; probably filename
(setcar var fname)
(setq files (delq var files)))))))
(apply orig-fun files client args)))
;;; Org specific functions:
(defun org-protocol-create-for-org ()
"Create an Org protocol project for the current file's project.
The visited file needs to be part of a publishing project in
`org-publish-project-alist' for this to work. The function
delegates most of the work to `org-protocol-create'."
(interactive)
(require 'ox-publish)
(let ((all (or (org-publish-get-project-from-filename buffer-file-name))))
(if all (org-protocol-create (cdr all))
(message "%s"
(substitute-command-keys
"Not in an Org project. \
Did you mean `\\[org-protocol-create]'?")))))
(defun org-protocol-create (&optional project-plist)
"Create a new org-protocol project interactively.
An org-protocol project is an entry in
`org-protocol-project-alist' which is used by
`org-protocol-open-source'. Optionally use PROJECT-PLIST to
initialize the defaults for this project. If PROJECT-PLIST is
the cdr of an element in `org-publish-project-alist', reuse
:base-directory, :html-extension and :base-extension."
(interactive)
(let ((working-dir (expand-file-name
(or (plist-get project-plist :base-directory)
default-directory)))
(base-url "https://orgmode.org/worg/")
(strip-suffix (or (plist-get project-plist :html-extension) ".html"))
(working-suffix (if (plist-get project-plist :base-extension)
(concat "." (plist-get project-plist :base-extension))
".org"))
(insert-default-directory t)
(minibuffer-allow-text-properties nil))
(setq base-url (read-string "Base URL of published content: " base-url nil base-url t))
(or (string-suffix-p "/" base-url)
(setq base-url (concat base-url "/")))
(setq working-dir
(expand-file-name
(read-directory-name "Local working directory: " working-dir working-dir t)))
(or (string-suffix-p "/" working-dir)
(setq working-dir (concat working-dir "/")))
(setq strip-suffix
(read-string
(concat "Extension to strip from published URLs (" strip-suffix "): ")
strip-suffix nil strip-suffix t))
(setq working-suffix
(read-string
(concat "Extension of editable files (" working-suffix "): ")
working-suffix nil working-suffix t))
(when (yes-or-no-p "Save the new org-protocol-project to your init file? ")
(setq org-protocol-project-alist
(cons `(,base-url . (:base-url ,base-url
:working-directory ,working-dir
:online-suffix ,strip-suffix
:working-suffix ,working-suffix))
org-protocol-project-alist))
(customize-save-variable 'org-protocol-project-alist org-protocol-project-alist))))
(provide 'org-protocol)
;;; org-protocol.el ends here
org-mode-9.7.29+dfsg/lisp/org-refile.el 0000664 0000000 0000000 00000074454 15004304337 0017613 0 ustar 00root root 0000000 0000000 ;;; org-refile.el --- Refile Org Subtrees -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2025 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
;; Keywords: outlines, hypermedia, calendar, text
;;
;; 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Org Refile allows you to refile subtrees to various locations.
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'org)
(declare-function org-inlinetask-remove-END-maybe "org-inlinetask" ())
(defgroup org-refile nil
"Options concerning refiling entries in Org mode."
:tag "Org Refile"
:group 'org)
(defcustom org-log-refile nil
"Information to record when a task is refiled.
Possible values are:
nil Don't add anything
time Add a time stamp to the task
note Prompt for a note and add it with template `org-log-note-headings'
This option can also be set with on a per-file-basis with
#+STARTUP: nologrefile
#+STARTUP: logrefile
#+STARTUP: lognoterefile
You can have local logging settings for a subtree by setting the LOGGING
property to one or more of these keywords.
When bulk-refiling, e.g., from the agenda, the value `note' is
forbidden and will temporarily be changed to `time'."
:group 'org-refile
:group 'org-progress
:version "24.1"
:type '(choice
(const :tag "No logging" nil)
(const :tag "Record timestamp" time)
(const :tag "Record timestamp with note." note)))
(defcustom org-refile-targets nil
"Targets for refiling entries with `\\[org-refile]'.
This is a list of cons cells. Each cell contains:
- a specification of the files to be considered, either a list of files,
or a symbol whose function or variable value will be used to retrieve
a file name or a list of file names. If you use `org-agenda-files' for
that, all agenda files will be scanned for targets. Nil means consider
headings in the current buffer.
- A specification of how to find candidate refile targets. This may be
any of:
- a cons cell (:tag . \"TAG\") to identify refile targets by a tag.
This tag has to be present in all target headlines, inheritance will
not be considered.
- a cons cell (:todo . \"KEYWORD\") to identify refile targets by
todo keyword.
- a cons cell (:regexp . \"REGEXP\") with a regular expression matching
headlines that are refiling targets.
- a cons cell (:level . N). Any headline of level N is considered a target.
Note that, when `org-odd-levels-only' is set, level corresponds to
order in hierarchy, not to the number of stars.
- a cons cell (:maxlevel . N). Any headline with level <= N is a target.
Note that, when `org-odd-levels-only' is set, level corresponds to
order in hierarchy, not to the number of stars.
Each element of this list generates a set of possible targets.
The union of these sets is presented (with completion) to
the user by `org-refile'.
You can set the variable `org-refile-target-verify-function' to a function
to verify each headline found by the simple criteria above.
When this variable is nil, all top-level headlines in the current buffer
are used, equivalent to the value `((nil . (:level . 1)))'."
:group 'org-refile
:type '(repeat
(cons
(choice :value org-agenda-files
(const :tag "All agenda files" org-agenda-files)
(const :tag "Current buffer" nil)
(function) (variable) (file) (repeat (file)))
(choice :tag "Identify target headline by"
(cons :tag "Specific tag" (const :value :tag) (string))
(cons :tag "TODO keyword" (const :value :todo) (string))
(cons :tag "Regular expression" (const :value :regexp) (regexp))
(cons :tag "Level number" (const :value :level) (integer))
(cons :tag "Max Level number" (const :value :maxlevel) (integer))))))
(defcustom org-refile-target-verify-function nil
"Function to verify if the headline at point should be a refile target.
The function will be called without arguments, with point at the
beginning of the headline. It should return t and leave point
where it is if the headline is a valid target for refiling.
If the target should not be selected, the function must return nil.
In addition to this, it may move point to a place from where the search
should be continued. For example, the function may decide that the entire
subtree of the current entry should be excluded and move point to the end
of the subtree."
:group 'org-refile
:type '(choice
(const nil)
(function)))
(defcustom org-refile-use-cache nil
"Non-nil means cache refile targets to speed up the process.
\\<org-mode-map>\
The cache for a particular file will be updated automatically when
the buffer has been killed, or when any of the marker used for flagging
refile targets no longer points at a live buffer.
If you have added new entries to a buffer that might themselves be targets,
you need to clear the cache manually by pressing `C-0 \\[org-refile]' or,
if you find that easier, \
`\\[universal-argument] \\[universal-argument] \\[universal-argument] \
\\[org-refile]'."
:group 'org-refile
:version "24.1"
:type 'boolean)
(defcustom org-refile-use-outline-path nil
"Non-nil means provide refile targets as paths.
So a level 3 headline will be available as level1/level2/level3.
When the value is `file', also include the file name (without directory)
into the path. In this case, you can also stop the completion after
the file name, to get entries inserted as top level in the file.
When `full-file-path', include the full file path.
When `buffer-name', use the buffer name."
:group 'org-refile
:package-version '(Org . "9.6")
:type '(choice
(const :tag "Not" nil)
(const :tag "Yes" t)
(const :tag "Start with file name" file)
(const :tag "Start with full file path" full-file-path)
(const :tag "Start with buffer name" buffer-name)
(const :tag "Start with document title" title)))
(defcustom org-outline-path-complete-in-steps t
"Non-nil means complete the outline path in hierarchical steps.
When Org uses the refile interface to select an outline path (see
`org-refile-use-outline-path'), the completion of the path can be
done in a single go, or it can be done in steps down the headline
hierarchy. Going in steps is probably the best if you do not use
a special completion package like `ido' or `icicles'. However,
when using these packages, going in one step can be very fast,
while still showing the whole path to the entry."
:group 'org-refile
:type 'boolean)
(defcustom org-refile-allow-creating-parent-nodes nil
"Non-nil means allow the creation of new nodes as refile targets.
New nodes are then created by adding \"/new node name\" to the completion
of an existing node. When the value of this variable is `confirm',
new node creation must be confirmed by the user (recommended).
When nil, the completion must match an existing entry.
Note that, if the new heading is not seen by the criteria
listed in `org-refile-targets', multiple instances of the same
heading would be created by trying again to file under the new
heading."
:group 'org-refile
:type '(choice
(const :tag "Never" nil)
(const :tag "Always" t)
(const :tag "Prompt for confirmation" confirm)))
(defcustom org-refile-active-region-within-subtree nil
"Non-nil means also refile active region within a subtree.
By default `org-refile' doesn't allow refiling regions if they
don't contain a set of subtrees, but it might be convenient to
do so sometimes: in that case, the first line of the region is
converted to a headline before refiling."
:group 'org-refile
:version "24.1"
:type 'boolean)
(defvar org-refile-target-table nil
"The list of refile targets, created by `org-refile'.")
(defvar org-refile-cache nil
"Cache for refile targets.")
(defvar org-refile-markers nil
"All the markers used for caching refile locations.")
;; Add org refile commands to the main org menu
(mapc (lambda (i) (easy-menu-add-item
org-org-menu
'("Edit Structure") i))
'(["Refile Subtree" org-refile (org-in-subtree-not-table-p)]
["Refile and copy Subtree" org-refile-copy (org-in-subtree-not-table-p)]))
(defun org-refile-marker (pos)
"Return a new refile marker at POS, but only if caching is in use.
When `org-refile-use-cache' is nil, just return POS."
(if (not org-refile-use-cache)
pos
(let ((m (make-marker)))
(move-marker m pos)
(push m org-refile-markers)
m)))
(defun org-refile-cache-clear ()
"Clear the refile cache and disable all the markers."
(dolist (m org-refile-markers) (move-marker m nil))
(setq org-refile-markers nil)
(setq org-refile-cache nil)
(message "Refile cache has been cleared"))
(defun org-refile-cache-check-set (set)
"Check if all the markers in the cache still have live buffers."
(let (marker)
(catch 'exit
(while (and set (setq marker (nth 3 (pop set))))
;; If `org-refile-use-outline-path' is 'file, marker may be nil
(when (and marker (null (marker-buffer marker)))
(message "Please regenerate the refile cache with `C-0 C-c C-w'")
(sit-for 3)
(throw 'exit nil)))
t)))
(defun org-refile-cache-put (set &rest identifiers)
"Push the refile targets SET into the cache, under IDENTIFIERS."
(let* ((key (sha1 (prin1-to-string identifiers)))
(entry (assoc key org-refile-cache)))
(if entry
(setcdr entry set)
(push (cons key set) org-refile-cache))))
(defun org-refile-cache-get (&rest identifiers)
"Retrieve the cached value for refile targets given by IDENTIFIERS."
(cond
((not org-refile-cache) nil)
((not org-refile-use-cache) (org-refile-cache-clear) nil)
(t
(let ((set (cdr (assoc (sha1 (prin1-to-string identifiers))
org-refile-cache))))
(and set (org-refile-cache-check-set set) set)))))
(defun org-refile-get-targets (&optional default-buffer)
"Produce a table with refile targets."
(let ((case-fold-search nil)
;; otherwise org confuses "TODO" as a kw and "Todo" as a word
(entries (or org-refile-targets '((nil . (:level . 1)))))
targets tgs files desc descre)
(message "Getting targets...")
(cl-assert (listp entries) t "`org-refile-targets' must be a list of targets")
(with-current-buffer (or default-buffer (current-buffer))
(dolist (entry entries)
(cl-assert (consp entry) t "Refile target must be a cons cell (FILES . SPECIFICATION)")
(setq files (car entry) desc (cdr entry))
(cond
((null files) (setq files (list (current-buffer))))
((eq files 'org-agenda-files)
(setq files (org-agenda-files 'unrestricted)))
((and (symbolp files) (fboundp files))
(setq files (funcall files)))
((and (symbolp files) (boundp files))
(setq files (symbol-value files))))
(when (stringp files) (setq files (list files)))
;; Allow commonly used (FILE :maxlevel N) and similar values.
(when (and (listp (cdr desc)) (null (cddr desc)))
(setq desc (cons (car desc) (cadr desc))))
(condition-case err
(cond
((eq (car desc) :tag)
(setq descre (concat "^\\*+[ \t]+.*?:" (regexp-quote (cdr desc)) ":")))
((eq (car desc) :todo)
(setq descre (concat "^\\*+[ \t]+" (regexp-quote (cdr desc)) "[ \t]")))
((eq (car desc) :regexp)
(setq descre (cdr desc)))
((eq (car desc) :level)
(setq descre (concat "^\\*\\{" (number-to-string
(if org-odd-levels-only
(1- (* 2 (cdr desc)))
(cdr desc)))
"\\}[ \t]")))
((eq (car desc) :maxlevel)
(setq descre (concat "^\\*\\{1," (number-to-string
(if org-odd-levels-only
(1- (* 2 (cdr desc)))
(cdr desc)))
"\\}[ \t]")))
(t (error "Bad refiling target description %s" desc)))
(error
(error "Error parsing refiling target description: %s"
(error-message-string err))))
(dolist (f files)
(with-current-buffer (if (bufferp f) f (org-get-agenda-file-buffer f))
(unless (derived-mode-p 'org-mode)
(error "Major mode in refile target buffer \"%s\" must be `org-mode'" f))
(or
(setq tgs (org-refile-cache-get (buffer-file-name) descre))
(progn
(when (bufferp f)
(setq f (buffer-file-name (buffer-base-buffer f))))
(setq f (and f (expand-file-name f)))
(when (eq org-refile-use-outline-path 'file)
(push (list (and f (file-name-nondirectory f)) f nil nil) tgs))
(when (eq org-refile-use-outline-path 'buffer-name)
(push (list (buffer-name (buffer-base-buffer)) f nil nil) tgs))
(when (eq org-refile-use-outline-path 'full-file-path)
(push (list (and (buffer-file-name (buffer-base-buffer))
(file-truename (buffer-file-name (buffer-base-buffer))))
f nil nil) tgs))
(when (eq org-refile-use-outline-path 'title)
(push (list (or (org-get-title)
(and f (file-name-nondirectory f)))
f nil nil)
tgs))
(org-with-wide-buffer
(goto-char (point-min))
(setq org-outline-path-cache nil)
(while (re-search-forward descre nil t)
(forward-line 0)
(let ((case-fold-search nil))
(looking-at org-complex-heading-regexp))
(let ((begin (point))
(heading (match-string-no-properties 4)))
(unless (or (and
org-refile-target-verify-function
(not
(funcall org-refile-target-verify-function)))
(not heading))
(let ((re (format org-complex-heading-regexp-format
(regexp-quote heading)))
(target
(if (not org-refile-use-outline-path) heading
(mapconcat
#'identity
(append
(pcase org-refile-use-outline-path
(`file (list
(and (buffer-file-name (buffer-base-buffer))
(file-name-nondirectory
(buffer-file-name (buffer-base-buffer))))))
(`title (list
(or (org-get-title)
(and (buffer-file-name (buffer-base-buffer))
(file-name-nondirectory
(buffer-file-name (buffer-base-buffer)))))))
(`full-file-path
(list (buffer-file-name
(buffer-base-buffer))))
(`buffer-name
(list (buffer-name
(buffer-base-buffer))))
(_ nil))
(mapcar (lambda (s) (replace-regexp-in-string
"/" "\\/" s nil t))
(org-get-outline-path t t)))
"/"))))
(push (list target f re (org-refile-marker (point)))
tgs)))
(when (= (point) begin)
;; Verification function has not moved point.
(end-of-line)))))))
(when org-refile-use-cache
(org-refile-cache-put tgs (buffer-file-name) descre))
(setq targets (append tgs targets))))))
(message "Getting targets...done")
(delete-dups (nreverse targets))))
(defvar org-refile-history nil
"History for refiling operations.")
(defvar org-after-refile-insert-hook nil
"Hook run after `org-refile' has inserted its stuff at the new location.
Note that this is still *before* the stuff will be removed from
the *old* location.")
(defvar org-refile-keep nil
"Non-nil means `org-refile' will copy instead of refile.")
;;;###autoload
(defun org-refile-copy ()
"Like `org-refile', but preserve the refiled subtree."
(interactive)
(let ((org-refile-keep t))
(org-refile nil nil nil "Copy")))
;;;###autoload
(defun org-refile-reverse (&optional arg default-buffer rfloc msg)
"Refile while temporarily toggling `org-reverse-note-order'.
So if `org-refile' would append the entry as the last entry under
the target heading, `org-refile-reverse' will prepend it as the
first entry, and vice-versa."
(interactive "P")
(let ((org-reverse-note-order (not (org-notes-order-reversed-p))))
(org-refile arg default-buffer rfloc msg)))
(defvar org-capture-last-stored-marker)
;;;###autoload
(defun org-refile (&optional arg default-buffer rfloc msg)
"Move the entry or entries at point to another heading.
The list of target headings is compiled using the information in
`org-refile-targets', which see.
At the target location, the entry is filed as a subitem of the
target heading. Depending on `org-reverse-note-order', the new
subitem will either be the first or the last subitem.
If there is an active region, all entries in that region will be
refiled. However, the region must fulfill the requirement that
the first heading sets the top-level of the moved text.
With a `\\[universal-argument]' ARG, the command will only visit the target \
location
and not actually move anything.
With a prefix `\\[universal-argument] \\[universal-argument]', go to the \
location where the last
refiling operation has put the subtree.
With a numeric prefix argument of `2', refile to the running clock.
With a numeric prefix argument of `3', emulate `org-refile-keep'
being set to t and copy to the target location, don't move it.
Beware that keeping refiled entries may result in duplicated ID
properties.
RFLOC can be a refile location obtained in a different way. It
should be a list with the following 4 elements:
1. Name - an identifier for the refile location, typically the
headline text
2. File - the file the refile location is in
3. nil - used for generating refile location candidates, not
needed when passing RFLOC
4. Position - the position in the specified file of the
headline to refile under
MSG is a string to replace \"Refile\" in the default prompt with
another verb. E.g. `org-refile-copy' sets this parameter to \"Copy\".
See also `org-refile-use-outline-path'.
If you are using target caching (see `org-refile-use-cache'), you
have to clear the target cache in order to find new targets.
This can be done with a `0' prefix (\\`C-0 C-c C-w') or a triple
prefix argument (\\`C-u C-u C-u C-c C-w')."
(interactive "P")
(if (member arg '(0 (64)))
(org-refile-cache-clear)
(let* ((actionmsg (cond (msg msg)
((equal arg 3) "Refile (and keep)")
(t "Refile")))
(regionp (org-region-active-p))
(region-start (and regionp (region-beginning)))
(region-end (and regionp (region-end)))
(org-refile-keep (if (equal arg 3) t org-refile-keep))
pos it nbuf file level reversed)
(setq last-command nil)
(when regionp
(goto-char region-start)
(forward-line 0)
(setq region-start (point))
(unless (or (org-kill-is-subtree-p
(buffer-substring region-start region-end))
(prog1 org-refile-active-region-within-subtree
(let ((s (line-end-position)))
(org-toggle-heading)
(setq region-end (+ (- (line-end-position) s) region-end)))))
(user-error "The region is not a (sequence of) subtree(s)")))
(if (equal arg '(16))
(org-refile-goto-last-stored)
(when (or
(and (equal arg 2)
org-clock-hd-marker (marker-buffer org-clock-hd-marker)
(prog1
(setq it (list (or org-clock-heading "running clock")
(buffer-file-name
(marker-buffer org-clock-hd-marker))
""
(marker-position org-clock-hd-marker)))
(setq arg nil)))
(setq it
(or rfloc
(let (heading-text)
(save-excursion
(unless (and arg (listp arg))
(org-back-to-heading t)
(setq heading-text
(replace-regexp-in-string
org-link-bracket-re
"\\2"
(or (nth 4 (org-heading-components))
""))))
(org-refile-get-location
(cond ((and arg (listp arg)) "Goto")
(regionp (concat actionmsg " region to"))
(t (concat actionmsg " subtree \""
heading-text "\" to")))
default-buffer
(and (not (equal '(4) arg))
org-refile-allow-creating-parent-nodes)))))))
(setq file (nth 1 it)
pos (nth 3 it))
(when (and (not arg)
pos
(equal (buffer-file-name) file)
(if regionp
(and (>= pos region-start)
(<= pos region-end))
(and (>= pos (save-excursion
(org-back-to-heading t)
(point)))
(< pos (save-excursion
(org-end-of-subtree t t))))))
(error "Cannot refile to position inside the tree or region"))
(setq nbuf (find-file-noselect file 'nowarn))
(if (and arg (not (equal arg 3)))
(progn
(pop-to-buffer-same-window nbuf)
(goto-char (cond (pos)
((org-notes-order-reversed-p) (point-min))
(t (point-max))))
(org-fold-show-context 'org-goto))
(if regionp
(progn
(org-kill-new (buffer-substring region-start region-end))
(org-save-markers-in-region region-start region-end))
(org-copy-subtree 1 nil t))
(let ((origin (point-marker)))
;; Handle special case when we refile to exactly same
;; location with tree promotion/demotion. Point marker
;; saved by `org-with-wide-buffer' (`save-excursion')
;; will then remain before the inserted subtree in
;; unexpected location.
(set-marker-insertion-type origin t)
(with-current-buffer (setq nbuf (find-file-noselect file 'nowarn))
(setq reversed (org-notes-order-reversed-p))
(org-with-wide-buffer
(if pos
(progn
(goto-char pos)
(setq level (org-get-valid-level (funcall outline-level) 1))
(goto-char
(if reversed
(or (outline-next-heading) (point-max))
(or (save-excursion (org-get-next-sibling))
(org-end-of-subtree t t)
(point-max)))))
(setq level 1)
(if (not reversed)
(goto-char (point-max))
(goto-char (point-min))
(or (outline-next-heading) (goto-char (point-max)))))
(unless (bolp) (newline))
(org-paste-subtree level nil nil t)
;; Record information, according to `org-log-refile'.
;; Do not prompt for a note when refiling multiple
;; headlines, however. Simply add a time stamp.
(cond
((not org-log-refile))
(regionp
(org-map-region
(lambda () (org-add-log-setup 'refile nil nil 'time))
(point)
(+ (point) (- region-end region-start))))
(t
(org-add-log-setup 'refile nil nil org-log-refile)))
(and org-auto-align-tags
(let ((org-loop-over-headlines-in-active-region nil))
(org-align-tags)))
(let ((bookmark-name (plist-get org-bookmark-names-plist
:last-refile)))
(when bookmark-name
(condition-case err
(bookmark-set bookmark-name)
(error
(message (format "Bookmark set error: %S" err))))))
;; If we are refiling for capture, make sure that the
;; last-capture pointers point here
(when (bound-and-true-p org-capture-is-refiling)
(let ((bookmark-name (plist-get org-bookmark-names-plist
:last-capture-marker)))
(when bookmark-name
(condition-case err
(bookmark-set bookmark-name)
(error
(message (format "Bookmark set error: %S" err))))))
(move-marker org-capture-last-stored-marker (point)))
(deactivate-mark)
(run-hooks 'org-after-refile-insert-hook)))
;; Go back to ORIGIN.
(goto-char origin))
(unless org-refile-keep
(if regionp
(delete-region (point) (+ (point) (- region-end region-start)))
(org-preserve-local-variables
(delete-region
(and (org-back-to-heading t) (point))
(min (1+ (buffer-size)) (org-end-of-subtree t t) (point))))))
(when (featurep 'org-inlinetask)
(org-inlinetask-remove-END-maybe))
(setq org-markers-to-move nil)
(message "%s to \"%s\" in file %s: done" actionmsg
(car it) file)))))))
(defun org-refile-goto-last-stored ()
"Go to the location where the last refile was stored."
(interactive)
(bookmark-jump (plist-get org-bookmark-names-plist :last-refile))
(message "This is the location of the last refile"))
(defun org-refile--get-location (refloc tbl)
"When user refile to REFLOC, find the associated target in TBL.
Also check `org-refile-target-table'."
(car (delq
nil
(mapcar
(lambda (r) (or (assoc r tbl)
(assoc r org-refile-target-table)))
(list (replace-regexp-in-string "/$" "" refloc)
(replace-regexp-in-string "\\([^/]\\)$" "\\1/" refloc))))))
(defun org-refile-get-location (&optional prompt default-buffer new-nodes)
"Prompt the user for a refile location, using PROMPT.
PROMPT should not be suffixed with a colon and a space, because
this function appends the default value from
`org-refile-history' automatically, if that is not empty."
(let ((org-refile-targets org-refile-targets)
(org-refile-use-outline-path org-refile-use-outline-path))
(setq org-refile-target-table (org-refile-get-targets default-buffer)))
(unless org-refile-target-table
(user-error "No refile targets"))
(let* ((cbuf (current-buffer))
(cfn (buffer-file-name (buffer-base-buffer cbuf)))
(cfunc (if (and org-refile-use-outline-path
org-outline-path-complete-in-steps)
#'org-olpath-completing-read
#'completing-read))
(extra (if org-refile-use-outline-path "/" ""))
(cbnex (concat (buffer-name) extra))
(filename (and cfn (file-truename cfn)))
(tbl (mapcar
(lambda (x)
(if (and (not (member org-refile-use-outline-path
'(file full-file-path title)))
(not (equal filename (file-truename (nth 1 x)))))
(cons (concat (car x) extra " ("
(file-name-nondirectory (nth 1 x)) ")")
(cdr x))
(cons (concat (car x) extra) (cdr x))))
org-refile-target-table))
(completion-ignore-case t)
cdef
(prompt (let ((default (or (car org-refile-history)
(and (assoc cbnex tbl) (setq cdef cbnex)
cbnex))))
(org-format-prompt prompt default)))
pa answ parent-target child parent old-hist)
(setq old-hist org-refile-history)
(setq answ (funcall cfunc prompt tbl nil (not new-nodes)
nil 'org-refile-history
(or cdef (car org-refile-history))))
(if (setq pa (org-refile--get-location answ tbl))
(let ((last-refile-loc (car org-refile-history)))
(org-refile-check-position pa)
(when (or (not org-refile-history)
(not (eq old-hist org-refile-history))
(not (equal (car pa) last-refile-loc)))
(setq org-refile-history
(cons (car pa) (if (assoc last-refile-loc tbl)
org-refile-history
(cdr org-refile-history))))
(when (equal last-refile-loc (nth 1 org-refile-history))
(pop org-refile-history)))
pa)
(if (string-match "\\`\\(.*\\)/\\([^/]+\\)\\'" answ)
(progn
(setq parent (match-string 1 answ)
child (match-string 2 answ))
(setq parent-target (org-refile--get-location parent tbl))
(when (and parent-target
(or (eq new-nodes t)
(and (eq new-nodes 'confirm)
(y-or-n-p (format "Create new node \"%s\"? "
child)))))
(org-refile-new-child parent-target child)))
(user-error "Invalid target location")))))
(defun org-refile-check-position (refile-pointer)
"Check if the refile pointer matches the headline to which it points."
(let* ((file (nth 1 refile-pointer))
(re (nth 2 refile-pointer))
(pos (nth 3 refile-pointer))
buffer)
(if (and (not (markerp pos)) (not file))
(user-error "Please indicate a target file in the refile path")
(when (org-string-nw-p re)
(setq buffer (if (markerp pos)
(marker-buffer pos)
(find-file-noselect file 'nowarn)))
(with-current-buffer buffer
(org-with-wide-buffer
(goto-char pos)
(forward-line 0)
(unless (looking-at-p re)
(user-error "Invalid refile position, please clear the cache with `C-0 C-c C-w' before refiling"))))))))
(defun org-refile-new-child (parent-target child)
"Use refile target PARENT-TARGET to add new CHILD below it."
(unless parent-target
(error "Cannot find parent for new node"))
(let ((file (nth 1 parent-target))
(pos (nth 3 parent-target))
level)
(with-current-buffer (find-file-noselect file 'nowarn)
(org-with-wide-buffer
(if pos
(goto-char pos)
(goto-char (point-max))
(unless (bolp) (newline)))
(when (looking-at org-outline-regexp)
(setq level (funcall outline-level))
(org-end-of-subtree t t))
(org-back-over-empty-lines)
(insert "\n" (make-string
(if pos (org-get-valid-level level 1) 1) ?*)
" " child "\n")
(forward-line -1)
(list (concat (car parent-target) "/" child) file "" (point))))))
(defun org-olpath-completing-read (prompt collection &rest args)
"Read an outline path like a file name."
(let ((thetable collection))
(apply #'completing-read
prompt
(lambda (string predicate &optional flag)
(cond
((eq flag nil) (try-completion string thetable))
((eq flag t)
(let ((l (length string)))
(mapcar (lambda (x)
(let ((r (substring x l))
(f (if (string-match " ([^)]*)$" x)
(match-string 0 x)
"")))
(if (string-match "/" r)
(concat string (substring r 0 (match-end 0)) f)
x)))
(all-completions string thetable predicate))))
((eq (car-safe flag) 'boundaries)
;; See `completion-file-name-table'.
(let ((start (or (and (string-match "/" string)
(match-beginning 0))
(length string)))
(end (and (string-match "/" (cdr flag))
(match-beginning 0))))
`(boundaries ,start . ,end)))
;; Exact match?
((eq flag 'lambda) (assoc string thetable))))
args)))
(provide 'org-refile)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; org-refile.el ends here
org-mode-9.7.29+dfsg/lisp/org-src.el 0000664 0000000 0000000 00000163212 15004304337 0017123 0 ustar 00root root 0000000 0000000 ;;; org-src.el --- Source code examples in Org -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2004-2025 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
;; Bastien Guerry <bzg@gnu.org>
;; Dan Davison <davison at stats dot ox dot ac dot uk>
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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 <https://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;; This file contains the code dealing with source code examples in
;; Org mode.
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'cl-lib)
(require 'ob-comint)
(require 'org-macs)
(require 'org-compat)
(require 'org-keys)
(require 'sh-script)
(declare-function org--get-expected-indentation "org" (element contentsp))
(declare-function org-mode "org" ())
(declare-function org--get-expected-indentation "org" (element contentsp))
(declare-function org-fold-region "org-fold" (from to flag &optional spec-or-alias))
(declare-function org-element-at-point "org-element" (&optional pom cached-only))
(declare-function org-element-class "org-element" (datum &optional parent))
(declare-function org-element-context "org-element" (&optional element))
(declare-function org-element-lineage "org-element-ast"
(blob &optional types with-self))
(declare-function org-element--parse-paired-brackets "org-element" (char))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-begin "org-element" (node))
(declare-function org-element-end "org-element" (node))
(declare-function org-element-contents-begin "org-element" (node))
(declare-function org-element-contents-end "org-element" (node))
(declare-function org-element-post-affiliated "org-element" (node))
(declare-function org-element-post-blank "org-element" (node))
(declare-function org-element-parent "org-element-ast" (node))
(declare-function org-element-type "org-element-ast" (node &optional anonymous))
(declare-function org-element-type-p "org-element-ast" (node types))
(declare-function org-footnote-goto-definition "org-footnote"
(label &optional location))
(defvar org-inhibit-startup)
(defcustom org-edit-src-turn-on-auto-save nil
"Non-nil means turn `auto-save-mode' on when editing a source block.
This will save the content of the source code editing buffer into
a newly created file, not the base buffer for this source block.
If you want to regularly save the base buffer instead of the source
code editing buffer, see `org-edit-src-auto-save-idle-delay' instead."
:group 'org-edit-structure
:version "24.4"
:package-version '(Org . "8.0")
:type 'boolean)
(defcustom org-edit-src-auto-save-idle-delay 0
"Delay before saving a source code buffer back into its base buffer.
When a positive integer N, save after N seconds of idle time.
When 0 (the default), don't auto-save.
If you want to save the source code buffer itself, don't use this.
Check `org-edit-src-turn-on-auto-save' instead."
:group 'org-edit-structure
:version "24.4"
:package-version '(Org . "8.0")
:type 'integer)
(defcustom org-coderef-label-format "(ref:%s)"
"The default coderef format.
This format string will be used to search for coderef labels in literal
examples (EXAMPLE and SRC blocks). The format can be overwritten in
an individual literal example with the -l option, like
#+BEGIN_SRC pascal +n -r -l \"((%s))\"
...
#+END_SRC
If you want to use this for HTML export, make sure that the format does
not introduce special font-locking, and avoid the HTML special
characters `<', `>', and `&'. The reason for this restriction is that
the labels are searched for only after htmlize has done its job."
:group 'org-edit-structure ; FIXME this is not in the right group
:type 'string)
(defcustom org-edit-fixed-width-region-mode 'artist-mode
"The mode that should be used to edit fixed-width regions.
These are the regions where each line starts with a colon."
:group 'org-edit-structure
:type '(choice
(const artist-mode)
(const picture-mode)
(const fundamental-mode)
(function :tag "Other (specify)")))
(defcustom org-src-preserve-indentation nil
"If non-nil preserve leading whitespace characters on export.
If non-nil leading whitespace characters in source code blocks are
preserved on export, or adjusted while indenting or when switching
between the org buffer and the language mode edit buffer.
When this variable is nil, while indenting with `\\[org-indent-block]'
or after editing with `\\[org-edit-src-code]', the minimum (across-lines)
number of leading whitespace characters are removed from all lines,
and the code block is uniformly indented according to the value of
`org-edit-src-content-indentation'."
:group 'org-edit-structure
:type 'boolean)
(defcustom org-edit-src-content-indentation 2
"Indentation for the content of a source code block.
This should be the number of spaces added to the indentation of the #+begin
line in order to compute the indentation of the block content after
editing it with `\\[org-edit-src-code]'.
It has no effect if `org-src-preserve-indentation' is non-nil."
:group 'org-edit-structure
:type 'integer
:safe #'wholenump)
(defcustom org-edit-src-persistent-message t
"Non-nil means show persistent exit help message while editing src examples.
The message is shown in the header-line, which will be created in the
first line of the window showing the editing buffer."
:group 'org-edit-structure
:type 'boolean)
(defcustom org-src-ask-before-returning-to-edit-buffer t
"Non-nil means ask before switching to an existing edit buffer.
If nil, when `org-edit-src-code' is used on a block that already
has an active edit buffer, it will switch to that edit buffer
immediately; otherwise it will ask whether you want to return to
the existing edit buffer."
:group 'org-edit-structure
:version "24.4"
:package-version '(Org . "8.0")
:type 'boolean)
(defcustom org-src-window-setup 'reorganize-frame
"How the source code edit buffer should be displayed.
Possible values for this option are:
plain Show edit buffer using `display-buffer'. Users can
further control the display behavior by modifying
`display-buffer-alist' and its relatives.
current-window Show edit buffer in the current window, keeping all other
windows.
split-window-below Show edit buffer below the current window, keeping all
other windows.
split-window-right Show edit buffer to the right of the current window,
keeping all other windows.
other-window Use `switch-to-buffer-other-window' to display edit buffer.
reorganize-frame Show only two windows on the current frame, the current
window and the edit buffer.
other-frame Use `switch-to-buffer-other-frame' to display edit buffer.
Also, when exiting the edit buffer, kill that frame.
Values that modify the window layout (reorganize-frame, split-window-below,
split-window-right) will restore the layout after exiting the edit buffer."
:group 'org-edit-structure
:type '(choice
(const plain)
(const current-window)
(const split-window-below)
(const split-window-right)
(const other-frame)
(const other-window)
(const reorganize-frame)))
(defvar org-src-mode-hook nil
"Hook run after Org switched a source code snippet to its Emacs mode.
\\<org-mode-map>
This hook will run:
- when editing a source code snippet with `\\[org-edit-special]'
- when formatting a source code snippet for export with htmlize.
You may want to use this hook for example to turn off `outline-minor-mode'
or similar things which you want to have when editing a source code file,
but which mess up the display of a snippet in Org exported files.")
(defun org-src--get-known-shells ()
"List all the shells in `sh-ancestor-alist' for `org-src-lang-modes'.
The shells are associated with `sh-mode'."
(mapcar
(lambda (shell) (cons (symbol-name shell) 'sh))
(delete-dups (org--flatten-tree sh-ancestor-alist))))
(defcustom org-src-lang-modes
`(("C" . c)
("C++" . c++)
("asymptote" . asy)
("beamer" . latex)
("calc" . fundamental)
("cpp" . c++)
("ditaa" . artist)
("desktop" . conf-desktop)
("dot" . fundamental)
("elisp" . emacs-lisp)
("ocaml" . tuareg)
("screen" . shell-script)
("sqlite" . sql)
("toml" . conf-toml)
("shell" . sh)
,@(org-src--get-known-shells))
"Alist mapping languages to their major mode.
The key is the language name. The value is the mode name, as
a string or a symbol, without the \"-mode\" suffix.
For many languages this is simple, but for language where this is
not the case, this variable provides a way to simplify things on
the user side. For example, there is no `ocaml-mode' in Emacs,
but the mode to use is `tuareg-mode'."
:group 'org-edit-structure
:package-version '(Org . "9.7")
:type '(repeat
(cons
(string :tag "Language name")
(symbol :tag "Major mode"))))
(defcustom org-src-block-faces nil
"Alist of faces to be used for source-block.
Each element is a cell of the format
(\"language\" FACE)
Where FACE is either a defined face or an anonymous face. Empty
language string refers to source blocks without specified language.
For instance, the following would color the background of
emacs-lisp source blocks and python source blocks in purple and
green, respectability.
(setq org-src-block-faces
\\='((\"emacs-lisp\" (:background \"#EEE2FF\"))
(\"python\" (:background \"#e5ffb8\"))))"
:group 'org-edit-structure
:type '(repeat (list (string :tag "language")
(choice
(face :tag "Face")
(sexp :tag "Anonymous face"))))
:package-version '(Org . "9.0"))
(defcustom org-src-tab-acts-natively t
"If non-nil, TAB uses the language's major-mode binding in code blocks."
:type 'boolean
:package-version '(Org . "9.4")
:group 'org-babel)
;;; Internal functions and variables
(defvar org-src--auto-save-timer nil
"Idle Timer auto-saving remote editing buffers.")
(defvar-local org-src--allow-write-back t)
(put 'org-src--allow-write-back 'permanent-local t)
(defvar-local org-src--babel-info nil)
(put 'org-src--babel-info 'permanent-local t)
(defvar-local org-src--beg-marker nil)
(put 'org-src--beg-marker 'permanent-local t)
(defvar-local org-src--block-indentation nil)
(put 'org-src--block-indentation 'permanent-local t)
(defvar-local org-src--content-indentation nil)
(put 'org-src--content-indentation 'permanent-local t)
(defvar-local org-src--end-marker nil)
(put 'org-src--end-marker 'permanent-local t)
(defvar-local org-src--from-org-mode nil)
(put 'org-src--from-org-mode 'permanent-local t)
(defvar-local org-src--overlay nil)
(put 'org-src--overlay 'permanent-local t)
(defvar-local org-src--preserve-indentation nil)
(put 'org-src--preserve-indentation 'permanent-local t)
(defvar-local org-src--remote nil)
(put 'org-src--remote 'permanent-local t)
(defvar-local org-src--saved-temp-window-config nil)
(put 'org-src--saved-temp-window-config 'permanent-local t)
(defvar-local org-src--source-type nil
"Type of element being edited, as a symbol.")
(put 'org-src--source-type 'permanent-local t)
(defvar-local org-src--tab-width nil
"Contains `tab-width' value from Org source buffer.
However, if `indent-tabs-mode' is nil in that buffer, its value
is 0.")
(put 'org-src--tab-width 'permanent-local t)
(defvar-local org-src-source-file-name nil
"File name associated to Org source buffer, or nil.")
(put 'org-src-source-file-name 'permanent-local t)
(defun org-src--construct-edit-buffer-name (org-buffer-name lang)
"Construct the buffer name for a source editing buffer.
Format is \"*Org Src ORG-BUFFER-NAME[ LANG ]*\"."
(concat "*Org Src " org-buffer-name "[ " lang " ]*"))
(defun org-src--edit-buffer (beg end)
"Return buffer editing area between BEG and END.
Return nil if there is no such buffer."
(catch 'exit
(dolist (b (buffer-list))
(with-current-buffer b
(and (org-src-edit-buffer-p)
(= beg org-src--beg-marker)
(eq (marker-buffer beg) (marker-buffer org-src--beg-marker))
(= end org-src--end-marker)
(eq (marker-buffer end) (marker-buffer org-src--end-marker))
(throw 'exit b))))))
(defun org-src--coordinates (pos beg end)
"Return coordinates of POS relatively to BEG and END.
POS, BEG and END are buffer positions. Return value is either
a cons cell (LINE . COLUMN) or symbol `end'. See also
`org-src--goto-coordinates'."
(if (>= pos end) 'end
(org-with-wide-buffer
(goto-char (max beg pos))
(cons (count-lines (save-excursion (goto-char beg) (line-beginning-position))
(line-beginning-position))
;; Column is relative to the end of line to avoid problems of
;; comma escaping or colons appended in front of the line.
(- (point) (min end (line-end-position)))))))
(defun org-src--goto-coordinates (coord beg end)
"Move to coordinates COORD relatively to BEG and END.
COORD are coordinates, as returned by `org-src--coordinates',
which see. BEG and END are buffer positions."
(goto-char
(if (eq coord 'end) (max (1- end) beg)
;; If BEG happens to be located outside of the narrowed part of
;; the buffer, widen it first.
(org-with-wide-buffer
(goto-char beg)
(forward-line (car coord))
(max (point)
(+ (min end (line-end-position))
(cdr coord)))))))
(defun org-src--contents-area (datum)
"Return contents boundaries of DATUM.
DATUM is an element or object. Return a list (BEG END CONTENTS)
where BEG and END are buffer positions and CONTENTS is a string."
(let ((type (org-element-type datum)))
(org-with-wide-buffer
(cond
((eq type 'footnote-definition)
(let* ((beg (progn
(goto-char (org-element-post-affiliated datum))
(search-forward "]")))
(end (or (org-element-contents-end datum) beg)))
(list beg end (buffer-substring-no-properties beg end))))
((eq type 'inline-src-block)
(let ((beg (progn (goto-char (org-element-begin datum))
(search-forward "{" (line-end-position) t)))
(end (progn (goto-char (org-element-end datum))
(search-backward "}" (line-beginning-position) t))))
(list beg end (buffer-substring-no-properties beg end))))
((eq type 'latex-fragment)
(let ((beg (org-element-begin datum))
(end (org-with-point-at (org-element-end datum)
(skip-chars-backward " \t")
(point))))
(list beg end (buffer-substring-no-properties beg end))))
((org-element-contents-begin datum)
(let ((beg (org-element-contents-begin datum))
(end (org-element-contents-end datum)))
(list beg end (buffer-substring-no-properties beg end))))
((memq type '(example-block export-block src-block comment-block))
(list (progn (goto-char (org-element-post-affiliated datum))
(line-beginning-position 2))
(progn (goto-char (org-element-end datum))
(skip-chars-backward " \r\t\n")
(line-beginning-position 1))
(org-element-property :value datum)))
((memq type '(fixed-width latex-environment table))
(let ((beg (org-element-post-affiliated datum))
(end (progn (goto-char (org-element-end datum))
(skip-chars-backward " \r\t\n")
(line-beginning-position 2))))
(list beg
end
(if (eq type 'fixed-width) (org-element-property :value datum)
(buffer-substring-no-properties beg end)))))
(t (error "Unsupported element or object: %s" type))))))
(defun org-src--make-source-overlay (beg end edit-buffer)
"Create overlay between BEG and END positions and return it.
EDIT-BUFFER is the buffer currently editing area between BEG and
END."
(let ((overlay (make-overlay beg end)))
(overlay-put overlay 'face 'secondary-selection)
(overlay-put overlay 'edit-buffer edit-buffer)
(overlay-put overlay 'help-echo
"Click with mouse-1 to switch to buffer editing this segment")
(overlay-put overlay 'face 'secondary-selection)
(overlay-put overlay 'keymap
(let ((map (make-sparse-keymap)))
(define-key map [mouse-1] 'org-edit-src-continue)
map))
(let ((read-only
(list
(lambda (&rest _)
(user-error
"Cannot modify an area being edited in a dedicated buffer")))))
(overlay-put overlay 'modification-hooks read-only)
(overlay-put overlay 'insert-in-front-hooks read-only)
(overlay-put overlay 'insert-behind-hooks read-only))
overlay))
(defun org-src--remove-overlay ()
"Remove overlay from current source buffer."
(when (overlayp org-src--overlay) (delete-overlay org-src--overlay)))
(defun org-src--on-datum-p (datum)
"Non-nil when point is on DATUM.
DATUM is an element or an object. Consider blank lines or white
spaces after it as being outside."
(and (>= (point) (org-element-begin datum))
(<= (point)
(org-with-wide-buffer
(goto-char (org-element-end datum))
(skip-chars-backward " \r\t\n")
(if (eq (org-element-class datum) 'element)
(line-end-position)
(point))))))
(defun org-src-preserve-indentation-p (&optional node)
"Non-nil when indentation should be preserved within NODE.
When NODE is not passed, assume element at point."
(let ((node (or node (org-element-at-point))))
(and (org-element-type-p node '(example-block src-block))
(or (org-element-property :preserve-indent node)
org-src-preserve-indentation))))
(defun org-src--contents-for-write-back-1
( write-back-buf contents
&optional indentation-offset preserve-fl source-tab-width write-back)
"Populate WRITE-BACK-BUF with CONTENTS in the appropriate format.
INDENTATION-OFFSET, when non-nil is additional indentation to be applied
to all the lines. PRESERVE-FL means that first line should not be
indented (useful for inline blocks contents that belong to paragraph).
The original indentation, if any, is not altered.
TAB-WIDTH is `tab-width' to be used when indenting. The value of 0
means that tabs should not be used.
WRITE-BACK, when non-nil, is a function to be called with point at
WRITE-BACK-BUF after inserting the original contents, but before
applying extra indentation."
(let ((use-tabs? (and (> source-tab-width 0) t))
indent-str)
(with-current-buffer write-back-buf
;; Apply WRITE-BACK function on edit buffer contents.
(insert (org-no-properties contents))
(goto-char (point-min))
(when (functionp write-back) (save-excursion (funcall write-back)))
;; Add INDENTATION-OFFSET to every line in buffer,
;; unless indentation is meant to be preserved.
(when (and indentation-offset (> indentation-offset 0))
;; The exact sequence of tabs and spaces used to indent
;; up to `indentation-offset' in the Org buffer.
(setq indent-str
(with-temp-buffer
;; Reproduce indentation parameters.
(setq indent-tabs-mode use-tabs?)
(when (> source-tab-width 0)
(setq tab-width source-tab-width))
(indent-to indentation-offset)
(buffer-string)))
;; LaTeX-fragments are inline. Do not add indentation to their
;; first line.
(when preserve-fl (forward-line))
(while (not (eobp))
;; Keep empty src lines empty, even when src block is
;; indented on Org side.
;; See https://list.orgmode.org/725763.1632663635@apollo2.minshall.org/T/
(when (not (eolp)) ; not an empty line
(insert indent-str))
(forward-line))))))
(defun org-src--contents-for-write-back (write-back-buf)
"Populate WRITE-BACK-BUF with contents in the appropriate format.
Assume point is in the corresponding edit buffer."
(org-src--contents-for-write-back-1
write-back-buf
;; CONTENTS
(org-with-wide-buffer (buffer-string))
;; INDENTATION
(if org-src--preserve-indentation 0
(+ (or org-src--block-indentation 0)
(if (memq org-src--source-type '(example-block src-block))
org-src--content-indentation
0)))
;; PRESERVE-FL
(eq org-src--source-type 'latex-fragment)
;; TAB-WIDTH
org-src--tab-width
;; WRITE-BACK
org-src--allow-write-back))
(defun org-src--edit-element
(datum name &optional initialize write-back contents remote)
"Edit DATUM contents in a dedicated buffer NAME.
INITIALIZE is a function to call upon creating the buffer.
When WRITE-BACK is non-nil, assume contents will replace original
region. Moreover, if it is a function, apply it in the edit
buffer, from point min, before returning the contents.
When CONTENTS is non-nil, display them in the edit buffer.
Otherwise, show DATUM contents as specified by
`org-src--contents-area'.
When REMOTE is non-nil, do not try to preserve point or mark when
moving from the edit area to the source.
Leave point in edit buffer."
(when (memq org-src-window-setup '(reorganize-frame
split-window-below
split-window-right))
(setq org-src--saved-temp-window-config (current-window-configuration)))
(let* ((area (org-src--contents-area datum))
(beg (copy-marker (nth 0 area)))
(end (copy-marker (nth 1 area) t))
(old-edit-buffer (org-src--edit-buffer beg end))
(contents (or contents (nth 2 area))))
(if (and old-edit-buffer
(or (not org-src-ask-before-returning-to-edit-buffer)
(y-or-n-p "Return to existing edit buffer ([n] will revert changes)? ")))
;; Move to existing buffer.
(org-src-switch-to-buffer old-edit-buffer 'return)
;; Discard old edit buffer.
(when old-edit-buffer
(with-current-buffer old-edit-buffer (org-src--remove-overlay))
(kill-buffer old-edit-buffer))
(let* ((org-mode-p (derived-mode-p 'org-mode))
(source-file-name (buffer-file-name (buffer-base-buffer)))
(source-tab-width (if indent-tabs-mode tab-width 0))
(type (org-element-type datum))
(block-ind (org-with-point-at (org-element-begin datum)
(cond
((save-excursion (skip-chars-backward " \t") (bolp))
(org-current-text-indentation))
((org-element-parent datum)
(org--get-expected-indentation
(org-element-parent datum) nil))
(t (org-current-text-indentation)))))
(content-ind org-edit-src-content-indentation)
(preserve-ind (org-src-preserve-indentation-p datum))
;; Store relative positions of mark (if any) and point
;; within the edited area.
(point-coordinates (and (not remote)
(org-src--coordinates (point) beg end)))
(mark-coordinates (and (not remote)
(org-region-active-p)
(let ((m (mark)))
(and (>= m beg) (>= end m)
(org-src--coordinates m beg end)))))
;; Generate a new edit buffer.
(buffer (generate-new-buffer name))
;; Add an overlay on top of source.
(overlay (org-src--make-source-overlay beg end buffer)))
;; Switch to edit buffer.
(org-src-switch-to-buffer buffer 'edit)
;; Insert contents.
(insert contents)
(remove-text-properties (point-min) (point-max)
'(display nil invisible nil intangible nil))
(let ((lf (eq type 'latex-fragment)))
(unless preserve-ind (org-do-remove-indentation (and lf block-ind) lf)))
(set-buffer-modified-p nil)
(setq buffer-file-name nil)
;; Initialize buffer.
(when (functionp initialize)
(let ((org-inhibit-startup t))
(condition-case-unless-debug e
(funcall initialize)
(error (message "Initialization fails with: %S"
(error-message-string e))))))
;; Transmit buffer-local variables for exit function. It must
;; be done after initializing major mode, as this operation
;; may reset them otherwise.
(setq org-src--tab-width source-tab-width)
(setq org-src--from-org-mode org-mode-p)
(setq org-src--beg-marker beg)
(setq org-src--end-marker end)
(setq org-src--remote remote)
(setq org-src--source-type type)
(setq org-src--block-indentation block-ind)
(setq org-src--content-indentation content-ind)
(setq org-src--preserve-indentation preserve-ind)
(setq org-src--overlay overlay)
(setq org-src--allow-write-back write-back)
(setq org-src-source-file-name source-file-name)
;; Start minor mode.
(org-src-mode)
;; Clear undo information so we cannot undo back to the
;; initial empty buffer.
(buffer-disable-undo (current-buffer))
(buffer-enable-undo)
;; Move mark and point in edit buffer to the corresponding
;; location.
(if remote
(progn
;; Put point at first non read-only character after
;; leading blank.
(goto-char
(or (text-property-any (point-min) (point-max) 'read-only nil)
(point-max)))
(skip-chars-forward " \r\t\n"))
;; Set mark and point.
(when mark-coordinates
(org-src--goto-coordinates mark-coordinates (point-min) (point-max))
(push-mark (point) 'no-message t)
(setq deactivate-mark nil))
(org-src--goto-coordinates
point-coordinates (point-min) (point-max)))))))
;;; Fontification of source blocks
(defvar org-src-fontify-natively) ; Defined in org.el
(defun org-src-font-lock-fontify-block (lang start end)
"Fontify code block between START and END using LANG's syntax.
This function is called by Emacs's automatic fontification, as long
as `org-src-fontify-natively' is non-nil."
(let ((modified (buffer-modified-p)) native-tab-width)
(remove-text-properties start end '(face nil))
(let ((lang-mode (org-src-get-lang-mode lang)))
(when (fboundp lang-mode)
(let ((string (buffer-substring-no-properties start end))
(org-buffer (current-buffer)))
(with-current-buffer
(get-buffer-create
(format " *org-src-fontification:%s*" lang-mode))
(let ((inhibit-modification-hooks nil))
(erase-buffer)
;; Add string and a final space to ensure property change.
(insert string " "))
(unless (eq major-mode lang-mode) (funcall lang-mode))
(setq native-tab-width tab-width)
(font-lock-ensure)
(let ((pos (point-min)) next
;; Difference between positions here and in org-buffer.
(offset (- start (point-min))))
(while (setq next (next-property-change pos))
;; Handle additional properties from font-lock, so as to
;; preserve, e.g., composition.
;; FIXME: We copy 'font-lock-face property explicitly because
;; `font-lock-mode' is not enabled in the buffers starting from
;; space and the remapping between 'font-lock-face and 'face
;; text properties may thus not be set. See commit
;; 453d634bc.
(dolist (prop (append '(font-lock-face face) font-lock-extra-managed-props))
(let ((new-prop (get-text-property pos prop)))
(when new-prop
(if (not (eq prop 'invisible))
(put-text-property
(+ offset pos) (+ offset next) prop new-prop
org-buffer)
;; Special case. `invisible' text property may
;; clash with Org folding. Do not assign
;; `invisible' text property directly. Use
;; property alias instead.
(let ((invisibility-spec
(or
;; ATOM spec.
(and (memq new-prop buffer-invisibility-spec)
new-prop)
;; (ATOM . ELLIPSIS) spec.
(assq new-prop buffer-invisibility-spec))))
(with-current-buffer org-buffer
;; Add new property alias.
(unless (memq 'org-src-invisible
(cdr (assq 'invisible char-property-alias-alist)))
(setq-local
char-property-alias-alist
(cons (cons 'invisible
(nconc (cdr (assq 'invisible char-property-alias-alist))
'(org-src-invisible)))
(remove (assq 'invisible char-property-alias-alist)
char-property-alias-alist))))
;; Carry over the invisibility spec, unless
;; already present. Note that there might
;; be conflicting invisibility specs from
;; different major modes. We cannot do much
;; about this then.
(when invisibility-spec
(add-to-invisibility-spec invisibility-spec))
(put-text-property
(+ offset pos) (+ offset next)
'org-src-invisible new-prop
org-buffer)))))))
(setq pos next)))
(set-buffer-modified-p nil)))))
;; Add Org faces.
(let ((src-face (nth 1 (assoc-string lang org-src-block-faces t))))
(when (or (facep src-face) (listp src-face))
(font-lock-append-text-property start end 'face src-face))
(font-lock-append-text-property start end 'face 'org-block))
;; Display native tab indentation characters as spaces
(when native-tab-width
(save-excursion
(goto-char start)
(let ((indent-offset
(if (org-src-preserve-indentation-p) 0
(+ (progn (backward-char)
(org-current-text-indentation))
org-edit-src-content-indentation))))
(while (re-search-forward "^[ ]*\t" end t)
(let* ((b (and (eq indent-offset (move-to-column indent-offset))
(point)))
(e (progn (skip-chars-forward "\t") (point)))
(s (and b (make-string (* (- e b) native-tab-width) ? ))))
(when (and b (< b e)) (add-text-properties b e `(display ,s)))
(forward-char))))))
(add-text-properties
start end
'(font-lock-fontified t fontified t font-lock-multiline t))
(set-buffer-modified-p modified)))
(defun org-fontify-inline-src-blocks (limit)
"Try to apply `org-fontify-inline-src-blocks-1'."
(condition-case-unless-debug nil
(org-fontify-inline-src-blocks-1 limit)
(error (message "Org mode fontification error in %S at %d"
(current-buffer)
(line-number-at-pos)))))
(defun org-fontify-inline-src-blocks-1 (limit)
"Fontify inline src_LANG blocks, from `point' up to LIMIT."
(let ((case-fold-search t))
;; The regexp below is copied from `org-element-inline-src-block-parser'.
(while (re-search-forward "\\_<src_\\([^ \t\n[{]+\\)[{[]?" limit t)
(let ((beg (match-beginning 0))
(lang-beg (match-beginning 1))
(lang-end (match-end 1))
pt)
(add-face-text-property beg lang-end 'org-inline-src-block)
(add-face-text-property beg lang-beg 'shadow)
(add-face-text-property lang-beg lang-end 'org-meta-line)
(setq pt (goto-char lang-end))
;; `org-element--parse-paired-brackets' doesn't take a limit, so to
;; prevent it searching the entire rest of the buffer we temporarily
;; narrow the active region.
(save-restriction
(narrow-to-region beg
(min limit (or (save-excursion
(and (search-forward"\n" limit t 2)
(point)))
(point-max))))
(when (ignore-errors (org-element--parse-paired-brackets ?\[))
(add-face-text-property pt (point) 'org-inline-src-block)
(setq pt (point)))
(when (ignore-errors (org-element--parse-paired-brackets ?\{))
(remove-text-properties pt (point) '(face nil))
(add-face-text-property pt (1+ pt) '(org-inline-src-block shadow))
(unless (= (1+ pt) (1- (point)))
(if org-src-fontify-natively
(org-src-font-lock-fontify-block
(buffer-substring-no-properties lang-beg lang-end)
(1+ pt) (1- (point)))
(font-lock-append-text-property
(1+ pt) (1- (point)) 'face 'org-inline-src-block)))
(add-face-text-property (1- (point)) (point) '(org-inline-src-block shadow))
(setq pt (point)))))
t)))
;;; Escape contents
(defun org-escape-code-in-region (beg end)
"Escape lines between BEG and END.
Escaping happens when a line starts with \"*\", \"#+\", \",*\" or
\",#+\" by appending a comma to it."
(interactive "r")
(save-excursion
(goto-char end)
(while (re-search-backward "^[ \t]*\\(,*\\(?:\\*\\|#\\+\\)\\)" beg t)
(save-excursion (replace-match ",\\1" nil nil nil 1)))))
(defun org-escape-code-in-string (s)
"Escape lines in string S.
Escaping happens when a line starts with \"*\", \"#+\", \",*\" or
\",#+\" by appending a comma to it."
(replace-regexp-in-string "^[ \t]*\\(,*\\(?:\\*\\|#\\+\\)\\)" ",\\1"
s nil nil 1))
(defun org-unescape-code-in-region (beg end)
"Un-escape lines between BEG and END.
Un-escaping happens by removing the first comma on lines starting
with \",*\", \",#+\", \",,*\" and \",,#+\"."
(interactive "r")
(save-excursion
(goto-char end)
(while (re-search-backward "^[ \t]*,*\\(,\\)\\(?:\\*\\|#\\+\\)" beg t)
(save-excursion (replace-match "" nil nil nil 1)))))
(defun org-unescape-code-in-string (s)
"Un-escape lines in string S.
Un-escaping happens by removing the first comma on lines starting
with \",*\", \",#+\", \",,*\" and \",,#+\"."
(replace-regexp-in-string
"^[ \t]*,*\\(,\\)\\(?:\\*\\|#\\+\\)" "" s nil nil 1))
;;; Org src minor mode
(defvar org-src-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "\C-c'" 'org-edit-src-exit)
(define-key map "\C-c\C-k" 'org-edit-src-abort)
(define-key map "\C-x\C-s" 'org-edit-src-save)
map))
(define-minor-mode org-src-mode
"Minor mode for language major mode buffers generated by Org.
\\<org-mode-map>
This minor mode is turned on in two situations:
- when editing a source code snippet with `\\[org-edit-special]'
- when formatting a source code snippet for export with htmlize.
\\{org-src-mode-map}
See also `org-src-mode-hook'."
:lighter " OrgSrc"
(when org-edit-src-persistent-message
(setq header-line-format
(substitute-command-keys
(if org-src--allow-write-back
"Edit, then exit with `\\[org-edit-src-exit]' or abort with \
`\\[org-edit-src-abort]'"
"Exit with `\\[org-edit-src-exit]' or abort with \
`\\[org-edit-src-abort]'"))))
;; Possibly activate various auto-save features (for the edit buffer
;; or the source buffer).
(when org-edit-src-turn-on-auto-save
(setq buffer-auto-save-file-name
(concat (make-temp-name "org-src-")
(format-time-string "-%Y-%d-%m")
".txt")))
(unless (or org-src--auto-save-timer
(= 0 org-edit-src-auto-save-idle-delay))
(setq org-src--auto-save-timer
(run-with-idle-timer
org-edit-src-auto-save-idle-delay t
(lambda ()
(save-excursion
(let (edit-flag)
(dolist (b (buffer-list))
(with-current-buffer b
(when (org-src-edit-buffer-p)
(unless edit-flag (setq edit-flag t))
(when (buffer-modified-p) (org-edit-src-save)))))
(unless edit-flag
(cancel-timer org-src--auto-save-timer)
(setq org-src--auto-save-timer nil)))))))))
(defun org-src-mode-configure-edit-buffer ()
"Configure the src edit buffer."
(when (bound-and-true-p org-src--from-org-mode)
(add-hook 'kill-buffer-hook #'org-src--remove-overlay nil 'local)
(if (bound-and-true-p org-src--allow-write-back)
(progn
(setq buffer-offer-save t)
(setq write-contents-functions '(org-edit-src-save)))
(setq buffer-read-only t))))
(add-hook 'org-src-mode-hook #'org-src-mode-configure-edit-buffer)
;;; Babel related functions
(defun org-src-associate-babel-session (info)
"Associate edit buffer with comint session.
INFO should be a list similar in format to the return value of
`org-babel-get-src-block-info'."
(interactive)
(let ((session (cdr (assq :session (nth 2 info)))))
(and session (not (string= session "none"))
(let ((f (intern (format "org-babel-%s-associate-session"
(nth 0 info)))))
(and (fboundp f) (funcall f session))))))
(defun org-src-babel-configure-edit-buffer ()
"Configure src editing buffer."
(when org-src--babel-info
(org-src-associate-babel-session org-src--babel-info)))
(add-hook 'org-src-mode-hook #'org-src-babel-configure-edit-buffer)
;;; Public API
(defmacro org-src-do-at-code-block (&rest body)
"Execute BODY from an edit buffer in the Org mode buffer."
(declare (debug (body)))
`(let ((beg-marker org-src--beg-marker))
(when beg-marker
(with-current-buffer (marker-buffer beg-marker)
(goto-char beg-marker)
,@body))))
(defun org-src-do-key-sequence-at-code-block (&optional key)
"Execute key sequence at code block in the source Org buffer.
The command bound to KEY in the Org-babel key map is executed
remotely with point temporarily at the start of the code block in
the Org buffer.
This command is not bound to a key by default, to avoid conflicts
with language major mode bindings. To bind it to \\`C-c @' in all
language major modes, you could use
(add-hook \\='org-src-mode-hook
(lambda () (define-key org-src-mode-map \"\\C-c@\"
\\='org-src-do-key-sequence-at-code-block)))
In that case, for example, \\`C-c @ t' issued in code edit buffers
would tangle the current Org code block, \\`C-c @ e' would execute
the block and \\`C-c @ h' would display the other available
Org-babel commands."
(interactive "kOrg-babel key: ")
(if (equal key (kbd "C-g")) (keyboard-quit)
(org-edit-src-save)
(org-src-do-at-code-block
(call-interactively (lookup-key org-babel-map key)))))
(defun org-src-get-lang-mode (lang)
"Return major mode that should be used for LANG.
LANG is a string, and the returned major mode is a symbol."
(intern
(concat
(let ((l (or (cdr (assoc lang org-src-lang-modes)) lang)))
(if (symbolp l) (symbol-name l) l))
"-mode")))
(defun org-src-edit-buffer-p (&optional buffer)
"Non-nil when current buffer is a source editing buffer.
If BUFFER is non-nil, test it instead."
(let ((buffer (org-base-buffer (or buffer (current-buffer)))))
(and (buffer-live-p buffer)
(local-variable-p 'org-src--beg-marker buffer)
(local-variable-p 'org-src--end-marker buffer))))
(defun org-src-source-buffer ()
"Return source buffer edited in current buffer.
Raise an error when current buffer is not a source editing buffer."
(unless (org-src-edit-buffer-p) (error "Not in a source buffer"))
(or (marker-buffer org-src--beg-marker)
(error "No source buffer available for current editing session")))
(defun org-src-source-type ()
"Return type of element edited in current buffer.
Raise an error when current buffer is not a source editing buffer."
(unless (org-src-edit-buffer-p) (error "Not in a source buffer"))
org-src--source-type)
(defun org-src-switch-to-buffer (buffer context)
"Switch to BUFFER considering CONTEXT and `org-src-window-setup'."
(pcase org-src-window-setup
(`plain
(when (eq context 'exit) (quit-restore-window))
(pop-to-buffer buffer))
(`current-window (pop-to-buffer-same-window buffer))
(`other-window
(let ((cur-win (selected-window)))
(switch-to-buffer-other-window buffer)
(when (eq context 'exit) (quit-restore-window cur-win))))
(`split-window-below
(if (eq context 'exit)
(delete-window)
(select-window (split-window-vertically)))
(pop-to-buffer-same-window buffer))
(`split-window-right
(if (eq context 'exit)
(delete-window)
(select-window (split-window-horizontally)))
(pop-to-buffer-same-window buffer))
(`other-frame
(pcase context
(`exit
(let ((frame (selected-frame)))
(switch-to-buffer-other-frame buffer)
(delete-frame frame)))
(`save
(kill-buffer (current-buffer))
(pop-to-buffer-same-window buffer))
(_ (switch-to-buffer-other-frame buffer))))
(`reorganize-frame
(pcase context
(`edit (pop-to-buffer buffer '(org-display-buffer-split)))
(`exit (pop-to-buffer buffer '(org-display-buffer-full-frame)))
(_ (switch-to-buffer-other-window buffer))))
(`switch-invisibly (set-buffer buffer))
(_
(message "Invalid value %s for `org-src-window-setup'"
org-src-window-setup)
(pop-to-buffer-same-window buffer))))
(defun org-src-coderef-format (&optional element)
"Return format string for block at point.
When optional argument ELEMENT is provided, use that block.
Otherwise, assume point is either at a source block, at an
example block.
If point is in an edit buffer, retrieve format string associated
to the remote source block."
(cond
((and element (org-element-property :label-fmt element)))
((org-src-edit-buffer-p) (org-src-do-at-code-block (org-src-coderef-format)))
((org-element-property :label-fmt (org-element-at-point)))
(t org-coderef-label-format)))
(defun org-src-coderef-regexp (fmt &optional label)
"Return regexp matching a coderef format string FMT.
When optional argument LABEL is non-nil, match coderef for that
label only.
Match group 1 contains the full coderef string with surrounding
white spaces. Match group 2 contains the same string without any
surrounding space. Match group 3 contains the label.
A coderef format regexp can only match at the end of a line."
(format "\\([ \t]*\\(%s\\)[ \t]*\\)$"
(replace-regexp-in-string
"%s"
(if label (regexp-quote label) "\\([-a-zA-Z0-9_][-a-zA-Z0-9_ ]*\\)")
(regexp-quote fmt)
nil t)))
(defun org-edit-footnote-reference ()
"Edit definition of footnote reference at point."
(interactive)
(let* ((context (org-element-context))
(label (org-element-property :label context)))
(unless (and (org-element-type-p context 'footnote-reference)
(org-src--on-datum-p context))
(user-error "Not on a footnote reference"))
(unless label (user-error "Cannot edit remotely anonymous footnotes"))
(let* ((definition (org-with-wide-buffer
(org-footnote-goto-definition label)
(backward-char)
(org-element-context)))
(inline? (org-element-type-p definition 'footnote-reference))
(contents
(org-with-wide-buffer
(buffer-substring-no-properties
(or (org-element-post-affiliated definition)
(org-element-begin definition))
(cond
(inline? (1+ (org-element-contents-end definition)))
((org-element-contents-end definition))
(t (goto-char (org-element-post-affiliated definition))
(line-end-position)))))))
(add-text-properties
0
(progn (string-match (if inline? "\\`\\[fn:.*?:" "\\`.*?\\]") contents)
(match-end 0))
'(read-only "Cannot edit footnote label" front-sticky t rear-nonsticky t)
contents)
(when inline?
(let ((l (length contents)))
(add-text-properties
(1- l) l
'(read-only "Cannot edit past footnote reference"
front-sticky nil rear-nonsticky nil)
contents)))
(org-src--edit-element
definition
(format "*Edit footnote [%s]*" label)
(let ((source (current-buffer)))
(lambda ()
(org-mode)
(org-clone-local-variables source)))
(lambda ()
(if (not inline?) (delete-region (point) (search-forward "]"))
(delete-region (point) (search-forward ":" nil t 2))
(delete-region (1- (point-max)) (point-max))
(when (re-search-forward "\n[ \t]*\n" nil t)
(user-error "Inline definitions cannot contain blank lines"))
;; If footnote reference belongs to a table, make sure to
;; remove any newline characters in order to preserve
;; table's structure.
(when (org-element-lineage definition 'table-cell)
(while (search-forward "\n" nil t) (replace-match " ")))))
contents
'remote))
;; Report success.
t))
(defun org-edit-table.el ()
"Edit \"table.el\" table at point.
\\<org-src-mode-map>
A new buffer is created and the table is copied into it. Then
the table is recognized with `table-recognize'. When done
editing, exit with `\\[org-edit-src-exit]'. The edited text will \
then replace
the area in the Org mode buffer.
Throw an error when not at such a table."
(interactive)
(let ((element (org-element-at-point)))
(unless (and (org-element-type-p element 'table)
(eq (org-element-property :type element) 'table.el)
(org-src--on-datum-p element))
(user-error "Not in a table.el table"))
(org-src--edit-element
element
(org-src--construct-edit-buffer-name (buffer-name) "Table")
#'text-mode t)
(when (bound-and-true-p flyspell-mode) (flyspell-mode -1))
(table-recognize)
t))
(defun org-edit-latex-fragment ()
"Edit LaTeX fragment at point."
(interactive)
(let ((context (org-element-context)))
(unless (and (org-element-type-p context 'latex-fragment)
(org-src--on-datum-p context))
(user-error "Not on a LaTeX fragment"))
(let* ((contents
(buffer-substring-no-properties
(org-element-begin context)
(- (org-element-end context)
(org-element-post-blank context))))
(delim-length (if (string-match "\\`\\$[^$]" contents) 1 2)))
;; Make the LaTeX deliminators read-only.
(add-text-properties 0 delim-length
(list 'read-only "Cannot edit LaTeX deliminator"
'front-sticky t
'rear-nonsticky t)
contents)
(let ((l (length contents)))
(add-text-properties (- l delim-length) l
(list 'read-only "Cannot edit LaTeX deliminator"
'front-sticky nil
'rear-nonsticky nil)
contents))
(org-src--edit-element
context
(org-src--construct-edit-buffer-name (buffer-name) "LaTeX fragment")
(org-src-get-lang-mode "latex")
(lambda ()
;; Blank lines break things, replace with a single newline.
(while (re-search-forward "\n[ \t]*\n" nil t) (replace-match "\n"))
;; If within a table a newline would disrupt the structure,
;; so remove newlines.
(goto-char (point-min))
(when (org-element-lineage context 'table-cell)
(while (search-forward "\n" nil t) (replace-match " "))))
contents))
t))
(defun org-edit-latex-environment ()
"Edit LaTeX environment at point.
\\<org-src-mode-map>
The LaTeX environment is copied into a new buffer. Major mode is
set to the one associated to \"latex\" in `org-src-lang-modes',
or to `latex-mode' if there is none.
When done, exit with `\\[org-edit-src-exit]'. The edited text \
will then replace
the LaTeX environment in the Org mode buffer."
(interactive)
(let ((element (org-element-at-point)))
(unless (and (org-element-type-p element 'latex-environment)
(org-src--on-datum-p element))
(user-error "Not in a LaTeX environment"))
(org-src--edit-element
element
(org-src--construct-edit-buffer-name (buffer-name) "LaTeX environment")
(org-src-get-lang-mode "latex")
t)
t))
(defun org-edit-export-block ()
"Edit export block at point.
\\<org-src-mode-map>
A new buffer is created and the block is copied into it, and the
buffer is switched into an appropriate major mode. See also
`org-src-lang-modes'.
When done, exit with `\\[org-edit-src-exit]'. The edited text \
will then replace
the area in the Org mode buffer.
Throw an error when not at an export block."
(interactive)
(let ((element (org-element-at-point)))
(unless (and (org-element-type-p element 'export-block)
(org-src--on-datum-p element))
(user-error "Not in an export block"))
(let* ((type (downcase (or (org-element-property :type element)
;; Missing export-block type. Fallback
;; to default mode.
"fundamental")))
(mode (org-src-get-lang-mode type)))
(unless (functionp mode) (error "No such language mode: %s" mode))
(org-src--edit-element
element
(org-src--construct-edit-buffer-name (buffer-name) type)
mode
(lambda () (org-escape-code-in-region (point-min) (point-max)))))
t))
(defun org-edit-comment-block ()
"Edit comment block at point.
\\<org-src-mode-map>
A new buffer is created and the block is copied into it, and the
buffer is switched into Org mode.
When done, exit with `\\[org-edit-src-exit]'. The edited text will
then replace the area in the Org mode buffer.
Throw an error when not at a comment block."
(interactive)
(let ((element (org-element-at-point)))
(unless (and (org-element-type-p element 'comment-block)
(org-src--on-datum-p element))
(user-error "Not in a comment block"))
(org-src--edit-element
element
(org-src--construct-edit-buffer-name (buffer-name) "org")
'org-mode
(lambda () (org-escape-code-in-region (point-min) (point-max)))
(org-unescape-code-in-string (org-element-property :value element)))
t))
(defun org-edit-src-code (&optional code edit-buffer-name)
"Edit the source or example block at point.
\\<org-src-mode-map>
The code is copied to a separate buffer and the appropriate mode
is turned on. When done, exit with `\\[org-edit-src-exit]'. This \
will remove the
original code in the Org buffer, and replace it with the edited
version. See `org-src-window-setup' to configure the display of
windows containing the Org buffer and the code buffer.
When optional argument CODE is a string, edit it in a dedicated
buffer instead.
When optional argument EDIT-BUFFER-NAME is non-nil, use it as the
name of the sub-editing buffer."
(interactive)
(let* ((element (org-element-at-point))
(type (org-element-type element)))
(unless (and (memq type '(example-block src-block))
(org-src--on-datum-p element))
(user-error "Not in a source or example block"))
(let* ((lang
(if (eq type 'src-block) (org-element-property :language element)
"example"))
(lang-f (and (eq type 'src-block) (org-src-get-lang-mode lang)))
(babel-info (and (eq type 'src-block)
(org-babel-get-src-block-info 'no-eval)))
deactivate-mark)
(when (and (eq type 'src-block) (not (functionp lang-f)))
(error "No such language mode: %s" lang-f))
(org-src--edit-element
element
(or edit-buffer-name
(org-src--construct-edit-buffer-name (buffer-name) lang))
(lambda ()
(when lang-f (funcall lang-f))
(setq-local org-coderef-label-format
(or (org-element-property :label-fmt element)
org-coderef-label-format))
(when (eq type 'src-block)
(setq org-src--babel-info babel-info)))
(and (null code)
(lambda () (org-escape-code-in-region (point-min) (point-max))))
(and code (org-unescape-code-in-string code)))
;; Finalize buffer.
(when (eq type 'src-block)
(let ((edit-prep-func (intern (concat "org-babel-edit-prep:" lang))))
(when (fboundp edit-prep-func)
(funcall edit-prep-func babel-info))))
t)))
(defun org-edit-inline-src-code ()
"Edit inline source code at point."
(interactive)
(let ((context (org-element-context)))
(unless (and (org-element-type-p context 'inline-src-block)
(org-src--on-datum-p context))
(user-error "Not on inline source code"))
(let* ((lang (org-element-property :language context))
(lang-f (org-src-get-lang-mode lang))
(babel-info (org-babel-get-src-block-info 'no-eval))
deactivate-mark)
(unless (functionp lang-f) (error "No such language mode: %s" lang-f))
(org-src--edit-element
context
(org-src--construct-edit-buffer-name (buffer-name) lang)
lang-f
(lambda ()
;; Inline source blocks are limited to one line.
(while (re-search-forward "\n[ \t]*" nil t) (replace-match " "))
;; Trim contents.
(goto-char (point-min))
(skip-chars-forward " \t")
(delete-region (point-min) (point))
(goto-char (point-max))
(skip-chars-backward " \t")
(delete-region (point) (point-max))))
;; Finalize buffer.
(setq org-src--babel-info babel-info)
(setq org-src--preserve-indentation t)
(let ((edit-prep-func (intern (concat "org-babel-edit-prep:" lang))))
(when (fboundp edit-prep-func) (funcall edit-prep-func babel-info)))
;; Return success.
t)))
(defun org-edit-fixed-width-region ()
"Edit the fixed-width ASCII drawing at point.
\\<org-src-mode-map>
This must be a region where each line starts with a colon
followed by a space or a newline character.
A new buffer is created and the fixed-width region is copied into
it, and the buffer is switched into the major mode defined in
`org-edit-fixed-width-region-mode', which see.
When done, exit with `\\[org-edit-src-exit]'. The edited text \
will then replace
the area in the Org mode buffer."
(interactive)
(let ((element (org-element-at-point)))
(unless (and (org-element-type-p element 'fixed-width)
(org-src--on-datum-p element))
(user-error "Not in a fixed-width area"))
(org-src--edit-element
element
(org-src--construct-edit-buffer-name (buffer-name) "Fixed Width")
org-edit-fixed-width-region-mode
(lambda () (while (not (eobp)) (insert ": ") (forward-line))))
;; Return success.
t))
(defun org-edit-src-abort ()
"Abort editing of the src code and return to the Org buffer."
(interactive)
(let (org-src--allow-write-back) (org-edit-src-exit)))
(defun org-edit-src-continue (event)
"Unconditionally return to buffer editing area under point.
Throw an error if there is no such buffer.
EVENT is passed to `mouse-set-point'."
(interactive "e")
(mouse-set-point event)
(let ((buf (get-char-property (point) 'edit-buffer)))
(if buf (org-src-switch-to-buffer buf 'continue)
(user-error "No sub-editing buffer for area at point"))))
(defun org-edit-src-save ()
"Save parent buffer with current state source-code buffer."
(interactive)
(unless (org-src-edit-buffer-p) (user-error "Not in a sub-editing buffer"))
(set-buffer-modified-p nil)
(let ((write-back-buf (generate-new-buffer "*org-src-write-back*"))
(beg org-src--beg-marker)
(end org-src--end-marker)
(overlay org-src--overlay))
(org-src--contents-for-write-back write-back-buf)
(with-current-buffer (org-src-source-buffer)
(undo-boundary)
(goto-char beg)
;; Temporarily disable read-only features of OVERLAY in order to
;; insert new contents.
(delete-overlay overlay)
(let ((expecting-bol (bolp)))
(if (version< emacs-version "27.1")
(progn (delete-region beg end)
(insert (with-current-buffer write-back-buf (buffer-string))))
(save-restriction
(narrow-to-region beg end)
(org-replace-buffer-contents write-back-buf 0.1 nil)
(goto-char (point-max))))
(when (and expecting-bol (not (bolp))) (insert "\n")))
(kill-buffer write-back-buf)
(save-buffer)
(move-overlay overlay beg (point))))
;; `write-contents-functions' requires the function to return
;; a non-nil value so that other functions are not called.
t)
(defun org-edit-src-exit ()
"Kill current sub-editing buffer and return to source buffer."
(interactive)
(unless (org-src-edit-buffer-p)
(error "Not in a sub-editing buffer"))
(let* ((beg org-src--beg-marker)
(end org-src--end-marker)
(write-back org-src--allow-write-back)
(remote org-src--remote)
(coordinates (and (not remote)
(org-src--coordinates (point) 1 (point-max))))
(write-back-buf
(and write-back (generate-new-buffer "*org-src-write-back*"))))
(when write-back (org-src--contents-for-write-back write-back-buf))
(set-buffer-modified-p nil)
;; Switch to source buffer. Kill sub-editing buffer.
(let ((edit-buffer (current-buffer))
(source-buffer (marker-buffer beg)))
(unless source-buffer
(when write-back-buf (kill-buffer write-back-buf))
(error "Source buffer disappeared. Aborting"))
(org-src-switch-to-buffer source-buffer 'exit)
(kill-buffer edit-buffer))
;; Insert modified code. Ensure it ends with a newline character.
(org-with-wide-buffer
(when (and write-back
(not (equal (buffer-substring beg end)
(with-current-buffer write-back-buf
(buffer-string)))))
(undo-boundary)
(goto-char beg)
(let ((expecting-bol (bolp)))
(if (version< emacs-version "27.1")
(progn (delete-region beg end)
(insert (with-current-buffer write-back-buf
(buffer-string))))
(save-restriction
(narrow-to-region beg end)
(org-replace-buffer-contents write-back-buf 0.1 nil)
(goto-char (point-max))))
(when (and expecting-bol (not (bolp))) (insert "\n")))))
(when write-back-buf (kill-buffer write-back-buf))
;; If we are to return to source buffer, put point at an
;; appropriate location. In particular, if block is hidden, move
;; to the beginning of the block opening line.
(unless remote
(goto-char beg)
(cond
;; Block is hidden; move at start of block.
((org-fold-folded-p nil 'block) (forward-line -1))
(write-back (org-src--goto-coordinates coordinates beg end))))
;; Clean up left-over markers and restore window configuration.
(set-marker beg nil)
(set-marker end nil)
(when org-src--saved-temp-window-config
(unwind-protect
(set-window-configuration org-src--saved-temp-window-config)
(setq org-src--saved-temp-window-config nil)))))
(provide 'org-src)
;;; org-src.el ends here
org-mode-9.7.29+dfsg/lisp/org-table.el 0000664 0000000 0000000 00000737434 15004304337 0017440 0 ustar 00root root 0000000 0000000 ;;; org-table.el --- The Table Editor for Org -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2025 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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 <https://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;; This file contains the table editor and spreadsheet for Org mode.
;; Watch out: Here we are talking about two different kind of tables.
;; Most of the code is for the tables created with the Org mode table editor.
;; Sometimes, we talk about tables created and edited with the table.el
;; Emacs package. We call the former org-type tables, and the latter
;; table.el-type tables.
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'cl-lib)
(require 'org-macs)
(require 'org-compat)
(require 'org-keys)
(require 'org-fold-core)
(declare-function calc-eval "calc" (str &optional separator &rest args))
(declare-function face-remap-remove-relative "face-remap" (cookie))
(declare-function face-remap-add-relative "face-remap" (face &rest specs))
(declare-function org-at-timestamp-p "org" (&optional extended))
(declare-function org-delete-backward-char "org" (N))
(declare-function org-mode "org" ())
(declare-function org-duration-p "org-duration" (duration &optional canonical))
(declare-function org-duration-to-minutes "org-duration" (duration &optional canonical))
(declare-function org-element-at-point "org-element" (&optional pom cached-only))
(declare-function org-element-contents "org-element-ast" (node))
(declare-function org-element-extract "org-element-ast" (node))
(declare-function org-element-interpret-data "org-element" (data))
(declare-function org-element-lineage "org-element-ast" (blob &optional types with-self))
(declare-function org-element-map "org-element" (data types fun &optional info first-match no-recursion with-affiliated))
(declare-function org-element-parse-buffer "org-element" (&optional granularity visible-only keep-deferred))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-end "org-element" (node))
(declare-function org-element-post-affiliated "org-element" (node))
(declare-function org-element-type-p "org-element-ast" (node types))
(declare-function org-element-cache-reset "org-element" (&optional all no-persistence))
(declare-function org-entry-get "org" (pom property &optional inherit literal-nil))
(declare-function org-export-create-backend "ox" (&rest rest) t)
(declare-function org-export-data-with-backend "ox" (data backend info))
(declare-function org-export-filter-apply-functions "ox" (filters value info))
(declare-function org-export-first-sibling-p "ox" (blob info))
(declare-function org-export-get-backend "ox" (name))
(declare-function org-export-get-environment "ox" (&optional backend subtreep ext-plist))
(declare-function org-export-install-filters "ox" (info))
(declare-function org-export-table-has-special-column-p "ox" (table))
(declare-function org-export-table-row-is-special-p "ox" (table-row info))
(declare-function org-forward-paragraph "org" (&optional arg))
(declare-function org-id-find "org-id" (id &optional markerp))
(declare-function org-indent-line "org" ())
(declare-function org-load-modules-maybe "org" (&optional force))
(declare-function org-restart-font-lock "org" ())
(declare-function org-sort-remove-invisible "org" (s))
(declare-function org-time-stamp-format "org" (&optional long inactive))
(declare-function org-time-string-to-absolute "org" (s &optional daynr prefer buffer pos))
(declare-function org-time-string-to-time "org" (s))
(declare-function org-timestamp-up-day "org" (&optional arg))
(defvar constants-unit-system)
(defvar org-M-RET-may-split-line)
(defvar org-element-use-cache)
(defvar org-export-filters-alist)
(defvar org-finish-function)
(defvar org-inhibit-highlight-removal)
(defvar org-inhibit-startup)
(defvar org-selected-window)
(defvar org-self-insert-cluster-for-undo)
(defvar org-self-insert-command-undo-counter)
(defvar org-ts-regexp)
(defvar org-ts-regexp-both)
(defvar org-ts-regexp-inactive)
(defvar org-ts-regexp3)
(defvar org-window-configuration)
(defvar sort-fold-case)
;;; Customizables
(defgroup org-table nil
"Options concerning tables in Org mode."
:tag "Org Table"
:group 'org)
(defcustom orgtbl-optimized t
"Non-nil means use the optimized table editor version for `orgtbl-mode'.
In the optimized version, the table editor takes over all simple keys that
normally just insert a character. In tables, the characters are inserted
in a way to minimize disturbing the table structure (i.e. in overwrite mode
for empty fields). Outside tables, the correct binding of the keys is
restored.
Changing this variable requires a restart of Emacs to become
effective."
:group 'org-table
:type 'boolean)
(defcustom orgtbl-radio-table-templates
'((latex-mode "% BEGIN RECEIVE ORGTBL %n
% END RECEIVE ORGTBL %n
\\begin{comment}
#+ORGTBL: SEND %n orgtbl-to-latex :splice nil :skip 0
| | |
\\end{comment}\n")
(texinfo-mode "@c BEGIN RECEIVE ORGTBL %n
@c END RECEIVE ORGTBL %n
@ignore
#+ORGTBL: SEND %n orgtbl-to-html :splice nil :skip 0
| | |
@end ignore\n")
(html-mode "<!-- BEGIN RECEIVE ORGTBL %n -->
<!-- END RECEIVE ORGTBL %n -->
<!--
#+ORGTBL: SEND %n orgtbl-to-html :splice nil :skip 0
| | |
-->\n")
(org-mode "#+ BEGIN RECEIVE ORGTBL %n
#+ END RECEIVE ORGTBL %n
#+ORGTBL: SEND %n orgtbl-to-orgtbl :splice nil :skip 0
| | |
"))
"Templates for radio tables in different major modes.
Each template must define lines that will be treated as a comment and that
must contain the \"BEGIN RECEIVE ORGTBL %n\" and \"END RECEIVE ORGTBL\"
lines where \"%n\" will be replaced with the name of the table during
insertion of the template. The transformed table will later be inserted
between these lines.
The template should also contain a minimal table in a multiline comment.
If multiline comments are not possible in the buffer language,
you can pack it into a string that will not be used when the code
is compiled or executed. Above the table will you need a line with
the fixed string \"#+ORGTBL: SEND\", followed by instruction on how to
convert the table into a data structure useful in the
language of the buffer. Check the manual for the section on
\"Translator functions\", and more generally check out
the Info node `(org)Tables in arbitrary syntax'.
All occurrences of %n in a template will be replaced with the name of the
table, obtained by prompting the user."
:group 'org-table
:type '(repeat
(list (symbol :tag "Major mode")
(string :tag "Format"))))
(defgroup org-table-settings nil
"Settings for tables in Org mode."
:tag "Org Table Settings"
:group 'org-table)
(defcustom org-table-header-line-p nil
"Activate `org-table-header-line-mode' by default?"
:type 'boolean
:package-version '(Org . "9.4")
:group 'org-table)
(defcustom org-table-default-size "5x2"
"The default size for newly created tables, Columns x Rows."
:group 'org-table-settings
:type 'string)
(defcustom org-table-number-regexp
"^\\([<>]?[-+^.0-9]*[0-9][-+^.0-9eEdDx()%:]*\\|[<>]?[-+]?0[xX][[:xdigit:].]+\\|[<>]?[-+]?[0-9]+#[0-9a-zA-Z.]+\\|nan\\|[-+u]?inf\\)$"
"Regular expression for recognizing numbers in table columns.
If a table column contains mostly numbers, it will be aligned to the
right. If not, it will be aligned to the left.
The default value of this option is a regular expression which allows
anything which looks remotely like a number as used in scientific
context. For example, all of the following will be considered a
number:
12 12.2 2.4e-08 2x10^12 4.034+-0.02 2.7(10) >3.5
Other options offered by the customize interface are more restrictive."
:group 'org-table-settings
:type '(choice
(const :tag "Positive Integers"
"^[0-9]+$")
(const :tag "Integers"
"^[-+]?[0-9]+$")
(const :tag "Floating Point Numbers"
"^[-+]?\\([0-9]*\\.[0-9]+\\|[0-9]+\\.[0-9]*\\)$")
(const :tag "Floating Point Number or Integer"
"^[-+]?\\([0-9]*\\.[0-9]+\\|[0-9]+\\.?[0-9]*\\)$")
(const :tag "Exponential, Floating point, Integer"
"^[-+]?[0-9.]+\\([eEdD][-+0-9]+\\)?$")
(const :tag "Very General Number-Like, including hex and Calc radix"
"^\\([<>]?[-+^.0-9]*[0-9][-+^.0-9eEdDx()%]*\\|[<>]?[-+]?0[xX][[:xdigit:].]+\\|[<>]?[-+]?[0-9]+#[0-9a-zA-Z.]+\\|nan\\|[-+u]?inf\\)$")
(const :tag "Very General Number-Like, including hex and Calc radix, allows comma as decimal mark"
"^\\([<>]?[-+^.,0-9]*[0-9][-+^.0-9eEdDx()%]*\\|[<>]?[-+]?0[xX][[:xdigit:].]+\\|[<>]?[-+]?[0-9]+#[0-9a-zA-Z.]+\\|nan\\|[-+u]?inf\\)$")
(regexp :tag "Regexp:")))
(defcustom org-table-number-fraction 0.5
"Fraction of numbers in a column required to make the column align right.
In a column all non-white fields are considered. If at least
this fraction of fields is matched by `org-table-number-regexp',
alignment to the right border applies."
:group 'org-table-settings
:type 'number)
(defcustom org-table-formula-field-format "%s"
"Format for fields which contain the result of a formula.
For example, using \"~%s~\" will display the result within tilde
characters. Beware that modifying the display can prevent the
field from being used in another formula."
:group 'org-table-settings
:version "24.1"
:type 'string)
(defgroup org-table-editing nil
"Behavior of tables during editing in Org mode."
:tag "Org Table Editing"
:group 'org-table)
(defcustom org-table-automatic-realign t
"Non-nil means automatically re-align table when pressing TAB or RETURN.
When nil, aligning is only done with `\\[org-table-align]', or after column
removal/insertion."
:group 'org-table-editing
:type 'boolean)
(defcustom org-table-auto-blank-field t
"Non-nil means automatically blank table field when starting to type into it.
This only happens when typing immediately after a field motion
command (TAB, S-TAB or RET)."
:group 'org-table-editing
:type 'boolean)
(defcustom org-table-exit-follow-field-mode-when-leaving-table t
"Non-nil means automatically exit the follow mode.
When nil, the follow mode will stay on and be active in any table
the cursor enters. Since the table follow filed mode messes with the
window configuration, it is not recommended to set this variable to nil,
except maybe locally in a special file that has mostly tables with long
fields."
:group 'org-table
:version "24.1"
:type 'boolean)
(defcustom org-table-fix-formulas-confirm nil
"Whether the user should confirm when Org fixes formulas."
:group 'org-table-editing
:version "24.1"
:type '(choice
(const :tag "with yes-or-no" yes-or-no-p)
(const :tag "with y-or-n" y-or-n-p)
(const :tag "no confirmation" nil)))
(defcustom org-table-tab-jumps-over-hlines t
"Non-nil means tab in the last column of a table with jump over a hline.
If a horizontal separator line is following the current line,
`org-table-next-field' can either create a new row before that line, or jump
over the line. When this option is nil, a new line will be created before
this line."
:group 'org-table-editing
:type 'boolean)
(defcustom org-table-shrunk-column-indicator "…"
"String to be displayed in a shrunk column."
:group 'org-table-editing
:type 'string
:package-version '(Org . "9.2")
:safe (lambda (v) (and (stringp v) (not (equal v "")))))
(defgroup org-table-calculation nil
"Options concerning tables in Org mode."
:tag "Org Table Calculation"
:group 'org-table)
(defcustom org-table-use-standard-references 'from
"Non-nil means using table references like B3 instead of @3$2.
Possible values are:
nil never use them
from accept as input, do not present for editing
t accept as input and present for editing"
:group 'org-table-calculation
:type '(choice
(const :tag "Never, don't even check user input for them" nil)
(const :tag "Always, both as user input, and when editing" t)
(const :tag "Convert user input, don't offer during editing" from)))
(defcustom org-table-copy-increment t
"Non-nil means increment when copying current field with \
`\\[org-table-copy-down]'."
:group 'org-table-calculation
:version "26.1"
:package-version '(Org . "8.3")
:type '(choice
(const :tag "Use the difference between the current and the above fields" t)
(integer :tag "Use a number" 1)
(const :tag "Don't increment the value when copying a field" nil)))
(defcustom org-calc-default-modes
'(calc-internal-prec 12
calc-float-format (float 8)
calc-angle-mode deg
calc-prefer-frac nil
calc-symbolic-mode nil
calc-date-format (YYYY "-" MM "-" DD " " Www (" " hh ":" mm))
calc-display-working-message t)
"List with Calc mode settings for use in `calc-eval' for table formulas.
The list must contain alternating symbols (Calc modes variables and values).
Don't remove any of the default settings, just change the values. Org mode
relies on the variables to be present in the list."
:group 'org-table-calculation
:type 'plist)
(defcustom org-table-duration-custom-format 'hours
"Format for the output of calc computations like $1+$2;t.
The default value is `hours', and will output the results as a
number of hours. Other allowed values are `seconds', `minutes' and
`days', and the output will be a fraction of seconds, minutes or
days. `hh:mm' selects to use hours and minutes, ignoring seconds.
The `U' flag in a table formula will select this specific format for
a single formula."
:group 'org-table-calculation
:version "24.1"
:type '(choice (const :tag "Seconds" seconds)
(const :tag "Minutes" minutes)
(const :tag "Hours " hours)
(const :tag "Days " days)
(const :tag "HH:MM " hh:mm)))
(defcustom org-table-duration-hour-zero-padding t
"Non-nil means hours in table duration computations should be zero-padded.
So this is about 08:32:34 versus 8:33:34."
:group 'org-table-calculation
:version "26.1"
:package-version '(Org . "9.1")
:type 'boolean
:safe #'booleanp)
(defcustom org-table-formula-evaluate-inline t
"Non-nil means TAB and RET evaluate a formula in current table field.
If the current field starts with an equal sign, it is assumed to be a formula
which should be evaluated as described in the manual and in the documentation
string of the command `org-table-eval-formula'. This feature requires the
Emacs calc package.
When this variable is nil, formula calculation is only available through
the command `\\[org-table-eval-formula]'."
:group 'org-table-calculation
:type 'boolean)
(defcustom org-table-formula-use-constants t
"Non-nil means interpret constants in formulas in tables.
A constant looks like `$c' or `$Grav' and will be replaced before evaluation
by the value given in `org-table-formula-constants', or by a value obtained
from the `constants.el' package."
:group 'org-table-calculation
:type 'boolean)
(defcustom org-table-formula-constants nil
"Alist with constant names and values, for use in table formulas.
The car of each element is a name of a constant, without the `$' before it.
The cdr is the value as a string. For example, if you'd like to use the
speed of light in a formula, you would configure
(setq org-table-formula-constants \\='((\"c\" . \"299792458.\")))
and then use it in an equation like `$1*$c'.
Constants can also be defined on a per-file basis using a line like
#+CONSTANTS: c=299792458. pi=3.14 eps=2.4e-6"
:group 'org-table-calculation
:type '(repeat
(cons (string :tag "name")
(string :tag "value"))))
(defcustom org-table-allow-automatic-line-recalculation t
"Non-nil means lines marked with |#| or |*| will be recomputed automatically.
\\<org-mode-map>\
Automatically means when `TAB' or `RET' or `\\[org-ctrl-c-ctrl-c]' \
are pressed in the line."
:group 'org-table-calculation
:type 'boolean)
(defcustom org-table-relative-ref-may-cross-hline t
"Non-nil means relative formula references may cross hlines.
Here are the allowed values:
nil Relative references may not cross hlines. They will reference the
field next to the hline instead. Coming from below, the reference
will be to the field below the hline. Coming from above, it will be
to the field above.
t Relative references may cross hlines.
error An attempt to cross a hline will throw an error.
It is probably good to never set this variable to nil, for the sake of
portability of tables."
:group 'org-table-calculation
:type '(choice
(const :tag "Allow crossing hline" t)
(const :tag "Stick to hline" nil)
(const :tag "Error on attempt to cross" error)))
(defcustom org-table-formula-create-columns nil
"Non-nil means evaluation of formula can add new columns.
When non-nil, evaluating an out-of-bounds field can insert as
many columns as needed. When set to `warn', issue a warning when
doing so. When set to `prompt', ask user before creating a new
column. Otherwise, throw an error."
:group 'org-table-calculation
:package-version '(Org . "8.3")
:type '(choice
(const :tag "Out-of-bounds field generates an error (default)" nil)
(const :tag "Out-of-bounds field silently adds columns as needed" t)
(const :tag "Out-of-bounds field adds columns, but issues a warning" warn)
(const :tag "Prompt user when setting an out-of-bounds field" prompt)))
(defgroup org-table-import-export nil
"Options concerning table import and export in Org mode."
:tag "Org Table Import Export"
:group 'org-table)
(defcustom org-table-export-default-format "orgtbl-to-tsv"
"Default export parameters for `org-table-export'.
These can be overridden for a specific table by setting the
TABLE_EXPORT_FORMAT property. See the manual section on orgtbl
radio tables for the different export transformations and
available parameters."
:group 'org-table-import-export
:type 'string)
(defcustom org-table-convert-region-max-lines 999
"Max lines that `org-table-convert-region' will attempt to process.
The function can be slow on larger regions; this safety feature
prevents it from hanging Emacs."
:group 'org-table-import-export
:type 'integer
:package-version '(Org . "8.3"))
;;; Org table header minor mode
(defun org-table-row-get-visible-string (&optional pos)
"Get the visible string of a table row.
This may be useful when columns have been shrunk."
(save-excursion
(when pos (goto-char pos))
(let* ((beg (line-beginning-position))
(end (line-end-position))
(str (buffer-substring beg end)))
;; FIXME: This does not handle intersecting overlays.
(dolist (ov (overlays-in beg end))
(when (overlay-get ov 'display)
(put-text-property
(- (overlay-start ov) beg) (- (overlay-end ov) beg)
'display (overlay-get ov 'display)
str)))
str)))
(defvar-local org-table-header-overlay nil)
(put 'org-table-header-overlay 'permanent-local t)
(defun org-table-header-set-header ()
"Display the header of the table at point."
(let ((gcol temporary-goal-column))
(unwind-protect
(progn
(when (overlayp org-table-header-overlay)
(delete-overlay org-table-header-overlay))
;; We might be called after scrolling but before display is
;; updated. Make sure that any queued redisplay is executed
;; before we look into `window-start'.
(redisplay)
(let* ((ws (window-start))
(beg (save-excursion
;; Check table at window start, not at point.
;; Point might be after the table, or at
;; another table located below the one visible
;; on top.
(goto-char ws)
(goto-char (org-table-begin))
(while (or (org-at-table-hline-p)
(looking-at-p ".*|\\s-+<[rcl]?\\([0-9]+\\)?>"))
(move-beginning-of-line 2))
(line-beginning-position))))
(if (pos-visible-in-window-p beg)
(when (overlayp org-table-header-overlay)
(delete-overlay org-table-header-overlay))
(setq org-table-header-overlay
(make-overlay
(save-excursion (goto-char ws) (line-beginning-position))
(save-excursion (goto-char ws) (line-end-position))))
(org-overlay-display
org-table-header-overlay
(org-table-row-get-visible-string beg)
'org-table-header))))
(setq temporary-goal-column gcol))))
;;;###autoload
(define-minor-mode org-table-header-line-mode
"Display the first row of the table at point in the header line."
:lighter " TblHeader"
(unless (eq major-mode 'org-mode)
(user-error "Cannot turn org table header mode outside org-mode buffers"))
(if org-table-header-line-mode
(add-hook 'post-command-hook #'org-table-header-set-header nil t)
(when (overlayp org-table-header-overlay)
(delete-overlay org-table-header-overlay)
(setq org-table-header-overlay nil))
(remove-hook 'post-command-hook #'org-table-header-set-header t)))
;;; Regexps Constants
(defconst org-table-any-line-regexp "^[ \t]*\\(|\\|\\+-[-+]\\)"
"Detect an org-type or table-type table.")
(defconst org-table-line-regexp "^[ \t]*|"
"Detect an org-type table line.")
(defconst org-table-dataline-regexp "^[ \t]*|[^-]"
"Detect an org-type table line.")
(defconst org-table-hline-regexp "^[ \t]*|-"
"Detect an org-type table hline.")
(defconst org-table1-hline-regexp "^[ \t]*\\+-[-+]"
"Detect a table-type table hline.")
(defconst org-table-any-border-regexp "^[ \t]*[^|+ \t]"
"Detect the first line outside a table when searching from within it.
This works for both table types.")
(defconst org-TBLFM-regexp "^[ \t]*#\\+TBLFM: "
"Detect a #+TBLFM line.")
(defvar org-table-TBLFM-begin-regexp "^[ \t]*|.*\n[ \t]*#\\+TBLFM: ")
(defconst org-table-auto-recalculate-regexp "^[ \t]*| *# *\\(|\\|$\\)"
"Regexp matching a line marked for automatic recalculation.")
(defconst org-table-recalculate-regexp "^[ \t]*| *[#*] *\\(|\\|$\\)"
"Regexp matching a line marked for recalculation.")
(defconst org-table-calculate-mark-regexp "^[ \t]*| *[!$^_#*] *\\(|\\|$\\)"
"Regexp matching a line marked for calculation.")
(defconst org-table-border-regexp "^[ \t]*[^| \t]"
"Regexp matching any line outside an Org table.")
(defconst org-table-range-regexp
"@\\([-+]?I*[-+]?[0-9]*\\)\\(\\$[-+]?[0-9]+\\)?\\(\\.\\.@?\\([-+]?I*[-+]?[0-9]*\\)\\(\\$[-+]?[0-9]+\\)?\\)?"
;; 1 2 3 4 5
"Regular expression for matching ranges in formulas.")
(defconst org-table-range-regexp2
(concat
"\\(" "@[-0-9I$&]+" "\\|" "[a-zA-Z]\\{1,2\\}\\([0-9]+\\|&\\)" "\\|" "\\$[a-zA-Z0-9]+" "\\)"
"\\.\\."
"\\(" "@?[-0-9I$&]+" "\\|" "[a-zA-Z]\\{1,2\\}\\([0-9]+\\|&\\)" "\\|" "\\$[a-zA-Z0-9]+" "\\)")
"Match a range for reference display.")
(defconst org-table-translate-regexp
(concat "\\(" "@[-0-9I$]+" "\\|" "[a-zA-Z]\\{1,2\\}\\([0-9]+\\|&\\)" "\\)")
"Match a reference that needs translation, for reference display.")
(defconst org-table--separator-space-pre
(propertize " " 'display '(space :relative-width 1) 'rear-nonsticky t)
"Space used in front of fields when aligning the table.
This space serves as a segment separator for the purposes of the
bidirectional reordering.
Note that `org-table--separator-space-pre' is not `eq' to
`org-table--separator-space-post'. This is done to prevent Emacs from
visually merging spaces in an empty table cell. See bug#45915.")
(defconst org-table--separator-space-post
(propertize " " 'display '(space :relative-width 1.001))
"Space used after fields when aligning the table.
This space serves as a segment separator for the purposes of the
bidirectional reordering.
Note that `org-table--separator-space-pre' is not `eq' to
`org-table--separator-space-post'. This is done to prevent Emacs from
visually merging spaces in an empty table cell. See bug#45915.")
;;; Internal Variables
(defvar org-table-last-highlighted-reference nil)
(defvar org-table-formula-history nil)
(defvar org-field-marker nil)
(defvar org-table-buffer-is-an nil)
(defvar-local org-table-formula-constants-local nil
"Local version of `org-table-formula-constants'.")
(defvar org-table-may-need-update t
"Indicates that a table might need an update.
This variable is set by `org-before-change-function'.
`org-table-align' sets it back to nil.")
(defvar orgtbl-after-send-table-hook nil
"Hook for functions attaching to \\`C-c C-c', if the table is sent.
This can be used to add additional functionality after the table is sent
to the receiver position, otherwise, if table is not sent, the functions
are not run.")
(defvar org-table-column-names nil
"Alist with column names, derived from the `!' line.
This variable is initialized with `org-table-analyze'.")
(defvar org-table-column-name-regexp nil
"Regular expression matching the current column names.
This variable is initialized with `org-table-analyze'.")
(defvar org-table-local-parameters nil
"Alist with parameter names, derived from the `$' line.
This variable is initialized with `org-table-analyze'.")
(defvar org-table-named-field-locations nil
"Alist with locations of named fields.
Associations follow the pattern (NAME LINE COLUMN) where
NAME is the name of the field as a string,
LINE is the number of lines from the beginning of the table,
COLUMN is the column of the field, as an integer.
This variable is initialized with `org-table-analyze'.")
(defvar org-table-current-line-types nil
"Table row types in current table.
This variable is initialized with `org-table-analyze'.")
(defvar org-table-current-begin-pos nil
"Current table begin position, as a marker.
This variable is initialized with `org-table-analyze'.")
(defvar org-table-current-ncol nil
"Number of columns in current table.
This variable is initialized with `org-table-analyze'.")
(defvar org-table-dlines nil
"Vector of data line line numbers in the current table.
Line numbers are counted from the beginning of the table. This
variable is initialized with `org-table-analyze'.")
(defvar org-table-hlines nil
"Vector of hline line numbers in the current table.
Line numbers are counted from the beginning of the table. This
variable is initialized with `org-table-analyze'.")
(defvar org-table-aligned-begin-marker (make-marker)
"Marker at the beginning of the table last aligned.
Used to check if cursor still is in that table, to minimize realignment.")
(defvar org-table-aligned-end-marker (make-marker)
"Marker at the end of the table last aligned.
Used to check if cursor still is in that table, to minimize realignment.")
(defvar org-table-last-alignment nil
"List of flags for flushright alignment, from the last re-alignment.
This is being used to correctly align a single field after TAB or RET.")
(defvar org-table-last-column-widths nil
"List of max width of fields in each column.
This is being used to correctly align a single field after TAB or RET.")
(defvar-local org-table-formula-debug nil
"Non-nil means debug table formulas.
When nil, simply write \"#ERROR\" in corrupted fields.")
(defvar-local org-table-overlay-coordinates nil
"Overlay coordinates after each align of a table.")
(defvar org-last-recalc-line nil)
(defvar org-show-positions nil)
(defvar org-table-rectangle-overlays nil)
(defvar org-table-clip nil
"Clipboard for table regions.")
(defvar org-timecnt nil)
(defvar org-recalc-commands nil
"List of commands triggering the recalculation of a line.
Will be filled automatically during use.")
(defvar org-recalc-marks
'((" " . "Unmarked: no special line, no automatic recalculation")
("#" . "Automatically recalculate this line upon TAB, RET, and C-c C-c in the line")
("*" . "Recalculate only when entire table is recalculated with `C-u C-c *'")
("!" . "Column name definition line. Reference in formula as $name.")
("$" . "Parameter definition line name=value. Reference in formula as $name.")
("_" . "Names for values in row below this one.")
("^" . "Names for values in row above this one.")))
(defvar org-pos nil)
;;; Macros and Inlined Functions
(defmacro org-table-with-shrunk-columns (&rest body)
"Expand all columns before executing BODY, then shrink them again."
(declare (debug (body)))
(org-with-gensyms (shrunk-columns begin end)
`(let ((,begin (copy-marker (org-table-begin)))
(,end (copy-marker (org-table-end) t))
(,shrunk-columns (org-table--list-shrunk-columns)))
(org-with-point-at ,begin (org-table-expand ,begin ,end))
(unwind-protect
(progn ,@body)
(org-table--shrink-columns ,shrunk-columns ,begin ,end)
(set-marker ,begin nil)
(set-marker ,end nil)))))
(defmacro org-table-with-shrunk-field (&rest body)
"Save field shrunk state, execute BODY and restore state."
(declare (debug (body)))
(org-with-gensyms (end shrunk size)
`(let* ((,shrunk (save-match-data (org-table--shrunk-field)))
(,end (and ,shrunk (copy-marker (overlay-end ,shrunk) t)))
(,size (and ,shrunk (- ,end (overlay-start ,shrunk)))))
(when ,shrunk (delete-overlay ,shrunk))
(unwind-protect (progn ,@body)
(when ,shrunk (move-overlay ,shrunk (- ,end ,size) ,end))))))
(defmacro org-table-save-field (&rest body)
"Save current field; execute BODY; restore field.
Field is restored even in case of abnormal exit."
(declare (debug (body)))
(org-with-gensyms (line column)
`(let ((,line (copy-marker (line-beginning-position)))
(,column (org-table-current-column)))
(unwind-protect
(progn ,@body)
(goto-char ,line)
(org-table-goto-column ,column)
(set-marker ,line nil)))))
;;; Predicates
(defun org-at-TBLFM-p (&optional pos)
"Non-nil when point (or POS) is in #+TBLFM line."
(save-excursion
(goto-char (or pos (point)))
(forward-line 0)
(and (let ((case-fold-search t)) (looking-at org-TBLFM-regexp))
(org-element-type-p (org-element-at-point) 'table))))
(defun org-at-table-p (&optional table-type)
"Non-nil if the cursor is inside an Org table.
If TABLE-TYPE is non-nil, also check for table.el-type tables."
(and (org-match-line (if table-type "[ \t]*[|+]" "[ \t]*|"))
(or (not (derived-mode-p 'org-mode))
(let ((e (org-element-lineage (org-element-at-point) 'table t)))
(and e (or table-type
(eq 'org (org-element-property :type e))))))))
(defun org-at-table.el-p ()
"Non-nil when point is at a table.el table."
(and (org-match-line "[ \t]*[|+]")
(let ((element (org-element-at-point)))
(and (org-element-type-p element 'table)
(eq (org-element-property :type element) 'table.el)))))
(defun org-at-table-hline-p ()
"Non-nil when point is inside a hline in a table.
Assume point is already in a table."
(org-match-line org-table-hline-regexp))
(defun org-table-check-inside-data-field (&optional noerror assume-table)
"Non-nil when point is inside a table data field.
Raise an error otherwise, unless NOERROR is non-nil. In that
case, return nil if point is not inside a data field. When
optional argument ASSUME-TABLE is non-nil, assume point is within
a table."
(cond ((and (or assume-table (org-at-table-p))
(not (save-excursion (skip-chars-backward " \t") (bolp)))
(not (org-at-table-hline-p))
(not (looking-at-p "[ \t]*$"))))
(noerror nil)
(t (user-error "Not in table data field"))))
;;; Create, Import, and Convert Tables
;;;###autoload
(defun org-table-create-with-table.el ()
"Use the table.el package to insert a new table.
If there is already a table at point, convert between Org tables
and table.el tables."
(interactive)
(require 'table)
(cond
((and (org-at-table.el-p)
(y-or-n-p "Convert table to Org table? "))
(org-table-convert))
((and (org-at-table-p)
(y-or-n-p "Convert table to table.el table? "))
(org-table-align)
(org-table-convert))
(t (call-interactively 'table-insert))))
;;;###autoload
(defun org-table-create-or-convert-from-region (arg)
"Convert region to table, or create an empty table.
If there is an active region, convert it to a table, using the function
`org-table-convert-region'. See the documentation of that function
to learn how the prefix argument is interpreted to determine the field
separator.
If there is no such region, create an empty table with `org-table-create'."
(interactive "P")
(if (org-region-active-p)
(org-table-convert-region (region-beginning) (region-end) arg)
(org-table-create arg)))
;;;###autoload
(defun org-table-create (&optional size)
"Query for a size and insert a table skeleton.
SIZE is a string Columns x Rows like for example \"3x2\"."
(interactive "P")
(unless size
(setq size (read-string
(concat "Table size Columns x Rows [e.g. "
org-table-default-size "]: ")
"" nil org-table-default-size)))
(let* ((pos (point))
(indent (make-string (current-column) ?\ ))
(split (org-split-string size " *x *"))
(rows (string-to-number (nth 1 split)))
(columns (string-to-number (car split)))
(line (concat (apply 'concat indent "|" (make-list columns " |"))
"\n")))
(if (string-match "^[ \t]*$" (buffer-substring-no-properties
(line-beginning-position) (point)))
(forward-line 0)
(newline))
;; (mapcar (lambda (x) (insert line)) (make-list rows t))
(dotimes (_ rows) (insert line))
(goto-char pos)
(when (> rows 1)
;; Insert a hline after the first row.
(end-of-line 1)
(insert "\n|-")
(goto-char pos))
(org-table-align)))
;;;###autoload
(defun org-table-convert-region (beg0 end0 &optional separator)
"Convert region to a table.
The region goes from BEG0 to END0, but these borders will be moved
slightly, to make sure a beginning of line in the first line is
included.
Throw an error when the region has more than
`org-table-convert-region-max-lines' lines.
SEPARATOR specifies the field separator in the lines. It can have the
following values:
(4) Use the comma as a field separator
(16) Use a TAB as field separator
(64) Prompt for a regular expression as field separator
integer When a number, use that many spaces, or a TAB, as field separator
regexp When a regular expression, use it to match the separator
nil When nil, the command tries to be smart and figure out the
separator in the following way:
- when each line contains a TAB, assume TAB-separated material
- when each line contains a comma, assume CSV material
- else, assume one or more SPACE characters as separator.
`babel-auto'
Use the same rules as nil, but do not try any separator when
the region contains a single line and has no commas or tabs."
(interactive "r\nP")
(let* ((beg (min beg0 end0))
(end (max beg0 end0))
re)
(when (> (count-lines beg end) org-table-convert-region-max-lines)
(user-error "Region is longer than `org-table-convert-region-max-lines' (%s) lines; not converting"
org-table-convert-region-max-lines))
(when (equal separator '(64))
(setq separator (read-regexp "Regexp for field separator")))
(goto-char beg)
(forward-line 0)
(setq beg (point-marker))
(goto-char end)
(if (bolp) (backward-char 1) (end-of-line 1))
(setq end (point-marker))
;; Get the right field separator
(when (or (not separator) (eq separator 'babel-auto))
(goto-char beg)
(setq separator
(cond
((not (save-excursion (re-search-forward "^[^\n\t]+$" end t))) '(16))
((not (save-excursion (re-search-forward "^[^\n,]+$" end t))) '(4))
((and (eq separator 'babel-auto)
(= 1 (count-lines beg end)))
(rx unmatchable))
(t 1))))
(goto-char beg)
(if (equal separator '(4))
(while (< (point) end)
;; parse the csv stuff
(cond
((looking-at "^") (insert "| "))
((looking-at "[ \t]*$") (replace-match " |") (forward-line 1))
((looking-at "[ \t]*\"\\([^\"\n]*\\)\"")
(replace-match "\\1")
(if (looking-at "\"") (insert "\"")))
((looking-at "[^,\n]+") (goto-char (match-end 0)))
((looking-at "[ \t]*,") (replace-match " | "))
(t (forward-line 1))))
(setq re (cond
((equal separator '(4)) "^\\|\"?[ \t]*,[ \t]*\"?")
((equal separator '(16)) "^\\|\t")
((integerp separator)
(if (< separator 1)
(user-error "Number of spaces in separator must be >= 1")
(format "^ *\\| *\t *\\| \\{%d,\\}" separator)))
((stringp separator)
(format "^ *\\|%s" separator))
(t (error "This should not happen"))))
(while (re-search-forward re end t)
(replace-match "| " t t)))
(goto-char beg)
(org-table-align)))
;;;###autoload
(defun org-table-import (file separator)
"Import FILE as a table.
The command tries to be smart and figure out the separator in the
following way:
- when each line contains a TAB, assume TAB-separated material;
- when each line contains a comma, assume CSV material;
- else, assume one or more SPACE characters as separator.
When non-nil, SEPARATOR specifies the field separator in the
lines. It can have the following values:
- (4) Use the comma as a field separator.
- (16) Use a TAB as field separator.
- (64) Prompt for a regular expression as field separator.
- integer When a number, use that many spaces, or a TAB, as field separator.
- regexp When a regular expression, use it to match the separator."
(interactive "f\nP")
(when (and (called-interactively-p 'any)
(not (string-match-p (rx "." (or "txt" "tsv" "csv") eos) file))
(not (yes-or-no-p "The file's extension is not .txt, .tsv or .csv. Import? ")))
(user-error "Cannot import such file"))
(unless (bolp) (insert "\n"))
(let ((beg (point))
(pm (point-max)))
(insert-file-contents file)
(org-table-convert-region beg (+ (point) (- (point-max) pm)) separator)))
(defun org-table-convert ()
"Convert from Org table to table.el and back.
Obviously, this only works within limits. When an Org table is converted
to table.el, all horizontal separator lines get lost, because table.el uses
these as cell boundaries and has no notion of horizontal lines. A table.el
table can be converted to an Org table only if it does not do row or column
spanning. Multiline cells will become multiple cells. Beware, Org mode
does not test if the table can be successfully converted - it blindly
applies a recipe that works for simple tables."
(interactive)
(require 'table)
(if (org-at-table.el-p)
;; convert to Org table
(let ((beg (copy-marker (org-table-begin t)))
(end (copy-marker (org-table-end t))))
(table-unrecognize-region beg end)
(goto-char beg)
(while (re-search-forward "^\\([ \t]*\\)\\+-.*\n" end t)
(replace-match ""))
(goto-char beg))
(if (org-at-table-p)
;; convert to table.el table
(let ((beg (copy-marker (org-table-begin)))
(end (copy-marker (org-table-end))))
;; first, get rid of all horizontal lines
(goto-char beg)
(while (re-search-forward "^\\([ \t]*\\)|-.*\n" end t)
(replace-match ""))
;; insert a hline before first
(goto-char beg)
(org-table-insert-hline 'above)
(forward-line -2)
;; insert a hline after each line
(while (progn (forward-line 2) (< (point) end))
(org-table-insert-hline))
(goto-char beg)
(setq end (move-marker end (org-table-end)))
;; replace "+" at beginning and ending of hlines
(while (re-search-forward "^\\([ \t]*\\)|-" end t)
(replace-match "\\1+-"))
(goto-char beg)
(while (re-search-forward "-|[ \t]*$" end t)
(replace-match "-+"))
(goto-char beg)))))
;;; Navigation and Structure Editing
;;;###autoload
(defun org-table-begin (&optional table-type)
"Find the beginning of the table and return its position.
With a non-nil optional argument TABLE-TYPE, return the beginning
of a table.el-type table. This function assumes point is on
a table."
(cond (table-type
(org-element-post-affiliated (org-element-at-point)))
((save-excursion
(and (re-search-backward org-table-border-regexp nil t)
(line-beginning-position 2))))
(t (point-min))))
;;;###autoload
(defun org-table-end (&optional table-type)
"Find the end of the table and return its position.
With a non-nil optional argument TABLE-TYPE, return the end of
a table.el-type table. This function assumes point is on
a table."
(save-excursion
(cond (table-type
(goto-char (org-element-end (org-element-at-point)))
(skip-chars-backward " \t\n")
(line-beginning-position 2))
((re-search-forward org-table-border-regexp nil t)
(match-beginning 0))
;; When the line right after the table is the last line in
;; the buffer with trailing spaces but no final newline
;; character, be sure to catch the correct ending at its
;; beginning. In any other case, ending is expected to be
;; at point max.
(t (goto-char (point-max))
(skip-chars-backward " \t")
(if (bolp) (point) (line-end-position))))))
;;;###autoload
(defun org-table-next-field ()
"Go to the next field in the current table, creating new lines as needed.
Before doing so, re-align the table if necessary."
(interactive)
(org-table-maybe-eval-formula)
(org-table-maybe-recalculate-line)
(when (and org-table-automatic-realign
org-table-may-need-update)
(org-table-align))
(let ((end (org-table-end)))
(if (org-at-table-hline-p)
(end-of-line 1))
(condition-case nil
(progn
(re-search-forward "|" end)
(if (looking-at "[ \t]*$")
(re-search-forward "|" end))
(if (and (looking-at "-")
org-table-tab-jumps-over-hlines
(re-search-forward "^[ \t]*|\\([^-]\\)" end t))
(goto-char (match-beginning 1)))
(if (looking-at "-")
(progn
(forward-line -1)
(org-table-insert-row 'below))
(if (looking-at " ") (forward-char 1))))
(error
(org-table-insert-row 'below)))))
;;;###autoload
(defun org-table-previous-field ()
"Go to the previous field in the table.
Before doing so, re-align the table if necessary."
(interactive)
(org-table-justify-field-maybe)
(org-table-maybe-recalculate-line)
(when (and org-table-automatic-realign
org-table-may-need-update)
(org-table-align))
(when (org-at-table-hline-p)
(end-of-line))
(let ((start (org-table-begin))
(origin (point)))
(condition-case nil
(progn
(search-backward "|" start nil 2)
(while (looking-at-p "|\\(?:-\\|[ \t]*$\\)")
(search-backward "|" start)))
(error
(goto-char origin)
(user-error "Cannot move to previous table field"))))
(when (looking-at "| ?")
(goto-char (match-end 0))))
(defun org-table-beginning-of-field (&optional n)
"Move to the beginning of the current table field.
If already at or before the beginning, move to the beginning of the
previous field.
With numeric argument N, move N-1 fields backward first."
(interactive "p")
(let ((pos (point)))
(while (> n 1)
(setq n (1- n))
(org-table-previous-field))
(if (not (re-search-backward "|" (line-beginning-position 0) t))
(user-error "No more table fields before the current")
(goto-char (match-end 0))
(and (looking-at " ") (forward-char 1)))
(when (>= (point) pos) (org-table-beginning-of-field 2))))
(defun org-table-end-of-field (&optional n)
"Move to the end of the current table field.
If already at or after the end, move to the end of the next table field.
With numeric argument N, move N-1 fields forward first."
(interactive "p")
(let ((pos (point)))
(while (> n 1)
(setq n (1- n))
(org-table-next-field))
(when (re-search-forward "|" (line-end-position 1) t)
(backward-char 1)
(skip-chars-backward " ")
(when (and (equal (char-before (point)) ?|) (equal (char-after (point)) ?\s))
(forward-char 1)))
(when (<= (point) pos) (org-table-end-of-field 2))))
;;;###autoload
(defun org-table-next-row ()
"Go to the next row (same column) in the current table.
When next row is an hline or outside the table, create a new empty
row. Before doing so, re-align the table if necessary."
(interactive)
(org-table-maybe-eval-formula)
(org-table-maybe-recalculate-line)
(if (and org-table-automatic-realign
org-table-may-need-update)
(org-table-align))
(let ((col (org-table-current-column)))
(forward-line 1)
(unless (bolp) (insert "\n")) ;missing newline at eob
(when (or (not (org-at-table-p))
(org-at-table-hline-p))
(forward-line -1)
(org-table-insert-row 'below))
(org-table-goto-column col)
(skip-chars-backward "^|\n\r")
(when (looking-at " ") (forward-char))))
(defun org-table-get (line column)
"Get the field in table line LINE, column COLUMN.
If LINE is larger than the number of data lines in the table, the function
returns nil. However, if COLUMN is too large, we will simply return an
empty string.
If LINE is nil, use the current line.
If COLUMN is nil, use the current column."
(setq column (or column (org-table-current-column)))
(save-excursion
(and (or (not line) (org-table-goto-line line))
(org-trim (org-table-get-field column)))))
(defun org-table-put (line column value &optional align)
"Put VALUE into line LINE, column COLUMN.
When ALIGN is set, also realign the table."
(setq column (or column (org-table-current-column)))
(prog1 (save-excursion
(and (or (not line) (org-table-goto-line line))
(progn (org-table-goto-column column nil 'force) t)
(org-table-get-field column value)))
(and align (org-table-align))))
(defun org-table-current-line ()
"Return the index of the current data line."
(let ((pos (point)) (end (org-table-end)) (cnt 0))
(save-excursion
(goto-char (org-table-begin))
(while (and (re-search-forward org-table-dataline-regexp end t)
(setq cnt (1+ cnt))
(< (line-end-position) pos))))
cnt))
(defun org-table-current-column ()
"Return current column number."
(interactive)
(save-excursion
(let ((pos (point)))
(forward-line 0)
(if (not (search-forward "|" pos t)) 0
(let ((column 1)
(separator (if (org-at-table-hline-p) "[+|]" "|")))
(while (re-search-forward separator pos t) (cl-incf column))
column)))))
(defun org-table-current-dline ()
"Find out what table data line we are in.
Only data lines count for this."
(save-excursion
(let ((c 0)
(pos (line-beginning-position)))
(goto-char (org-table-begin))
(while (<= (point) pos)
(when (looking-at org-table-dataline-regexp) (cl-incf c))
(forward-line))
c)))
(defun org-table-goto-line (N)
"Go to the Nth data line in the current table.
Return t when the line exists, nil if it does not exist."
(goto-char (org-table-begin))
(let ((end (org-table-end)) (cnt 0))
(while (and (re-search-forward org-table-dataline-regexp end t)
(< (setq cnt (1+ cnt)) N)))
(= cnt N)))
;;;###autoload
(defun org-table-blank-field ()
"Blank the current table field or active region."
(interactive)
(org-table-check-inside-data-field)
(if (and (called-interactively-p 'any) (org-region-active-p))
(let (org-table-clip)
(org-table-cut-region (region-beginning) (region-end)))
(skip-chars-backward "^|")
(backward-char 1)
(if (looking-at "|[^|\n]+")
(let* ((pos (match-beginning 0))
(match (match-string 0))
(len (save-match-data (org-string-width match nil 'org-table))))
(replace-match (concat "|" (make-string (1- len) ?\ )))
(goto-char (+ 2 pos))
(substring match 1)))))
(defun org-table-get-field (&optional n replace)
"Return the value of the field in column N of current row.
N defaults to current column. If REPLACE is a string, replace
field with this value. The return value is always the old
value."
(when n (org-table-goto-column n))
(skip-chars-backward "^|\n")
(if (or (bolp) (looking-at-p "[ \t]*$"))
;; Before first column or after last one.
""
(looking-at "[^|\r\n]*")
(let* ((pos (match-beginning 0))
(val (buffer-substring pos (match-end 0))))
(when replace
(org-table-with-shrunk-field
(replace-match (if (equal replace "") " " replace) t t)))
(goto-char (min (line-end-position) (1+ pos)))
val)))
;;;###autoload
(defun org-table-field-info (_arg)
"Show info about the current field, and highlight any reference at point."
(interactive "P")
(unless (org-at-table-p) (user-error "Not at a table"))
(org-table-analyze)
(save-excursion
(let* ((pos (point))
(col (org-table-current-column))
(cname (car (rassoc (number-to-string col) org-table-column-names)))
(name (car (rassoc (list (count-lines org-table-current-begin-pos
(line-beginning-position))
col)
org-table-named-field-locations)))
(eql (org-table-expand-lhs-ranges
(mapcar
(lambda (e)
(cons (org-table-formula-handle-first/last-rc (car e))
(cdr e)))
(org-table-get-stored-formulas))))
(dline (org-table-current-dline))
(ref (format "@%d$%d" dline col))
(ref1 (org-table-convert-refs-to-an ref))
;; Prioritize field formulas over column formulas.
(fequation (or (assoc name eql) (assoc ref eql)))
(cequation (assoc (format "$%d" col) eql))
(eqn (or fequation cequation)))
(let ((p (and eqn (get-text-property 0 :orig-eqn (car eqn)))))
(when p (setq eqn p)))
(goto-char pos)
(ignore-errors (org-table-show-reference 'local))
(message "line @%d, col $%s%s, ref @%d$%d or %s%s%s"
dline col
(if cname (concat " or $" cname) "")
dline col ref1
(if name (concat " or $" name) "")
;; FIXME: formula info not correct if special table line
(if eqn
(concat ", formula: "
(org-table-formula-to-user
(concat
(if (or (string-prefix-p "$" (car eqn))
(string-prefix-p "@" (car eqn)))
""
"$")
(car eqn) "=" (cdr eqn))))
"")))))
(defun org-table-goto-field (ref &optional create-column-p)
"Move point to a specific field in the current table.
REF is either the name of a field its absolute reference, as
a string. No column is created unless CREATE-COLUMN-P is
non-nil. If it is a function, it is called with the column
number as its argument as is used as a predicate to know if the
column can be created.
This function assumes the table is already analyzed (i.e., using
`org-table-analyze')."
(let* ((coordinates
(cond
((cdr (assoc ref org-table-named-field-locations)))
((string-match "\\`@\\([1-9][0-9]*\\)\\$\\([1-9][0-9]*\\)\\'" ref)
(list (condition-case nil
(aref org-table-dlines
(string-to-number (match-string 1 ref)))
(error (user-error "Invalid row number in %s" ref)))
(string-to-number (match-string 2 ref))))
(t (user-error "Unknown field: %s" ref))))
(line (car coordinates))
(column (nth 1 coordinates))
(create-new-column (if (functionp create-column-p)
(funcall create-column-p column)
create-column-p)))
(when coordinates
(goto-char org-table-current-begin-pos)
(forward-line line)
(org-table-goto-column column nil create-new-column))))
;;;###autoload
(defun org-table-goto-column (n &optional on-delim force)
"Move the cursor to the Nth column in the current table line.
With optional argument ON-DELIM, stop with point before the left delimiter
of the field.
If there are less than N fields, just go to after the last delimiter.
However, when FORCE is non-nil, create new columns if necessary."
(interactive "p")
(forward-line 0)
(when (> n 0)
(while (and (> (setq n (1- n)) -1)
(or (search-forward "|" (line-end-position) t)
(and force
(progn (end-of-line 1)
(skip-chars-backward "^|")
(insert " | ")
t)))))
(when (and force (not (looking-at ".*|")))
(save-excursion (end-of-line 1) (insert " | ")))
(if on-delim
(backward-char 1)
(if (looking-at " ") (forward-char 1)))))
;;;###autoload
(defun org-table-insert-column ()
"Insert a new column into the table."
(interactive)
(unless (org-at-table-p) (user-error "Not at a table"))
(when (eobp) (save-excursion (insert "\n")))
(unless (string-match-p "|[ \t]*$" (org-current-line-string))
(org-table-align))
(org-table-find-dataline)
(let ((col (max 1 (org-table-current-column)))
(beg (org-table-begin))
(end (copy-marker (org-table-end)))
(shrunk-columns (org-table--list-shrunk-columns)))
(org-table-expand beg end)
(save-excursion
(goto-char beg)
(while (< (point) end)
(unless (org-at-table-hline-p)
(org-table-goto-column col t)
(insert "|"))
(forward-line)))
(org-table-goto-column col)
(org-table-align)
;; Shift appropriately stored shrunk column numbers, then hide the
;; columns again.
(org-table--shrink-columns (mapcar (lambda (c) (if (< c col) c (1+ c)))
shrunk-columns)
beg end)
(set-marker end nil)
;; Fix TBLFM formulas, if desirable.
(when (or (not org-table-fix-formulas-confirm)
(funcall org-table-fix-formulas-confirm "Fix formulas? "))
(org-table-fix-formulas "$" nil (1- col) 1))))
(defun org-table-find-dataline ()
"Find a data line in the current table, which is needed for column commands.
This function assumes point is in a table. Raise an error when
there is no data row below."
(or (not (org-at-table-hline-p))
(let ((col (current-column))
(end (org-table-end)))
(forward-line)
(while (and (< (point) end) (org-at-table-hline-p))
(forward-line))
(when (>= (point) end)
(user-error "Cannot find data row for column operation"))
(org-move-to-column col)
t)))
(defun org-table-line-to-dline (line &optional above)
"Turn a buffer line number into a data line number.
If there is no data line in this line, return nil.
If there is no matching dline (most likely the reference was
a hline), the first dline below it is used. When ABOVE is
non-nil, the one above is used."
(let ((min 1)
(max (1- (length org-table-dlines))))
(cond ((or (> (aref org-table-dlines min) line)
(< (aref org-table-dlines max) line))
nil)
((= line (aref org-table-dlines max)) max)
(t (catch 'exit
(while (> (- max min) 1)
(let* ((mean (/ (+ max min) 2))
(v (aref org-table-dlines mean)))
(cond ((= v line) (throw 'exit mean))
((> v line) (setq max mean))
(t (setq min mean)))))
(cond ((= line (aref org-table-dlines max)) max)
((= line (aref org-table-dlines min)) min)
(above min)
(t max)))))))
(defun org-table--swap-cells (row1 col1 row2 col2)
"Swap two cells indicated by the coordinates provided.
ROW1, COL1, ROW2, COL2 are integers indicating the row/column
position of the two cells that will be swapped in the table."
(let ((content1 (org-table-get row1 col1))
(content2 (org-table-get row2 col2)))
(org-table-put row1 col1 content2)
(org-table-put row2 col2 content1)))
(defun org-table--move-cell (direction)
"Move the current cell in a cardinal direction.
DIRECTION is a symbol among `up', `down', `left', and `right'.
The contents the current cell are swapped with cell in the
indicated direction. Raise an error if the move cannot be done."
(let ((row-shift (pcase direction (`up -1) (`down 1) (_ 0)))
(column-shift (pcase direction (`left -1) (`right 1) (_ 0))))
(when (and (= 0 row-shift) (= 0 column-shift))
(error "Invalid direction: %S" direction))
;; Initialize `org-table-current-ncol' and `org-table-dlines'.
(org-table-analyze)
(let* ((row (org-table-current-line))
(column (org-table-current-column))
(target-row (+ row row-shift))
(target-column (+ column column-shift))
(org-table-current-nrow (1- (length org-table-dlines))))
(when (or (< target-column 1)
(< target-row 1)
(> target-column org-table-current-ncol)
(> target-row org-table-current-nrow))
(user-error "Cannot move cell further"))
(org-table--swap-cells row column target-row target-column)
(org-table-goto-line target-row)
(org-table-goto-column target-column))))
;;;###autoload
(defun org-table-move-cell-up ()
"Move a single cell up in a table.
Swap with anything in target cell."
(interactive)
(unless (org-table-check-inside-data-field)
(error "No table at point"))
(org-table--move-cell 'up)
(org-table-align))
;;;###autoload
(defun org-table-move-cell-down ()
"Move a single cell down in a table.
Swap with anything in target cell."
(interactive)
(unless (org-table-check-inside-data-field)
(error "No table at point"))
(org-table--move-cell 'down)
(org-table-align))
;;;###autoload
(defun org-table-move-cell-left ()
"Move a single cell left in a table.
Swap with anything in target cell."
(interactive)
(unless (org-table-check-inside-data-field)
(error "No table at point"))
(org-table--move-cell 'left)
(org-table-align))
;;;###autoload
(defun org-table-move-cell-right ()
"Move a single cell right in a table.
Swap with anything in target cell."
(interactive)
(unless (org-table-check-inside-data-field)
(error "No table at point"))
(org-table--move-cell 'right)
(org-table-align))
;;;###autoload
(defun org-table-delete-column ()
"Delete a column from the table."
(interactive)
(unless (org-at-table-p) (user-error "Not at a table"))
(org-table-find-dataline)
(when (save-excursion (skip-chars-forward " \t") (eolp))
(search-backward "|")) ;snap into last column
(org-table-check-inside-data-field nil t)
(let* ((col (org-table-current-column))
(beg (org-table-begin))
(end (copy-marker (org-table-end)))
(shrunk-columns (remq col (org-table--list-shrunk-columns))))
(org-table-expand beg end)
(org-table-save-field
(goto-char beg)
(while (< (point) end)
(if (org-at-table-hline-p)
nil
(org-table-goto-column col t)
(and (looking-at "|[^|\n]+|")
(replace-match "|")))
(forward-line)))
(org-table-align)
;; Shift appropriately stored shrunk column numbers, then hide the
;; columns again.
(org-table--shrink-columns (mapcar (lambda (c) (if (< c col) c (1- c)))
shrunk-columns)
beg end)
(set-marker end nil)
;; Fix TBLFM formulas, if desirable.
(when (or (not org-table-fix-formulas-confirm)
(funcall org-table-fix-formulas-confirm "Fix formulas? "))
(org-table-fix-formulas
"$" (list (cons (number-to-string col) "INVALID")) col -1 col))))
;;;###autoload
(defun org-table-move-column-right ()
"Move column to the right."
(interactive)
(org-table-move-column nil))
;;;###autoload
(defun org-table-move-column-left ()
"Move column to the left."
(interactive)
(org-table-move-column 'left))
;;;###autoload
(defun org-table-move-column (&optional left)
"Move the current column to the right. With arg LEFT, move to the left."
(interactive "P")
(unless (org-at-table-p) (user-error "Not at a table"))
(org-table-find-dataline)
(org-table-check-inside-data-field nil t)
(let* ((col (org-table-current-column))
(col1 (if left (1- col) col))
(colpos (if left (1- col) (1+ col)))
(beg (org-table-begin))
(end (copy-marker (org-table-end))))
(when (and left (= col 1))
(user-error "Cannot move column further left"))
(when (and (not left) (looking-at "[^|\n]*|[^|\n]*$"))
(user-error "Cannot move column further right"))
(let ((shrunk-columns (org-table--list-shrunk-columns)))
(org-table-expand beg end)
(org-table-save-field
(goto-char beg)
(while (< (point) end)
(unless (org-at-table-hline-p)
(org-table-goto-column col1 t)
(when (looking-at "|\\([^|\n]+\\)|\\([^|\n]+\\)|")
(transpose-regions
(match-beginning 1) (match-end 1)
(match-beginning 2) (match-end 2))))
(forward-line)))
(org-table-goto-column colpos)
(org-table-align)
;; Shift appropriately stored shrunk column numbers, then shrink
;; the columns again.
(org-table--shrink-columns
(mapcar (lambda (c)
(cond ((and (= col c) left) (1- c))
((= col c) (1+ c))
((and (= col (1+ c)) left) (1+ c))
((and (= col (1- c)) (not left) (1- c)))
(t c)))
shrunk-columns)
beg end)
(set-marker end nil)
;; Fix TBLFM formulas, if desirable.
(when (or (not org-table-fix-formulas-confirm)
(funcall org-table-fix-formulas-confirm "Fix formulas? "))
(org-table-fix-formulas
"$" (list (cons (number-to-string col) (number-to-string colpos))
(cons (number-to-string colpos) (number-to-string col))))))))
;;;###autoload
(defun org-table-move-row-down ()
"Move table row down."
(interactive)
(org-table-move-row nil))
;;;###autoload
(defun org-table-move-row-up ()
"Move table row up."
(interactive)
(org-table-move-row 'up))
;;;###autoload
(defun org-table-move-row (&optional up)
"Move the current table line down. With arg UP, move it up."
(interactive "P")
(let* ((col (current-column))
(pos (point))
(hline1p (save-excursion (forward-line 0)
(looking-at org-table-hline-regexp)))
(dline1 (org-table-current-dline))
(dline2 (+ dline1 (if up -1 1)))
(tonew (if up -1 1))
hline2p)
(when (and up (= (point-min) (line-beginning-position)))
(user-error "Cannot move row further"))
(forward-line tonew)
(when (or (and (not up) (eobp)) (not (org-at-table-p)))
(goto-char pos)
(user-error "Cannot move row further"))
(org-table-with-shrunk-columns
(setq hline2p (looking-at org-table-hline-regexp))
(goto-char pos)
(let ((row (delete-and-extract-region (line-beginning-position)
(line-beginning-position 2))))
(forward-line tonew)
(unless (bolp) (insert "\n")) ;at eob without a newline
(insert row)
(unless (bolp) (insert "\n")) ;missing final newline in ROW
(forward-line -1)
(org-move-to-column col)
(unless (or hline1p hline2p
(not (or (not org-table-fix-formulas-confirm)
(funcall org-table-fix-formulas-confirm
"Fix formulas? "))))
(org-table-fix-formulas
"@" (list
(cons (number-to-string dline1) (number-to-string dline2))
(cons (number-to-string dline2) (number-to-string dline1)))))))))
;;;###autoload
(defun org-table-insert-row (&optional arg)
"Insert a new row above the current line into the table.
With prefix ARG, insert below the current line."
(interactive "P")
(unless (org-at-table-p) (user-error "Not at a table"))
(when (eobp) (save-excursion (insert "\n")))
(unless (string-match-p "|[ \t]*$" (org-current-line-string))
(org-table-align))
(org-table-with-shrunk-columns
(let* ((line (buffer-substring (line-beginning-position) (line-end-position)))
(new (org-table-clean-line line)))
;; Fix the first field if necessary
(when (string-match "^[ \t]*| *[#*$] *|" line)
(setq new (replace-match (match-string 0 line) t t new)))
(forward-line (if arg 1 0))
;; Buffer may not end of a newline character, so ensure
;; (forward-line 1) moves point to a new line.
(unless (bolp) (insert "\n"))
(let (org-table-may-need-update) (insert-before-markers new "\n"))
(forward-line -1)
(re-search-forward "| ?" (line-end-position) t)
(when (or org-table-may-need-update org-table-overlay-coordinates)
(org-table-align))
(when (or (not org-table-fix-formulas-confirm)
(funcall org-table-fix-formulas-confirm "Fix formulas? "))
(org-table-fix-formulas "@" nil (1- (org-table-current-dline)) 1)))))
;;;###autoload
(defun org-table-insert-hline (&optional above)
"Insert a horizontal-line below the current line into the table.
With prefix ABOVE, insert above the current line."
(interactive "P")
(unless (org-at-table-p) (user-error "Not at a table"))
(when (eobp) (save-excursion (insert "\n")))
(unless (string-match-p "|[ \t]*$" (org-current-line-string))
(org-table-align))
(org-table-with-shrunk-columns
(let ((line (org-table-clean-line
(buffer-substring (line-beginning-position) (line-end-position))))
(col (current-column)))
(while (string-match "|\\( +\\)|" line)
(setq line (replace-match
(concat "+" (make-string (- (match-end 1) (match-beginning 1))
?-) "|") t t line)))
(and (string-match "\\+" line) (setq line (replace-match "|" t t line)))
(forward-line (if above 0 1))
(insert line "\n")
(forward-line (if above 0 -2))
(org-move-to-column col)
(when org-table-overlay-coordinates (org-table-align)))))
;;;###autoload
(defun org-table-hline-and-move (&optional same-column)
"Insert a hline and move to the row below that line."
(interactive "P")
(let ((col (org-table-current-column)))
(org-table-maybe-eval-formula)
(org-table-maybe-recalculate-line)
(org-table-insert-hline)
(end-of-line 2)
(if (looking-at "\n[ \t]*|-")
(progn (insert "\n|") (org-table-align))
(org-table-next-field))
(if same-column (org-table-goto-column col))))
(defun org-table-clean-line (s)
"Convert a table line S into a string with only \"|\" and space.
In particular, this does handle wide and invisible characters."
(if (string-match "^[ \t]*|-" s)
;; It's a hline, just map the characters
(setq s (mapconcat (lambda (x) (if (member x '(?| ?+)) "|" " ")) s ""))
(while (string-match "|\\([ \t]*?[^ \t\r\n|][^\r\n|]*\\)|" s)
(setq s (replace-match
(concat "|"
(make-string
(save-match-data
(org-string-width (match-string 1 s) nil 'org-table))
?\ )
"|")
t t s)))
s))
;;;###autoload
(defun org-table-kill-row ()
"Delete the current row or horizontal line from the table."
(interactive)
(unless (org-at-table-p) (user-error "Not at a table"))
(let ((col (current-column))
(dline (and (not (org-match-line org-table-hline-regexp))
(org-table-current-dline))))
(org-table-with-shrunk-columns
(kill-region (line-beginning-position)
(min (1+ (line-end-position)) (point-max)))
(if (not (org-at-table-p)) (forward-line -1))
(org-move-to-column col)
(when (and dline
(or (not org-table-fix-formulas-confirm)
(funcall org-table-fix-formulas-confirm "Fix formulas? ")))
(org-table-fix-formulas
"@" (list (cons (number-to-string dline) "INVALID")) dline -1 dline)))))
;;;###autoload
(defun org-table-cut-region (beg end)
"Copy region in table to the clipboard and blank all relevant fields.
If there is no active region, use just the field at point."
(interactive (list
(if (org-region-active-p) (region-beginning) (point))
(if (org-region-active-p) (region-end) (point))))
(org-table-copy-region beg end 'cut))
(defun org-table--increment-field (field previous)
"Increment string FIELD according to PREVIOUS field.
Increment FIELD only if it is a string representing a number, per
Emacs Lisp syntax, a timestamp, or is either prefixed or suffixed
with a number. In any other case, return FIELD as-is.
If PREVIOUS has the same structure as FIELD, e.g.,
a number-prefixed string with the same pattern, the increment
step is the difference between numbers (or timestamps, measured
in days) in PREVIOUS and FIELD. Otherwise, it uses
`org-table-copy-increment', if the variable contains a number, or
default to 1.
The function assumes `org-table-copy-increment' is non-nil."
(let* ((default-step (if (numberp org-table-copy-increment)
org-table-copy-increment
1))
(number-regexp ;Lisp read syntax for numbers
(rx (and string-start
(opt (any "+-"))
(or (and (one-or-more digit) (opt "."))
(and (zero-or-more digit) "." (one-or-more digit)))
(opt (any "eE") (opt (opt (any "+-")) (one-or-more digit)))
string-end)))
(number-prefix-regexp (rx (and string-start (one-or-more digit))))
(number-suffix-regexp (rx (and (one-or-more digit) string-end)))
(analyze
(lambda (field)
;; Analyze string FIELD and return information related to
;; increment or nil. When non-nil, return value has the
;; following scheme: (TYPE VALUE PATTERN) where
;; - TYPE is a symbol among `number', `prefix', `suffix'
;; and `timestamp',
;; - VALUE is a timestamp if TYPE is `timestamp', or
;; a number otherwise,
;; - PATTERN is the field without its prefix, or suffix if
;; TYPE is either `prefix' or `suffix' , or nil
;; otherwise.
(cond ((not (org-string-nw-p field)) nil)
((string-match-p number-regexp field)
(list 'number
(string-to-number field)
nil))
((string-match number-prefix-regexp field)
(list 'prefix
(string-to-number (match-string 0 field))
(substring field (match-end 0))))
((string-match number-suffix-regexp field)
(list 'suffix
(string-to-number (match-string 0 field))
(substring field 0 (match-beginning 0))))
((string-match-p org-ts-regexp3 field)
(list 'timestamp field nil))
(t nil))))
(next-number-string
(lambda (n1 &optional n2)
;; Increment number N1 and return it as a string. If N2
;; is also a number, deduce increment step from the
;; difference between N1 and N2. Otherwise, increment
;; step is `default-step'.
(number-to-string (if n2 (+ n1 (- n1 n2)) (+ n1 default-step)))))
(shift-timestamp
(lambda (t1 &optional t2)
;; Increment timestamp T1 and return it. If T2 is also
;; a timestamp, deduce increment step from the difference,
;; in days, between T1 and T2. Otherwise, increment by
;; `default-step' days.
(with-temp-buffer
(insert t1)
(org-timestamp-up-day (if (not t2) default-step
(- (org-time-string-to-absolute t1)
(org-time-string-to-absolute t2))))
(buffer-string)))))
;; Check if both PREVIOUS and FIELD have the same type. Also, if
;; the case of prefixed or suffixed numbers, make sure their
;; pattern, i.e., the part of the string without the prefix or the
;; suffix, is the same.
(pcase (cons (funcall analyze field) (funcall analyze previous))
(`((number ,n1 ,_) . (number ,n2 ,_))
(funcall next-number-string n1 n2))
(`((number ,n ,_) . ,_)
(funcall next-number-string n))
(`((prefix ,n1 ,p1) . (prefix ,n2 ,p2))
(concat (funcall next-number-string n1 (and (equal p1 p2) n2)) p1))
(`((prefix ,n ,p) . ,_)
(concat (funcall next-number-string n) p))
(`((suffix ,n1 ,p1) . (suffix ,n2 ,p2))
(concat p1 (funcall next-number-string n1 (and (equal p1 p2) n2))))
(`((suffix ,n ,p) . ,_)
(concat p (funcall next-number-string n)))
(`((timestamp ,t1 ,_) . (timestamp ,t2 ,_))
(funcall shift-timestamp t1 t2))
(`((timestamp ,t1 ,_) . ,_)
(funcall shift-timestamp t1))
(_ field))))
;;;###autoload
(defun org-table-copy-down (n)
"Copy the value of the current field one row below.
If the field at the cursor is empty, copy the content of the
nearest non-empty field above. With argument N, use the Nth
non-empty field.
If the current field is not empty, it is copied down to the next
row, and the cursor is moved with it. Therefore, repeating this
command causes the column to be filled row-by-row.
If the variable `org-table-copy-increment' is non-nil and the
field is a number, a timestamp, or is either prefixed or suffixed
with a number, it will be incremented while copying. By default,
increment by the difference between the value in the current
field and the one in the field above, if any. To increment using
a fixed integer, set `org-table-copy-increment' to a number. In
the case of a timestamp, increment by days.
However, when N is 0, do not increment the field at all."
(interactive "p")
(org-table-check-inside-data-field)
(let* ((beg (org-table-begin))
(column (org-table-current-column))
(initial-field (save-excursion
(let ((f (org-string-nw-p (org-table-get-field))))
(and f (org-trim f)))))
field field-above next-field)
(save-excursion
;; Get reference field.
(if initial-field (setq field initial-field)
(forward-line 0)
(setq field
(catch :exit
(while (re-search-backward org-table-dataline-regexp beg t)
(let ((f (org-string-nw-p (org-table-get-field column))))
(cond ((and (> n 1) f) (cl-decf n))
(f (throw :exit (org-trim f)))
(t nil))
(forward-line 0)))
(user-error "No non-empty field found"))))
;; Check if increment is appropriate, and how it should be done.
(when (and org-table-copy-increment (/= n 0))
;; If increment step is not explicit, get non-empty field just
;; above the field being incremented to guess it.
(unless (numberp org-table-copy-increment)
(setq field-above
(let ((f (unless (= beg (line-beginning-position))
(forward-line -1)
(not (org-at-table-hline-p))
(org-table-get-field column))))
(and (org-string-nw-p f)
(org-trim f)))))
;; Compute next field.
(setq next-field (org-table--increment-field field field-above))))
;; Since initial field in not empty, we modify row below instead.
;; Skip alignment since we do it at the end of the process anyway.
(when initial-field
(let ((org-table-may-need-update nil)) (org-table-next-row))
(org-table-blank-field))
;; Insert the new field. NEW-FIELD may be nil if
;; `org-table-copy-increment' is nil, or N = 0. In that case,
;; copy FIELD.
(insert (or next-field field))
(org-table-maybe-recalculate-line)
(org-table-align)))
;;;###autoload
(defun org-table-copy-region (beg end &optional cut)
"Copy rectangular region in table to clipboard.
A special clipboard is used which can only be accessed with
`org-table-paste-rectangle'. Return the region copied, as a list
of lists of fields."
(interactive (list
(if (org-region-active-p) (region-beginning) (point))
(if (org-region-active-p) (region-end) (point))
current-prefix-arg))
(goto-char (min beg end))
(org-table-check-inside-data-field)
(let ((beg (line-beginning-position))
(c01 (org-table-current-column))
region)
(goto-char (max beg end))
(org-table-check-inside-data-field nil t)
(let* ((end (copy-marker (line-end-position)))
(c02 (org-table-current-column))
(column-start (min c01 c02))
(column-end (max c01 c02))
(column-number (1+ (- column-end column-start)))
(rpl (and cut " ")))
(goto-char beg)
(while (< (point) end)
(unless (org-at-table-hline-p)
;; Collect every cell between COLUMN-START and COLUMN-END.
(let (cols)
(dotimes (c column-number)
(push (org-table-get-field (+ c column-start) rpl) cols))
(push (nreverse cols) region)))
(forward-line))
(set-marker end nil))
(when cut (org-table-align))
(when (called-interactively-p 'any)
(message (substitute-command-keys "Cells in the region copied, use \
\\[org-table-paste-rectangle] to paste them in a table.")))
(setq org-table-clip (nreverse region))))
;;;###autoload
(defun org-table-paste-rectangle ()
"Paste a rectangular region into a table.
The upper right corner ends up in the current field. All involved fields
will be overwritten. If the rectangle does not fit into the present table,
the table is enlarged as needed. The process ignores horizontal separator
lines."
(interactive)
(unless (consp org-table-clip)
(user-error "First cut/copy a region to paste!"))
(org-table-check-inside-data-field)
(let* ((column (org-table-current-column))
(org-table-automatic-realign nil))
(org-table-save-field
(dolist (row org-table-clip)
(while (org-at-table-hline-p) (forward-line))
;; If we left the table, create a new row.
(when (and (bolp) (not (looking-at "[ \t]*|")))
(end-of-line 0)
(org-table-next-field))
(let ((c column))
(dolist (field row)
(org-table-goto-column c nil 'force)
(org-table-get-field nil field)
(cl-incf c)))
(forward-line)))
(org-table-align)))
;;; Follow Field minor mode
(define-minor-mode org-table-follow-field-mode
"Minor mode to make the table field editor window follow the cursor.
When this mode is active, the field editor window will always show the
current field. The mode exits automatically when the cursor leaves the
table (but see `org-table-exit-follow-field-mode-when-leaving-table')."
:lighter " TblFollow"
(if org-table-follow-field-mode
(add-hook 'post-command-hook 'org-table-follow-fields-with-editor
'append 'local)
(remove-hook 'post-command-hook 'org-table-follow-fields-with-editor 'local)
(let* ((buf (get-buffer "*Org Table Edit Field*"))
(win (and buf (get-buffer-window buf))))
(when win (delete-window win))
(when buf
(with-current-buffer buf
(move-marker org-field-marker nil))
(kill-buffer buf)))))
;;;###autoload
(defun org-table-edit-field (arg)
"Edit table field in a different window.
This is mainly useful for fields that contain hidden parts.
When called with a `\\[universal-argument]' prefix, just make the full field
visible so that it can be edited in place.
When called with a `\\[universal-argument] \\[universal-argument]' prefix, \
toggle `org-table-follow-field-mode'."
(interactive "P")
(unless (org-at-table-p) (user-error "Not at a table"))
(cond
((equal arg '(16))
(org-table-follow-field-mode (if org-table-follow-field-mode -1 1)))
(arg
(let ((b (save-excursion (skip-chars-backward "^|") (point)))
(e (save-excursion (skip-chars-forward "^|\r\n") (point))))
(remove-text-properties b e '(invisible t intangible t))
(if font-lock-mode
(font-lock-fontify-block))))
(t
(let ((pos (point-marker))
(coord
(if (eq org-table-use-standard-references t)
(concat (org-number-to-letters (org-table-current-column))
(number-to-string (org-table-current-dline)))
(concat "@" (number-to-string (org-table-current-dline))
"$" (number-to-string (org-table-current-column)))))
(field (org-table-get-field))
(cw (current-window-configuration))
p)
(goto-char pos)
(switch-to-buffer-other-window "*Org Table Edit Field*")
(when (and (local-variable-p 'org-field-marker)
(markerp org-field-marker))
(move-marker org-field-marker nil))
(erase-buffer)
(insert "#\n# Edit field " coord " and finish with C-c C-c\n#\n")
(let ((org-inhibit-startup t)) (org-mode))
(auto-fill-mode -1)
(setq truncate-lines nil)
(setq word-wrap t)
(goto-char (setq p (point-max)))
(insert (org-trim field))
(remove-text-properties p (point-max) '(invisible t intangible t))
(goto-char p)
(setq-local org-finish-function 'org-table-finish-edit-field)
(setq-local org-window-configuration cw)
(setq-local org-field-marker pos)
(message "Edit and finish with C-c C-c")))))
(defun org-table-follow-fields-with-editor ()
(if (and org-table-exit-follow-field-mode-when-leaving-table
(not (org-at-table-p)))
;; We have left the table, exit the follow mode
(org-table-follow-field-mode -1)
(when (org-table-check-inside-data-field 'noerror)
(let ((win (selected-window)))
(org-table-edit-field nil)
(org-fit-window-to-buffer)
(select-window win)))))
(defun org-table-finish-edit-field ()
"Finish editing a table data field.
Remove all newline characters, insert the result into the table, realign
the table and kill the editing buffer."
(let ((pos org-field-marker)
(cw org-window-configuration)
(cb (current-buffer))
text)
(goto-char (point-min))
(while (re-search-forward "^#.*\n?" nil t) (replace-match ""))
(while (re-search-forward "[ \t]*\n[ \t\n]*" nil t)
(replace-match " "))
(setq text (org-trim (buffer-string)))
(set-window-configuration cw)
(kill-buffer cb)
(select-window (get-buffer-window (marker-buffer pos)))
(goto-char pos)
(move-marker pos nil)
(org-table-check-inside-data-field)
(org-table-get-field nil text)
(org-table-align)
(message "New field value inserted")))
;;; Formulas
(defun org-table-current-field-formula (&optional key noerror)
"Return the formula active for the current field.
Assumes that table is already analyzed. If KEY is given, return
the key to this formula. Otherwise return the formula preceded
with \"=\" or \":=\"."
(let* ((line (count-lines org-table-current-begin-pos
(line-beginning-position)))
(row (org-table-line-to-dline line)))
(cond
(row
(let* ((col (org-table-current-column))
(name (car (rassoc (list line col)
org-table-named-field-locations)))
(scol (format "$%d" col))
(ref (format "@%d$%d" (org-table-current-dline) col))
(stored-list (org-table-get-stored-formulas noerror))
(ass (or (assoc name stored-list)
(assoc ref stored-list)
(assoc scol stored-list))))
(cond (key (car ass))
(ass (concat (if (string-match-p "^[0-9]+$" (car ass)) "=" ":=")
(cdr ass))))))
(noerror nil)
(t (error "No formula active for the current field")))))
(defun org-table-get-formula (&optional equation named)
"Read a formula from the minibuffer, offer stored formula as default.
When NAMED is non-nil, look for a named equation."
(let* ((stored-list (org-table-get-stored-formulas))
(name (car (rassoc (list (count-lines org-table-current-begin-pos
(line-beginning-position))
(org-table-current-column))
org-table-named-field-locations)))
(ref (format "@%d$%d"
(org-table-current-dline)
(org-table-current-column)))
(scol (cond
((not named) (format "$%d" (org-table-current-column)))
(name)
(t ref)))
(name (or name ref))
(org-table-may-need-update nil)
(stored (cdr (assoc scol stored-list)))
(eq (cond
((and stored equation (string-match-p "^ *=? *$" equation))
stored)
((stringp equation) equation)
(t
(org-table-formula-from-user
(read-string
(org-table-formula-to-user
(format "%s formula %s=" (if named "Field" "Column") scol))
(if stored (org-table-formula-to-user stored) "")
'org-table-formula-history)))))
mustsave)
(unless (org-string-nw-p eq)
;; Remove formula.
(setq stored-list (delq (assoc scol stored-list) stored-list))
(org-table-store-formulas stored-list)
(user-error "Formula removed"))
(when (string-match "^ *=?" eq) (setq eq (replace-match "" t t eq)))
(when (string-match " *$" eq) (setq eq (replace-match "" t t eq)))
(when (and name (not named))
;; We set the column equation, delete the named one.
(setq stored-list (delq (assoc name stored-list) stored-list)
mustsave t))
(if stored
(setcdr (assoc scol stored-list) eq)
(setq stored-list (cons (cons scol eq) stored-list)))
(when (or mustsave (not (equal stored eq)))
(org-table-store-formulas stored-list))
eq))
(defun org-table-store-formulas (alist &optional location)
"Store the list of formulas below the current table.
If optional argument LOCATION is a buffer position, insert it at
LOCATION instead."
(save-excursion
(if location
(progn (goto-char location) (forward-line 0))
(goto-char (org-table-end)))
(let ((case-fold-search t))
(if (looking-at "\\([ \t]*\n\\)*[ \t]*\\(#\\+TBLFM:\\)\\(.*\n?\\)")
(progn
;; Don't overwrite TBLFM, we might use text properties to
;; store stuff.
(goto-char (match-beginning 3))
(delete-region (match-beginning 3) (match-end 0)))
(org-indent-line)
(insert "#+TBLFM:"))
(insert " "
(mapconcat (lambda (x) (concat (car x) "=" (cdr x)))
(sort alist #'org-table-formula-less-p)
"::")
"\n"))))
(defsubst org-table-formula-make-cmp-string (a)
(when (string-match "\\`\\$[<>]" a)
(let ((arrow (string-to-char (substring a 1))))
;; Fake a high number to make sure this is sorted at the end.
(setq a (org-table-formula-handle-first/last-rc a))
(setq a (format "$%d" (+ 10000
(if (= arrow ?<) -1000 0)
(string-to-number (substring a 1)))))))
(when (string-match
"^\\(@\\([0-9]+\\)\\)?\\(\\$?\\([0-9]+\\)\\)?\\(\\$?[a-zA-Z0-9]+\\)?"
a)
(concat
(if (match-end 2)
(format "@%05d" (string-to-number (match-string 2 a))) "")
(if (match-end 4)
(format "$%05d" (string-to-number (match-string 4 a))) "")
(if (match-end 5)
(concat "@@" (match-string 5 a))))))
(defun org-table-formula-less-p (a b)
"Compare two formulas for sorting."
(let ((as (org-table-formula-make-cmp-string (car a)))
(bs (org-table-formula-make-cmp-string (car b))))
(and as bs (string< as bs))))
;;;###autoload
(defun org-table-get-stored-formulas (&optional noerror location)
"Return an alist with the stored formulas directly after current table.
By default, only return active formulas, i.e., formulas located
on the first line after the table. However, if optional argument
LOCATION is a buffer position, consider the formulas there."
(save-excursion
(if location
(progn (goto-char location) (forward-line 0))
(goto-char (org-table-end)))
(let ((case-fold-search t))
(when (looking-at "\\([ \t]*\n\\)*[ \t]*#\\+TBLFM: *\\(.*\\)")
(let ((strings (org-split-string (match-string-no-properties 2)
" *:: *"))
eq-alist seen)
(dolist (string strings (nreverse eq-alist))
(when (string-match "\\`\\(@[-+I<>0-9.$@]+\\|\\$\\([_a-zA-Z0-9]+\\|\
\[<>]+\\)\\) *= *\\(.*[^ \t]\\)"
string)
(let ((lhs
(let ((m (match-string 1 string)))
(cond
((not (match-end 2)) m)
;; Is it a column reference?
((string-match-p "\\`\\$\\([0-9]+\\|[<>]+\\)\\'" m) m)
;; Since named columns are not possible in
;; LHS, assume this is a named field.
(t (match-string 2 string)))))
(rhs (match-string 3 string)))
(push (cons lhs rhs) eq-alist)
(cond
((not (member lhs seen)) (push lhs seen))
(noerror
(message
"Double definition `%s=' in TBLFM line, please fix by hand"
lhs)
(ding)
(sit-for 2))
(t
(user-error
"Double definition `%s=' in TBLFM line, please fix by hand"
lhs)))))))))))
(defun org-table-fix-formulas (key replace &optional limit delta remove)
"Modify the equations after the table structure has been edited.
KEY is \"@\" or \"$\". REPLACE is an alist of numbers to replace.
For all numbers larger than LIMIT, shift them by DELTA."
(save-excursion
(goto-char (org-table-end))
(while (let ((case-fold-search t)) (looking-at "[ \t]*#\\+tblfm:"))
(let ((re (concat key "\\([0-9]+\\)"))
(re2
(when remove
(if (equal key "$")
(format "\\(@[0-9]+\\)?%s%d=.*?\\(::\\|$\\)"
(regexp-quote key) remove)
(format "@%d\\$[0-9]+=.*?\\(::\\|$\\)" remove))))
s n a)
(when remove
(save-excursion
(while (re-search-forward re2 (line-end-position) t)
(unless (save-match-data (org-in-regexp "remote([^)]+?)"))
(if (equal (char-before (match-beginning 0)) ?.)
(user-error
"Change makes TBLFM term %s invalid, use undo to recover"
(match-string 0))
(replace-match ""))))))
(while (re-search-forward re (line-end-position) t)
(unless (save-match-data (org-in-regexp "remote([^)]+?)"))
(setq s (match-string 1) n (string-to-number s))
(cond
((setq a (assoc s replace))
(replace-match (concat key (cdr a)) t t))
((and limit (> n limit))
(replace-match (concat key (number-to-string (+ n delta))) t t)))))
(message "The formulas in #+TBLFM have been updated"))
(forward-line))))
;;;###autoload
(defun org-table-maybe-eval-formula ()
"Check if the current field starts with \"=\" or \":=\".
If yes, store the formula and apply it."
;; We already know we are in a table. Get field will only return a formula
;; when appropriate. It might return a separator line, but no problem.
(when org-table-formula-evaluate-inline
(let* ((field (org-trim (or (org-table-get-field) "")))
named eq)
(when (string-match "^:?=\\(.*[^=]\\)$" field)
(setq named (equal (string-to-char field) ?:)
eq (match-string 1 field))
(org-table-eval-formula (and named '(4))
(org-table-formula-from-user eq))))))
;;;###autoload
(defun org-table-rotate-recalc-marks (&optional newchar)
"Rotate the recalculation mark in the first column.
If in any row, the first field is not consistent with a mark,
insert a new column for the markers.
When there is an active region, change all the lines in the region,
after prompting for the marking character.
After each change, a message will be displayed indicating the meaning
of the new mark."
(interactive)
(unless (org-at-table-p) (user-error "Not at a table"))
(let* ((region (org-region-active-p))
(l1 (and region
(save-excursion (goto-char (region-beginning))
(copy-marker (line-beginning-position)))))
(l2 (and region
(save-excursion (goto-char (region-end))
(copy-marker (line-beginning-position)))))
(l (copy-marker (line-beginning-position)))
(col (org-table-current-column))
(newchar (if region
(char-to-string
(read-char-exclusive
"Change region to what mark? Type # * ! $ or SPC: "))
newchar))
(no-special-column
(save-excursion
(goto-char (org-table-begin))
(re-search-forward
"^[ \t]*|[^-|][^|]*[^#!$*_^| \t][^|]*|" (org-table-end) t))))
(when (and newchar (not (assoc newchar org-recalc-marks)))
(user-error "Invalid character `%s' in `org-table-rotate-recalc-marks'"
newchar))
(when l1 (goto-char l1))
(save-excursion
(forward-line 0)
(unless (looking-at org-table-dataline-regexp)
(user-error "Not at a table data line")))
(when no-special-column
(org-table-goto-column 1)
(org-table-insert-column))
(let ((previous-line-end (line-end-position))
(newchar
(save-excursion
(forward-line 0)
(cond ((not (looking-at "^[ \t]*| *\\([#!$*^_ ]\\) *|")) "#")
(newchar)
(t (cadr (member (match-string 1)
(append (mapcar #'car org-recalc-marks)
'(" ")))))))))
;; Rotate mark in first row.
(org-table-get-field 1 (format " %s " newchar))
;; Rotate marks in additional rows if a region is active.
(when region
(save-excursion
(forward-line)
(while (<= (point) l2)
(when (looking-at org-table-dataline-regexp)
(org-table-get-field 1 (format " %s " newchar)))
(forward-line))))
;; Only align if rotation actually changed lines' length.
(when (/= previous-line-end (line-end-position)) (org-table-align)))
(goto-char l)
(org-table-goto-column (if no-special-column (1+ col) col))
(when l1 (set-marker l1 nil))
(when l2 (set-marker l2 nil))
(set-marker l nil)
(when (called-interactively-p 'interactive)
(message "%s" (cdr (assoc newchar org-recalc-marks))))))
;;;###autoload
(defun org-table-maybe-recalculate-line ()
"Recompute the current line if marked for it, and if we haven't just done it."
(interactive)
(and org-table-allow-automatic-line-recalculation
(not (and (memq last-command org-recalc-commands)
(eq org-last-recalc-line (line-beginning-position))))
(save-excursion (forward-line 0)
(looking-at org-table-auto-recalculate-regexp))
(org-table-recalculate) t))
;;;###autoload
(defun org-table-eval-formula (&optional arg equation
suppress-align suppress-const
suppress-store suppress-analysis)
"Replace the table field value at the cursor by the result of a calculation.
In a table, this command replaces the value in the current field with the
result of a formula. It also installs the formula as the \"current\" column
formula, by storing it in a special line below the table. When called
with a `\\[universal-argument]' prefix the formula is installed as a \
field formula.
When called with a `\\[universal-argument] \\[universal-argument]' prefix, \
insert the active equation for the field
back into the current field, so that it can be edited there. This is \
useful
in order to use \\<org-table-fedit-map>`\\[org-table-show-reference]' to \
check the referenced fields.
When called, the command first prompts for a formula, which is read in
the minibuffer. Previously entered formulas are available through the
history list, and the last used formula is offered as a default.
These stored formulas are adapted correctly when moving, inserting, or
deleting columns with the corresponding commands.
The formula can be any algebraic expression understood by the Calc package.
For details, see the Org mode manual.
This function can also be called from Lisp programs and offers
additional arguments: EQUATION can be the formula to apply. If this
argument is given, the user will not be prompted.
SUPPRESS-ALIGN is used to speed-up recursive calls by by-passing
unnecessary aligns.
SUPPRESS-CONST suppresses the interpretation of constants in the
formula, assuming that this has been done already outside the
function.
SUPPRESS-STORE means the formula should not be stored, either
because it is already stored, or because it is a modified
equation that should not overwrite the stored one.
SUPPRESS-ANALYSIS prevents analyzing the table and checking
location of point."
(interactive "P")
(unless suppress-analysis
(org-table-check-inside-data-field nil t)
(org-table-analyze))
(if (equal arg '(16))
(let ((eq (org-table-current-field-formula)))
(org-table-get-field nil eq)
(org-table-align)
(setq org-table-may-need-update t))
(let* (fields
(ndown (if (integerp arg) arg 1))
(org-table-automatic-realign nil)
(case-fold-search nil)
(down (> ndown 1))
(formula (if (and equation suppress-store)
equation
(org-table-get-formula equation (equal arg '(4)))))
(n0 (org-table-current-column))
(calc-modes (copy-sequence org-calc-default-modes))
(numbers nil) ; was a variable, now fixed default
(keep-empty nil)
form form0 formrpl formrg bw fmt ev orig lispp literal
duration duration-output-format)
;; Parse the format string. Since we have a lot of modes, this is
;; a lot of work. However, I think calc still uses most of the time.
(if (string-match "\\(.*\\);\\(.*\\)" formula)
(progn
(setq fmt (concat (cdr (assoc "%" org-table-local-parameters))
(match-string-no-properties 2 formula)))
(setq formula (match-string-no-properties 1 formula))
(while (string-match "\\([pnfse]\\)\\(-?[0-9]+\\)" fmt)
(let ((c (string-to-char (match-string 1 fmt)))
(n (string-to-number (match-string 2 fmt))))
(cl-case c
(?p (setf (cl-getf calc-modes 'calc-internal-prec) n))
(?n (setf (cl-getf calc-modes 'calc-float-format) (list 'float n)))
(?f (setf (cl-getf calc-modes 'calc-float-format) (list 'fix n)))
(?s (setf (cl-getf calc-modes 'calc-float-format) (list 'sci n)))
(?e (setf (cl-getf calc-modes 'calc-float-format) (list 'eng n)))))
;; Remove matched flags from the mode string.
(setq fmt (replace-match "" t t fmt)))
(while (string-match "\\([tTUNLEDRFSu]\\)" fmt)
(let ((c (string-to-char (match-string 1 fmt))))
(cl-case c
(?t (setq duration t numbers t
duration-output-format org-table-duration-custom-format))
(?T (setq duration t numbers t duration-output-format nil))
(?U (setq duration t numbers t duration-output-format 'hh:mm))
(?N (setq numbers t))
(?L (setq literal t))
(?E (setq keep-empty t))
(?D (setf (cl-getf calc-modes 'calc-angle-mode) 'deg))
(?R (setf (cl-getf calc-modes 'calc-angle-mode) 'rad))
(?F (setf (cl-getf calc-modes 'calc-prefer-frac) t))
(?S (setf (cl-getf calc-modes 'calc-symbolic-mode) t))
(?u (setf (cl-getf calc-modes 'calc-simplify-mode) 'units))))
;; Remove matched flags from the mode string.
(setq fmt (replace-match "" t t fmt)))
(unless (string-match "\\S-" fmt)
(setq fmt nil))))
(when (and (not suppress-const) org-table-formula-use-constants)
(setq formula (org-table-formula-substitute-names formula)))
(setq orig (or (get-text-property 1 :orig-formula formula) "?"))
(setq formula (org-table-formula-handle-first/last-rc formula))
(while (> ndown 0)
(setq fields (org-split-string
(org-trim
(buffer-substring-no-properties
(line-beginning-position) (line-end-position)))
" *| *"))
;; replace fields with duration values if relevant
(if duration
(setq fields
(mapcar (lambda (x) (org-table-time-string-to-seconds x))
fields)))
(if (eq numbers t)
(setq fields (mapcar
(lambda (x)
(if (string-match "\\S-" x)
(number-to-string (string-to-number x))
x))
fields)))
(setq ndown (1- ndown))
(setq form (copy-sequence formula)
lispp (and (> (length form) 2) (equal (substring form 0 2) "'(")))
(if (and lispp literal) (setq lispp 'literal))
;; Insert row and column number of formula result field
(while (string-match "[@$]#" form)
(setq form
(replace-match
(format "%d"
(save-match-data
(if (equal (substring form (match-beginning 0)
(1+ (match-beginning 0)))
"@")
(org-table-current-dline)
(org-table-current-column))))
t t form)))
;; Check for old vertical references
(org-table--error-on-old-row-references form)
;; Insert remote references
(setq form (org-table-remote-reference-indirection form))
(while (string-match "\\<remote([ \t]*\\([^,)]+\\)[ \t]*,[ \t]*\\([^\n)]+\\))" form)
(setq form
(replace-match
(save-match-data
(org-table-make-reference
(let ((rmtrng (org-table-get-remote-range
(match-string 1 form) (match-string 2 form))))
(if duration
(if (listp rmtrng)
(mapcar (lambda(x) (org-table-time-string-to-seconds x)) rmtrng)
(org-table-time-string-to-seconds rmtrng))
rmtrng))
keep-empty numbers lispp))
t t form)))
;; Insert complex ranges
(while (and (string-match org-table-range-regexp form)
(> (length (match-string 0 form)) 1))
(setq formrg
(save-match-data
(org-table-get-range
(match-string 0 form) org-table-current-begin-pos n0)))
(setq formrpl
(save-match-data
(org-table-make-reference
;; possibly handle durations
(if duration
(if (listp formrg)
(mapcar (lambda(x) (org-table-time-string-to-seconds x)) formrg)
(org-table-time-string-to-seconds formrg))
formrg)
keep-empty numbers lispp)))
(if (not (save-match-data
(string-match (regexp-quote form) formrpl)))
(setq form (replace-match formrpl t t form))
(user-error "Spreadsheet error: invalid reference \"%s\"" form)))
;; Insert simple ranges, i.e. included in the current row.
(while (string-match
"\\$\\(\\([-+]\\)?[0-9]+\\)\\.\\.\\$\\(\\([-+]\\)?[0-9]+\\)"
form)
(setq form
(replace-match
(save-match-data
(org-table-make-reference
(cl-subseq fields
(+ (if (match-end 2) n0 0)
(string-to-number (match-string 1 form))
-1)
(+ (if (match-end 4) n0 0)
(string-to-number (match-string 3 form))))
keep-empty numbers lispp))
t t form)))
(setq form0 form)
;; Insert the references to fields in same row
(while (string-match "\\$\\(\\([-+]\\)?[0-9]+\\)" form)
(let* ((n (+ (string-to-number (match-string 1 form))
(if (match-end 2) n0 0)))
(x (nth (1- (if (= n 0) n0 (max n 1))) fields)))
(setq formrpl (save-match-data
(org-table-make-reference
x keep-empty numbers lispp)))
(when (or (not x)
(save-match-data
(string-match (regexp-quote formula) formrpl)))
(user-error "Invalid field specifier \"%s\""
(match-string 0 form))))
(setq form (replace-match formrpl t t form)))
(if lispp
(setq ev (condition-case nil
;; FIXME: Arbitrary code evaluation.
(eval (eval (read form)))
(error "#ERROR"))
ev (if (numberp ev) (number-to-string ev) ev)
ev (if duration (org-table-time-seconds-to-string
(string-to-number ev)
duration-output-format)
ev))
;; Use <...> timestamps so that Calc can handle them.
(setq form
(replace-regexp-in-string org-ts-regexp-inactive "<\\1>" form))
;; Internationalize local timestamps by setting locale to
;; "C".
(setq form
(replace-regexp-in-string
org-ts-regexp
(lambda (ts)
(let ((system-time-locale "C"))
(format-time-string
(org-time-stamp-format
(string-match-p "[0-9]\\{1,2\\}:[0-9]\\{2\\}" ts))
(save-match-data (org-time-string-to-time ts)))))
form t t))
(setq ev (if (and duration (string-match "^[0-9]+:[0-9]+\\(?::[0-9]+\\)?$" form))
form
(calc-eval (cons form calc-modes)
(when (and (not keep-empty) numbers) 'num)))
ev (if (and duration
;; When the result is an empty string,
;; keep it empty.
;; See https://list.orgmode.org/orgmode/CAF_DUeEFpNU5UXjE80yB1MB9xj5oVLqG=XadnkqCdzWtakWdPg@mail.gmail.com/
(not (string-empty-p ev)))
(org-table-time-seconds-to-string
(if (string-match "^[0-9]+:[0-9]+\\(?::[0-9]+\\)?$" ev)
(string-to-number (org-table-time-string-to-seconds ev))
(string-to-number ev))
duration-output-format)
ev)))
(when org-table-formula-debug
(let ((wcf (current-window-configuration)))
(with-output-to-temp-buffer "*Substitution History*"
(princ (format "Substitution history of formula
Orig: %s
$xyz-> %s
@r$c-> %s
$1-> %s\n" orig formula form0 form))
(if (consp ev)
(princ (format " %s^\nError: %s"
(make-string (car ev) ?\-) (nth 1 ev)))
(princ (format "Result: %s\nFormat: %s\nFinal: %s"
ev (or fmt "NONE")
(if fmt (format fmt (string-to-number ev)) ev)))))
(setq bw (get-buffer-window "*Substitution History*"))
(org-fit-window-to-buffer bw)
(unless (and (called-interactively-p 'any) (not ndown))
(unless (let (inhibit-redisplay)
(y-or-n-p "Debugging Formula. Continue to next? "))
(org-table-align)
(user-error "Abort"))
(delete-window bw)
(message "")
(set-window-configuration wcf))))
(when (consp ev) (setq fmt nil ev "#ERROR"))
(org-table-justify-field-maybe
(format org-table-formula-field-format
(cond
((not (stringp ev)) ev)
(fmt (format fmt (string-to-number ev)))
;; Replace any active time stamp in the result with
;; an inactive one. Dates in tables are likely
;; piece of regular data, not meant to appear in the
;; agenda.
(t (replace-regexp-in-string org-ts-regexp "[\\1]" ev)))))
(if (and down (> ndown 0) (looking-at ".*\n[ \t]*|[^-]"))
(call-interactively 'org-return)
(setq ndown 0)))
(and down (org-table-maybe-recalculate-line))
(or suppress-align (and org-table-may-need-update
(org-table-align))))))
(defun org-table-put-field-property (prop value)
(save-excursion
(put-text-property (progn (skip-chars-backward "^|") (point))
(progn (skip-chars-forward "^|") (point))
prop value)))
(defun org-table-get-range (desc &optional tbeg col highlight corners-only)
"Get a calc vector from a column, according to descriptor DESC.
Optional arguments TBEG and COL can give the beginning of the table and
the current column, to avoid unnecessary parsing.
HIGHLIGHT means just highlight the range.
When CORNERS-ONLY is set, only return the corners of the range as
a list (line1 column1 line2 column2) where line1 and line2 are
line numbers relative to beginning of table, or TBEG, and column1
and column2 are table column numbers."
(let* ((desc (if (string-match-p "\\`\\$[0-9]+\\.\\.\\$[0-9]+\\'" desc)
(replace-regexp-in-string "\\$" "@0$" desc)
desc))
(col (or col (org-table-current-column)))
(tbeg (or tbeg (org-table-begin)))
(thisline (count-lines tbeg (line-beginning-position))))
(unless (string-match org-table-range-regexp desc)
(user-error "Invalid table range specifier `%s'" desc))
(let ((rangep (match-end 3))
(r1 (let ((r (and (match-end 1) (match-string 1 desc))))
(or (save-match-data
(and (org-string-nw-p r)
(org-table--descriptor-line r thisline)))
thisline)))
(r2 (let ((r (and (match-end 4) (match-string 4 desc))))
(or (save-match-data
(and (org-string-nw-p r)
(org-table--descriptor-line r thisline)))
thisline)))
(c1 (let ((c (and (match-end 2) (substring (match-string 2 desc) 1))))
(if (or (not c) (= (string-to-number c) 0)) col
(+ (string-to-number c)
(if (memq (string-to-char c) '(?- ?+)) col 0)))))
(c2 (let ((c (and (match-end 5) (substring (match-string 5 desc) 1))))
(if (or (not c) (= (string-to-number c) 0)) col
(+ (string-to-number c)
(if (memq (string-to-char c) '(?- ?+)) col 0))))))
(save-excursion
(if (and (not corners-only)
(or (not rangep) (and (= r1 r2) (= c1 c2))))
;; Just one field.
(progn
(forward-line (- r1 thisline))
(while (not (looking-at org-table-dataline-regexp))
(forward-line))
(prog1 (org-trim (org-table-get-field c1))
(when highlight (org-table-highlight-rectangle))))
;; A range, return a vector. First sort the numbers to get
;; a regular rectangle.
(let ((first-row (min r1 r2))
(last-row (max r1 r2))
(first-column (min c1 c2))
(last-column (max c1 c2)))
(if corners-only (list first-row first-column last-row last-column)
;; Copy the range values into a list.
(forward-line (- first-row thisline))
(while (not (looking-at org-table-dataline-regexp))
(forward-line)
(cl-incf first-row))
(org-table-goto-column first-column)
(let ((beg (point)))
(forward-line (- last-row first-row))
(while (not (looking-at org-table-dataline-regexp))
(forward-line -1))
(org-table-goto-column last-column)
(let ((end (point)))
(when highlight
(org-table-highlight-rectangle
beg (progn (skip-chars-forward "^|\n") (point))))
;; Return string representation of calc vector.
(mapcar #'org-trim
(apply #'append
(org-table-copy-region beg end))))))))))))
(defun org-table--descriptor-line (desc cline)
"Return relative line number corresponding to descriptor DESC.
The cursor is currently in relative line number CLINE."
(if (string-match "\\`[0-9]+\\'" desc)
(aref org-table-dlines (string-to-number desc))
(when (or (not (string-match
"^\\(\\([-+]\\)?\\(I+\\)\\)?\\(\\([-+]\\)?\\([0-9]+\\)\\)?"
;; 1 2 3 4 5 6
desc))
(and (not (match-end 3)) (not (match-end 6)))
(and (match-end 3) (match-end 6) (not (match-end 5))))
(user-error "Invalid row descriptor `%s'" desc))
(let* ((hn (and (match-end 3) (- (match-end 3) (match-beginning 3))))
(hdir (match-string 2 desc))
(odir (match-string 5 desc))
(on (and (match-end 6) (string-to-number (match-string 6 desc))))
(rel (and (match-end 6)
(or (and (match-end 1) (not (match-end 3)))
(match-end 5)))))
(when (and hn (not hdir))
(setq cline 0)
(setq hdir "+")
(when (eq (aref org-table-current-line-types 0) 'hline) (cl-decf hn)))
(when (and (not hn) on (not odir)) (user-error "Should never happen"))
(when hn
(setq cline
(org-table--row-type 'hline hn cline (equal hdir "-") nil desc)))
(when on
(setq cline
(org-table--row-type 'dline on cline (equal odir "-") rel desc)))
cline)))
(defun org-table--row-type (type n i backwards relative desc)
"Return relative line of Nth row with type TYPE.
Search starts from relative line I. When BACKWARDS in non-nil,
look before I. When RELATIVE is non-nil, the reference is
relative. DESC is the original descriptor that started the
search, as a string."
(let ((l (length org-table-current-line-types)))
(catch :exit
(dotimes (_ n)
(while (and (cl-incf i (if backwards -1 1))
(>= i 0)
(< i l)
(not (eq (aref org-table-current-line-types i) type))
;; We are going to cross a hline. Check if this is
;; an authorized move.
(cond
((not relative))
((not (eq (aref org-table-current-line-types i) 'hline)))
((eq org-table-relative-ref-may-cross-hline t))
((eq org-table-relative-ref-may-cross-hline 'error)
(user-error "Row descriptor %s crosses hline" desc))
(t (cl-decf i (if backwards -1 1)) ; Step back.
(throw :exit nil)))))))
(cond ((or (< i 0) (>= i l))
(user-error "Row descriptor %s leads outside table" desc))
;; The last hline doesn't exist. Instead, point to last row
;; in table.
((= i (1- l)) (1- i))
(t i))))
(defun org-table--error-on-old-row-references (s)
(when (string-match "&[-+0-9I]" s)
(user-error "Formula contains old &row reference, please rewrite using @-syntax")))
(defun org-table-make-reference (elements keep-empty numbers lispp)
"Convert list ELEMENTS to something appropriate to insert into formula.
KEEP-EMPTY indicated to keep empty fields, default is to skip them.
NUMBERS indicates that everything should be converted to numbers.
LISPP non-nil means to return something appropriate for a Lisp
list, `literal' is for the format specifier L."
;; Calc nan (not a number) is used for the conversion of the empty
;; field to a reference for several reasons: (i) It is accepted in a
;; Calc formula (e. g. "" or "()" would result in a Calc error).
;; (ii) In a single field (not in range) it can be distinguished
;; from "(nan)" which is the reference made from a single field
;; containing "nan".
(if (stringp elements)
;; field reference
(if lispp
(if (eq lispp 'literal)
elements
;; Ignore KEEP-EMPTY here.
;; When ELEMENTS="" and NUMBERS=t, (string-to-number "")
;; returns 0 - consistent with (0) for Calc branch.
;; When ELEMENTS="" and NUMBERS=nil, `prin1-to-string' will
;; return "\"\"" - historical behavior that also does not
;; leave missing arguments in formulas like (string< $1 $2)
;; when $2 cell is empty.
(prin1-to-string
(if numbers (string-to-number elements) elements)))
(if (string-match "\\S-" elements)
(progn
(when numbers (setq elements (number-to-string
(string-to-number elements))))
(concat "(" elements ")"))
(if (or (not keep-empty) numbers) "(0)" "nan")))
;; range reference
(unless keep-empty
(setq elements
(delq nil
(mapcar (lambda (x) (if (string-match "\\S-" x) x nil))
elements))))
(setq elements (or elements '())) ; if delq returns nil then we need '()
(if lispp
(mapconcat
(lambda (x)
(if (eq lispp 'literal)
x
(prin1-to-string (if numbers (string-to-number x) x))))
elements " ")
(concat "[" (mapconcat
(lambda (x)
(if (string-match "\\S-" x)
(if numbers
(number-to-string (string-to-number x))
x)
(if (or (not keep-empty) numbers) "0" "nan")))
elements
",") "]"))))
(defun org-table-message-once-per-second (t1 &rest args)
"If there has been more than one second since T1, display message.
ARGS are passed as arguments to the `message' function. Returns
current time if a message is printed, otherwise returns T1. If
T1 is nil, always messages."
(let ((curtime (current-time)))
(if (or (not t1) (time-less-p 1 (time-subtract curtime t1)))
(progn (apply 'message args)
curtime)
t1)))
;;;###autoload
(defun org-table-recalculate (&optional all noalign)
"Recalculate the current table line by applying all stored formulas.
With prefix arg ALL, do this for all lines in the table.
When called with a `\\[universal-argument] \\[universal-argument]' prefix, or \
if ALL is the symbol `iterate',
recompute the table until it no longer changes.
If NOALIGN is not nil, do not re-align the table after the computations
are done. This is typically used internally to save time, if it is
known that the table will be realigned a little later anyway."
(interactive "P")
(unless (memq this-command org-recalc-commands)
(push this-command org-recalc-commands))
(unless (org-at-table-p) (user-error "Not at a table"))
(if (or (eq all 'iterate) (equal all '(16)))
(org-table-iterate)
(org-table-analyze)
(let* ((eqlist (sort (org-table-get-stored-formulas)
(lambda (a b) (string< (car a) (car b)))))
(inhibit-redisplay (not debug-on-error))
(line-re org-table-dataline-regexp)
(log-first-time (current-time))
(log-last-time log-first-time)
(cnt 0)
beg end eqlcol eqlfield)
;; Insert constants in all formulas.
(when eqlist
(org-table-with-shrunk-columns
(org-table-save-field
;; Expand equations, then split the equation list between
;; column formulas and field formulas.
(dolist (eq eqlist)
(let* ((rhs (org-table-formula-substitute-names
(org-table-formula-handle-first/last-rc (cdr eq))))
(old-lhs (car eq))
(lhs
(org-table-formula-handle-first/last-rc
(cond
((string-match "\\`@-?I+" old-lhs)
(user-error "Can't assign to hline relative reference"))
((string-match "\\`\\$[<>]" old-lhs)
(let ((new (org-table-formula-handle-first/last-rc
old-lhs)))
(when (assoc new eqlist)
(user-error "\"%s=\" formula tries to overwrite \
existing formula for column %s"
old-lhs
new))
new))
(t old-lhs)))))
(if (string-match-p "\\`\\$[0-9]+\\'" lhs)
(push (cons lhs rhs) eqlcol)
(push (cons lhs rhs) eqlfield))))
(setq eqlcol (nreverse eqlcol))
;; Expand ranges in lhs of formulas
(setq eqlfield (org-table-expand-lhs-ranges (nreverse eqlfield)))
;; Get the correct line range to process.
(if all
(progn
(setq end (copy-marker (org-table-end)))
(goto-char (setq beg org-table-current-begin-pos))
(cond
((re-search-forward org-table-calculate-mark-regexp end t)
;; This is a table with marked lines, compute selected
;; lines.
(setq line-re org-table-recalculate-regexp))
;; Move forward to the first non-header line.
((and (re-search-forward org-table-dataline-regexp end t)
(re-search-forward org-table-hline-regexp end t)
(re-search-forward org-table-dataline-regexp end t))
(setq beg (match-beginning 0)))
;; Just leave BEG at the start of the table.
(t nil)))
(setq beg (line-beginning-position)
end (copy-marker (line-beginning-position 2))))
(goto-char beg)
;; Mark named fields untouchable. Also check if several
;; field/range formulas try to set the same field.
(remove-text-properties beg end '(:org-untouchable t))
(let ((current-line (count-lines org-table-current-begin-pos
(line-beginning-position)))
seen-fields)
(dolist (eq eqlfield)
(let* ((name (car eq))
(location (assoc name org-table-named-field-locations))
(eq-line (or (nth 1 location)
(and (string-match "\\`@\\([0-9]+\\)" name)
(aref org-table-dlines
(string-to-number
(match-string 1 name))))))
(reference
(if location
;; Turn field coordinates associated to NAME
;; into an absolute reference.
(format "@%d$%d"
(org-table-line-to-dline eq-line)
(nth 2 location))
name)))
(when (member reference seen-fields)
(user-error "Several field/range formulas try to set %s"
reference))
(push reference seen-fields)
(when (or all (eq eq-line current-line))
(org-table-goto-field name)
(org-table-put-field-property :org-untouchable t)))))
;; Evaluate the column formulas, but skip fields covered by
;; field formulas.
(goto-char beg)
(while (re-search-forward line-re end t)
(unless (string-match "\\` *[_^!$/] *\\'" (org-table-get-field 1))
;; Unprotected line, recalculate.
(cl-incf cnt)
(when all
(setq log-last-time
(org-table-message-once-per-second
log-last-time
"Re-applying formulas to full table...(line %d)" cnt)))
(if (markerp org-last-recalc-line)
(move-marker org-last-recalc-line (line-beginning-position))
(setq org-last-recalc-line
(copy-marker (line-beginning-position))))
(dolist (entry eqlcol)
(goto-char org-last-recalc-line)
(org-table-goto-column
(string-to-number (substring (car entry) 1)) nil 'force)
(unless (get-text-property (point) :org-untouchable)
(org-table-eval-formula
nil (cdr entry) 'noalign 'nocst 'nostore 'noanalysis)))))
;; Evaluate the field formulas.
(dolist (eq eqlfield)
(let ((reference (car eq))
(formula (cdr eq)))
(setq log-last-time
(org-table-message-once-per-second
(and all log-last-time)
"Re-applying formula to field: %s" (car eq)))
(org-table-goto-field
reference
;; Possibly create a new column, as long as
;; `org-table-formula-create-columns' allows it.
(let ((column-count (progn (end-of-line)
(1- (org-table-current-column)))))
(lambda (column)
(when (> column 1000)
(user-error "Formula column target too large"))
(and (> column column-count)
(or (eq org-table-formula-create-columns t)
(and (eq org-table-formula-create-columns 'warn)
(progn
(org-display-warning
"Out-of-bounds formula added columns")
t))
(and (eq org-table-formula-create-columns 'prompt)
(yes-or-no-p
"Out-of-bounds formula. Add columns? "))
(user-error
"Missing columns in the table. Aborting"))))))
(org-table-eval-formula nil formula t t t t)))
;; Clean up marker.
(set-marker end nil)))
(unless noalign
(when org-table-may-need-update (org-table-align))
(when all
(org-table-message-once-per-second
log-first-time "Re-applying formulas to %d lines... done" cnt)))
(org-table-message-once-per-second
(and all log-first-time) "Re-applying formulas... done")))))
;;;###autoload
(defun org-table-iterate (&optional arg)
"Recalculate the table until it does not change anymore.
The maximum number of iterations is 10, but you can choose a different value
with the prefix ARG."
(interactive "P")
(let ((imax (if arg (prefix-numeric-value arg) 10))
(i 0)
(lasttbl (buffer-substring (org-table-begin) (org-table-end)))
thistbl)
(catch 'exit
(while (< i imax)
(setq i (1+ i))
(org-table-recalculate 'all)
(setq thistbl (buffer-substring (org-table-begin) (org-table-end)))
(if (not (string= lasttbl thistbl))
(setq lasttbl thistbl)
(if (> i 1)
(message "Convergence after %d iterations" i)
(message "Table was already stable"))
(throw 'exit t)))
(user-error "No convergence after %d iterations" i))))
;;;###autoload
(defun org-table-recalculate-buffer-tables ()
"Recalculate all tables in the current buffer."
(interactive)
(org-with-wide-buffer
(org-table-map-tables
(lambda ()
;; Reason for separate `org-table-align': When repeating
;; (org-table-recalculate t) `org-table-may-need-update' gets in
;; the way.
(org-table-recalculate t t)
(org-table-align))
t)))
;;;###autoload
(defun org-table-iterate-buffer-tables ()
"Iterate all tables in the buffer, to converge inter-table dependencies."
(interactive)
(let* ((imax 10)
(i imax)
(checksum (md5 (buffer-string)))
c1)
(org-with-wide-buffer
(catch 'exit
(while (> i 0)
(setq i (1- i))
(org-table-map-tables (lambda () (org-table-recalculate t t)) t)
(if (equal checksum (setq c1 (md5 (buffer-string))))
(progn
(org-table-map-tables #'org-table-align t)
(message "Convergence after %d iterations" (- imax i))
(throw 'exit t))
(setq checksum c1)))
(org-table-map-tables #'org-table-align t)
(user-error "No convergence after %d iterations" imax)))))
(defun org-table-calc-current-TBLFM (&optional arg)
"Apply the #+TBLFM in the line at point to the table."
(interactive "P")
(unless (org-at-TBLFM-p) (user-error "Not at a #+TBLFM line"))
(let ((formula (buffer-substring
(line-beginning-position)
(line-end-position))))
(save-excursion
;; Insert a temporary formula at right after the table
(goto-char (org-table-TBLFM-begin))
(let ((s (point-marker)))
(insert formula "\n")
(let ((e (point-marker)))
;; Recalculate the table.
(forward-line -1) ; move to the inserted line
(skip-chars-backward " \r\n\t")
(unwind-protect
(org-call-with-arg #'org-table-recalculate (or arg t))
;; Delete the formula inserted temporarily.
(delete-region s e)
(set-marker s nil)
(set-marker e nil)))))))
(defun org-table-TBLFM-begin ()
"Find the beginning of the TBLFM lines and return its position.
Return nil when the beginning of TBLFM line was not found."
(save-excursion
(when (progn (forward-line 1)
(re-search-backward org-table-TBLFM-begin-regexp nil t))
(line-beginning-position 2))))
(defun org-table-expand-lhs-ranges (equations)
"Expand list of formulas.
If some of the RHS in the formulas are ranges or a row reference,
expand them to individual field equations for each field. This
function assumes the table is already analyzed (i.e., using
`org-table-analyze')."
(let (res)
(dolist (e equations (nreverse res))
(let ((lhs (car e))
(rhs (cdr e)))
(cond
((string-match-p "\\`@[-+0-9]+\\$-?[0-9]+\\'" lhs)
;; This just refers to one fixed field.
(push e res))
((string-match-p "\\`[a-zA-Z][_a-zA-Z0-9]*\\'" lhs)
;; This just refers to one fixed named field.
(push e res))
((string-match-p "\\`\\$[0-9]+\\'" lhs)
;; Column formulas are treated specially and are not
;; expanded.
(push e res))
((string-match "\\`@[0-9]+\\'" lhs)
(dotimes (ic org-table-current-ncol)
(push (cons (propertize (format "%s$%d" lhs (1+ ic)) :orig-eqn e)
rhs)
res)))
(t
(let* ((range (org-table-get-range
lhs org-table-current-begin-pos 1 nil 'corners))
(r1 (org-table-line-to-dline (nth 0 range)))
(c1 (nth 1 range))
(r2 (org-table-line-to-dline (nth 2 range) 'above))
(c2 (nth 3 range)))
(cl-loop for ir from r1 to r2 do
(cl-loop for ic from c1 to c2 do
(push (cons (propertize
(format "@%d$%d" ir ic) :orig-eqn e)
rhs)
res))))))))))
(defun org-table-formula-handle-first/last-rc (s)
"Replace @<, @>, $<, $> with first/last row/column of the table.
So @< and $< will always be replaced with @1 and $1, respectively.
The advantage of these special markers are that structure editing of
the table will not change them, while @1 and $1 will be modified
when a line/row is swapped out of that privileged position. So for
formulas that use a range of rows or columns, it may often be better
to anchor the formula with \"I\" row markers, or to offset from the
borders of the table using the @< @> $< $> makers."
(let (n nmax len char (start 0))
(while (string-match "\\([@$]\\)\\(<+\\|>+\\)\\|\\(remote([^)]+)\\)"
s start)
(if (match-end 3)
(setq start (match-end 3))
(setq nmax (if (equal (match-string 1 s) "@")
(1- (length org-table-dlines))
org-table-current-ncol)
len (- (match-end 2) (match-beginning 2))
char (string-to-char (match-string 2 s))
n (if (= char ?<)
len
(- nmax len -1)))
(if (or (< n 1) (> n nmax))
(user-error "Reference \"%s\" in expression \"%s\" points outside table"
(match-string 0 s) s))
(setq start (match-beginning 0))
(setq s (replace-match (format "%s%d" (match-string 1 s) n) t t s)))))
s)
(defun org-table-formula-substitute-names (f)
"Replace $const with values in string F."
(let ((start 0)
(pp (/= (string-to-char f) ?'))
(duration (string-match-p ";.*[Tt].*\\'" f))
(new (replace-regexp-in-string ; Check for column names.
org-table-column-name-regexp
(lambda (m)
(concat "$" (cdr (assoc (match-string 1 m)
org-table-column-names))))
f t t)))
;; Parameters and constants.
(while (setq start
(string-match
"\\$\\([a-zA-Z][_a-zA-Z0-9]*\\)\\|\\(\\<remote([^)]*)\\)"
new start))
(if (match-end 2) (setq start (match-end 2))
(cl-incf start)
;; When a duration is expected, convert value on the fly.
(let ((value
(save-match-data
(let ((v (org-table-get-constant (match-string 1 new))))
(if (and (org-string-nw-p v) duration)
(org-table-time-string-to-seconds v)
v)))))
(when value
(setq new (replace-match
(concat (and pp "(") value (and pp ")")) t t new))))))
(if org-table-formula-debug (propertize new :orig-formula f) new)))
(defun org-table-get-constant (const)
"Find the value for a parameter or constant in a formula.
Parameters get priority."
(or (cdr (assoc const org-table-local-parameters))
(cdr (assoc const org-table-formula-constants-local))
(cdr (assoc const org-table-formula-constants))
(and (fboundp 'constants-get) (constants-get const))
(and (string= (substring const 0 (min 5 (length const))) "PROP_")
(org-entry-get nil (substring const 5) 'inherit))
"#UNDEFINED_NAME"))
(defvar org-table-fedit-map
(let ((map (make-sparse-keymap)))
(org-defkey map "\C-x\C-s" 'org-table-fedit-finish)
(org-defkey map "\C-c\C-s" 'org-table-fedit-finish)
(org-defkey map "\C-c\C-c" 'org-table-fedit-finish)
(org-defkey map "\C-c'" 'org-table-fedit-finish)
(org-defkey map "\C-c\C-q" 'org-table-fedit-abort)
(org-defkey map "\C-c?" 'org-table-show-reference)
(org-defkey map [(meta shift up)] 'org-table-fedit-line-up)
(org-defkey map [(meta shift down)] 'org-table-fedit-line-down)
(org-defkey map [(shift up)] 'org-table-fedit-ref-up)
(org-defkey map [(shift down)] 'org-table-fedit-ref-down)
(org-defkey map [(shift left)] 'org-table-fedit-ref-left)
(org-defkey map [(shift right)] 'org-table-fedit-ref-right)
(org-defkey map [(meta up)] 'org-table-fedit-scroll-down)
(org-defkey map [(meta down)] 'org-table-fedit-scroll)
(org-defkey map [(meta tab)] 'completion-at-point)
(org-defkey map "\M-\C-i" 'completion-at-point)
(org-defkey map [(tab)] 'org-table-fedit-lisp-indent)
(org-defkey map "\C-i" 'org-table-fedit-lisp-indent)
(org-defkey map "\C-c\C-r" 'org-table-fedit-toggle-ref-type)
(org-defkey map "\C-c}" 'org-table-fedit-toggle-coordinates)
map))
(easy-menu-define org-table-fedit-menu org-table-fedit-map "Org Edit Formulas Menu."
'("Edit-Formulas"
["Finish and Install" org-table-fedit-finish t]
["Finish, Install, and Apply" (org-table-fedit-finish t) :keys "C-u C-c C-c"]
["Abort" org-table-fedit-abort t]
"--"
["Pretty-Print Lisp Formula" org-table-fedit-lisp-indent t]
["Complete Lisp Symbol" completion-at-point t]
"--"
"Shift Reference at Point"
["Up" org-table-fedit-ref-up t]
["Down" org-table-fedit-ref-down t]
["Left" org-table-fedit-ref-left t]
["Right" org-table-fedit-ref-right t]
"-"
"Change Test Row for Column Formulas"
["Up" org-table-fedit-line-up t]
["Down" org-table-fedit-line-down t]
"--"
["Scroll Table Window" org-table-fedit-scroll t]
["Scroll Table Window down" org-table-fedit-scroll-down t]
["Show Table Grid" org-table-fedit-toggle-coordinates
:style toggle :selected (with-current-buffer (marker-buffer org-pos)
org-table-overlay-coordinates)]
"--"
["Standard Refs (B3 instead of @3$2)" org-table-fedit-toggle-ref-type
:style toggle :selected org-table-buffer-is-an]))
(defvar org-table--fedit-source nil
"Position of the TBLFM line being edited.")
;;;###autoload
(defun org-table-edit-formulas ()
"Edit the formulas of the current table in a separate buffer."
(interactive)
(let ((at-tblfm (org-at-TBLFM-p)))
(unless (or at-tblfm (org-at-table-p))
(user-error "Not at a table"))
(save-excursion
;; Move point within the table before analyzing it.
(when at-tblfm (re-search-backward "^[ \t]*|"))
(org-table-analyze))
(let ((key (org-table-current-field-formula 'key 'noerror))
(eql (sort (org-table-get-stored-formulas t (and at-tblfm (point)))
#'org-table-formula-less-p))
(pos (point-marker))
(source (copy-marker (line-beginning-position)))
(startline 1)
(wc (current-window-configuration))
(sel-win (selected-window))
(titles '((column . "# Column Formulas\n")
(field . "# Field and Range Formulas\n")
(named . "# Named Field Formulas\n"))))
(let ((pop-up-frames nil))
;; We explicitly prohibit creating edit buffer in a new frame
;; - such configuration is not supported.
(switch-to-buffer-other-window "*Edit Formulas*"))
(erase-buffer)
;; Keep global-font-lock-mode from turning on font-lock-mode
(let ((font-lock-global-modes '(not fundamental-mode)))
(fundamental-mode))
(setq-local font-lock-global-modes (list 'not major-mode))
(setq-local org-pos pos)
(setq-local org-table--fedit-source source)
(setq-local org-window-configuration wc)
(setq-local org-selected-window sel-win)
;; Use completion from `emacs-lisp-mode'
(add-hook 'completion-at-point-functions
#'elisp-completion-at-point nil 'local)
(use-local-map org-table-fedit-map)
(add-hook 'post-command-hook #'org-table-fedit-post-command t t)
(setq startline (org-current-line))
(dolist (entry eql)
(let* ((type (cond
((string-match "\\`\\$\\([0-9]+\\|[<>]+\\)\\'"
(car entry))
'column)
((equal (string-to-char (car entry)) ?@) 'field)
(t 'named)))
(title (assq type titles)))
(when title
(unless (bobp) (insert "\n"))
(insert
(org-add-props (cdr title) nil 'face font-lock-comment-face))
(setq titles (remove title titles)))
(when (equal key (car entry)) (setq startline (org-current-line)))
(let ((s (concat
(if (memq (string-to-char (car entry)) '(?@ ?$)) "" "$")
(car entry) " = " (cdr entry) "\n")))
(remove-text-properties 0 (length s) '(face nil) s)
(insert s))))
(when (eq org-table-use-standard-references t)
(org-table-fedit-toggle-ref-type))
(org-goto-line startline)
(message "%s" (substitute-command-keys "\\<org-mode-map>\
Edit formulas, finish with `\\[org-ctrl-c-ctrl-c]' or `\\[org-edit-special]'. \
See menu for more commands.")))))
(defun org-table-fedit-post-command ()
(when (not (memq this-command '(lisp-complete-symbol completion-at-point)))
(let ((win (selected-window)))
(save-excursion
(ignore-errors (org-table-show-reference))
(select-window win)))))
(defun org-table-formula-to-user (s)
"Convert a formula from internal to user representation."
(if (eq org-table-use-standard-references t)
(org-table-convert-refs-to-an s)
s))
(defun org-table-formula-from-user (s)
"Convert a formula from user to internal representation."
(if org-table-use-standard-references
(org-table-convert-refs-to-rc s)
s))
(defun org-table-convert-refs-to-rc (s)
"Convert spreadsheet references from A7 to @7$28.
Works for single references, but also for entire formulas and even the
full TBLFM line."
(let ((start 0))
(while (string-match "\\<\\([a-zA-Z]+\\)\\([0-9]+\\>\\|&\\)\\|\\(;[^\r\n:]+\\|\\<remote([^,)]*)\\)" s start)
(cond
((match-end 3)
;; format match, just advance
(setq start (match-end 0)))
((and (> (match-beginning 0) 0)
(equal ?. (aref s (max (1- (match-beginning 0)) 0)))
(not (equal ?. (aref s (max (- (match-beginning 0) 2) 0)))))
;; 3.e5 or something like this.
(setq start (match-end 0)))
((or (> (- (match-end 1) (match-beginning 1)) 2)
;; (member (match-string 1 s)
;; '("arctan" "exp" "expm" "lnp" "log" "stir"))
)
;; function name, just advance
(setq start (match-end 0)))
(t
(setq start (match-beginning 0)
s (replace-match
(if (equal (match-string 2 s) "&")
(format "$%d" (org-letters-to-number (match-string 1 s)))
(format "@%d$%d"
(string-to-number (match-string 2 s))
(org-letters-to-number (match-string 1 s))))
t t s)))))
s))
(defun org-table-convert-refs-to-an (s)
"Convert spreadsheet references from to @7$28 to AB7.
Works for single references, but also for entire formulas and even the
full TBLFM line.
Leave the relative references unchanged."
(while (string-match "@\\([0-9]+\\)\\$\\([0-9]+\\)" s)
(setq s (replace-match
(format "%s%d"
(org-number-to-letters
(string-to-number (match-string 2 s)))
(string-to-number (match-string 1 s)))
t t s)))
(while (string-match "\\(^\\|[^0-9a-zA-Z]\\)\\$\\([1-9][0-9]*\\)" s)
(setq s (replace-match (concat "\\1"
(org-number-to-letters
(string-to-number (match-string 2 s))) "&")
t nil s)))
s)
(defun org-letters-to-number (s)
"Convert a base 26 number represented by letters into an integer.
For example: AB -> 28."
(let ((n 0))
(setq s (upcase s))
(while (> (length s) 0)
(setq n (+ (* n 26) (string-to-char s) (- ?A) 1)
s (substring s 1)))
n))
(defun org-number-to-letters (n)
"Convert an integer into a base 26 number represented by letters.
For example: 28 -> AB."
(let ((s ""))
(while (> n 0)
(setq s (concat (char-to-string (+ (mod (1- n) 26) ?A)) s)
n (/ (1- n) 26)))
s))
(defun org-table-time-string-to-seconds (s)
"Convert a time string into numerical duration in seconds.
S can be a string matching either -?HH:MM:SS or -?HH:MM.
If S is a string representing a number, keep this number."
(if (equal s "")
s
(let (hour minus min sec res)
(cond
((and (string-match "\\(-?\\)\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)" s))
(setq minus (< 0 (length (match-string 1 s)))
hour (string-to-number (match-string 2 s))
min (string-to-number (match-string 3 s))
sec (string-to-number (match-string 4 s)))
(if minus
(setq res (- (+ (* hour 3600) (* min 60) sec)))
(setq res (+ (* hour 3600) (* min 60) sec))))
((and (not (string-match org-ts-regexp-both s))
(string-match "\\(-?\\)\\([0-9]+\\):\\([0-9]+\\)" s))
(setq minus (< 0 (length (match-string 1 s)))
hour (string-to-number (match-string 2 s))
min (string-to-number (match-string 3 s)))
(if minus
(setq res (- (+ (* hour 3600) (* min 60))))
(setq res (+ (* hour 3600) (* min 60)))))
(t (setq res (string-to-number s))))
(number-to-string res))))
(defun org-table-time-seconds-to-string (secs &optional output-format)
"Convert a number of seconds to a time string.
If OUTPUT-FORMAT is non-nil, return a number of days, hours,
minutes or seconds."
(let* ((secs0 (abs secs))
(res
(cond ((eq output-format 'days)
(format "%.3f" (/ (float secs0) 86400)))
((eq output-format 'hours)
(format "%.2f" (/ (float secs0) 3600)))
((eq output-format 'minutes)
(format "%.1f" (/ (float secs0) 60)))
((eq output-format 'seconds)
(format "%d" secs0))
((eq output-format 'hh:mm)
;; Ignore seconds
(substring (format-seconds
(if org-table-duration-hour-zero-padding
"%.2h:%.2m:%.2s" "%h:%.2m:%.2s")
secs0)
0 -3))
(t (format-seconds
(if org-table-duration-hour-zero-padding
"%.2h:%.2m:%.2s" "%h:%.2m:%.2s")
secs0)))))
(if (< secs 0) (concat "-" res) res)))
(defun org-table-fedit-convert-buffer (function)
"Convert all references in this buffer, using FUNCTION."
(let ((origin (copy-marker (line-beginning-position))))
(goto-char (point-min))
(while (not (eobp))
(insert (funcall function (buffer-substring (point) (line-end-position))))
(delete-region (point) (line-end-position))
(forward-line))
(goto-char origin)
(set-marker origin nil)))
(defun org-table-fedit-toggle-ref-type ()
"Convert all references in the buffer from B3 to @3$2 and back."
(interactive)
(setq-local org-table-buffer-is-an (not org-table-buffer-is-an))
(org-table-fedit-convert-buffer
(if org-table-buffer-is-an
'org-table-convert-refs-to-an 'org-table-convert-refs-to-rc))
(message "Reference type switched to %s"
(if org-table-buffer-is-an "A1 etc" "@row$column")))
(defun org-table-fedit-ref-up ()
"Shift the reference at point one row/hline up."
(interactive)
(org-table-fedit-shift-reference 'up))
(defun org-table-fedit-ref-down ()
"Shift the reference at point one row/hline down."
(interactive)
(org-table-fedit-shift-reference 'down))
(defun org-table-fedit-ref-left ()
"Shift the reference at point one field to the left."
(interactive)
(org-table-fedit-shift-reference 'left))
(defun org-table-fedit-ref-right ()
"Shift the reference at point one field to the right."
(interactive)
(org-table-fedit-shift-reference 'right))
(defun org-table--rematch-and-replace (n &optional decr hline)
"Re-match the group N, and replace it with the shifted reference."
(or (match-end n) (user-error "Cannot shift reference in this direction"))
(goto-char (match-beginning n))
(and (looking-at (regexp-quote (match-string n)))
(replace-match (org-table-shift-refpart (match-string 0) decr hline)
t t)))
(defun org-table-fedit-shift-reference (dir)
(cond
((org-in-regexp "\\(\\<[a-zA-Z]\\)&")
(if (memq dir '(left right))
(org-table--rematch-and-replace 1 (eq dir 'left))
(user-error "Cannot shift reference in this direction")))
((org-in-regexp "\\(\\<[a-zA-Z]\\{1,2\\}\\)\\([0-9]+\\)")
;; A B3-like reference
(if (memq dir '(up down))
(org-table--rematch-and-replace 2 (eq dir 'up))
(org-table--rematch-and-replace 1 (eq dir 'left))))
((org-in-regexp
"\\(@\\|\\.\\.\\)\\([-+]?\\(I+\\>\\|[0-9]+\\)\\)\\(\\$\\([-+]?[0-9]+\\)\\)?")
;; An internal reference
(if (memq dir '(up down))
(org-table--rematch-and-replace 2 (eq dir 'up) (match-end 3))
(org-table--rematch-and-replace 5 (eq dir 'left))))))
(defun org-table-shift-refpart (ref &optional decr hline)
"Shift a reference part REF.
If DECR is set, decrease the references row/column, else increase.
If HLINE is set, this may be a hline reference, it certainly is not
a translation reference."
(save-match-data
(let* ((sign (string-match "^[-+]" ref)) n)
(if sign (setq sign (substring ref 0 1) ref (substring ref 1)))
(cond
((and hline (string-match "^I+" ref))
(setq n (string-to-number (concat sign (number-to-string (length ref)))))
(setq n (+ n (if decr -1 1)))
(if (= n 0) (setq n (+ n (if decr -1 1))))
(if sign
(setq sign (if (< n 0) "-" "+") n (abs n))
(setq n (max 1 n)))
(concat sign (make-string n ?I)))
((string-match "^[0-9]+" ref)
(setq n (string-to-number (concat sign ref)))
(setq n (+ n (if decr -1 1)))
(if sign
(concat (if (< n 0) "-" "+") (number-to-string (abs n)))
(number-to-string (max 1 n))))
((string-match "^[a-zA-Z]+" ref)
(org-number-to-letters
(max 1 (+ (org-letters-to-number ref) (if decr -1 1)))))
(t (user-error "Cannot shift reference"))))))
(defun org-table-fedit-toggle-coordinates ()
"Toggle the display of coordinates in the referenced table."
(interactive)
(let ((pos (marker-position org-pos)))
(with-current-buffer (marker-buffer org-pos)
(save-excursion
(goto-char pos)
(org-table-toggle-coordinate-overlays)))))
(defun org-table-fedit-finish (&optional arg)
"Parse the buffer for formula definitions and install them.
With prefix ARG, apply the new formulas to the table."
(interactive "P")
(org-table-remove-rectangle-highlight)
(when org-table-use-standard-references
(org-table-fedit-convert-buffer 'org-table-convert-refs-to-rc)
(setq org-table-buffer-is-an nil))
(let ((pos org-pos)
(sel-win org-selected-window)
(source org-table--fedit-source)
eql)
(goto-char (point-min))
(while (re-search-forward
"^\\(@[-+I<>0-9.$@]+\\|@?[0-9]+\\|\\$\\([a-zA-Z0-9]+\\|[<>]+\\)\\) *= *\\(.*\\(\n[ \t]+.*$\\)*\\)"
nil t)
(let ((var (match-string 1))
(form (org-trim (match-string 3))))
(unless (equal form "")
(while (string-match "[ \t]*\n[ \t]*" form)
(setq form (replace-match " " t t form)))
(when (assoc var eql)
(user-error "Double formulas for %s" var))
(push (cons var form) eql))))
(set-window-configuration org-window-configuration)
(select-window sel-win)
(goto-char source)
(org-table-store-formulas eql)
(set-marker pos nil)
(set-marker source nil)
(when-let* ((window (get-buffer-window "*Edit Formulas*" t)))
(quit-window 'kill window))
(when (get-buffer "*Edit Formulas*") (kill-buffer "*Edit Formulas*"))
(if arg
(org-table-recalculate 'all)
(message "New formulas installed - press C-u C-c C-c to apply."))))
(defun org-table-fedit-abort ()
"Abort editing formulas, without installing the changes."
(interactive)
(org-table-remove-rectangle-highlight)
(let ((pos org-pos) (sel-win org-selected-window))
(set-window-configuration org-window-configuration)
(select-window sel-win)
(goto-char pos)
(move-marker pos nil)
(message "Formula editing aborted without installing changes")))
(defun org-table-fedit-lisp-indent ()
"Pretty-print and re-indent Lisp expressions in the Formula Editor."
(interactive)
(let ((pos (point)) beg end ind)
(forward-line 0)
(cond
((looking-at "[ \t]")
(goto-char pos)
(call-interactively 'lisp-indent-line))
((looking-at "[$&@0-9a-zA-Z]+ *= *[^ \t\n']") (goto-char pos))
((looking-at "[$&@0-9a-zA-Z]+ *= *'(")
(goto-char (- (match-end 0) 2))
(setq beg (point))
(setq ind (make-string (current-column) ?\ ))
(condition-case nil (forward-sexp 1)
(error
(user-error "Cannot pretty-print Lisp expression: Unbalanced parenthesis")))
(setq end (point))
(save-restriction
(narrow-to-region beg end)
(if (eq last-command this-command)
(progn
(goto-char (point-min))
(setq this-command nil)
(while (re-search-forward "[ \t]*\n[ \t]*" nil t)
(replace-match " ")))
(pp-buffer)
(untabify (point-min) (point-max))
(goto-char (1+ (point-min)))
(while (re-search-forward "^." nil t)
(forward-line 0)
(insert ind))
(goto-char (point-max))
(org-delete-backward-char 1)))
(goto-char beg))
(t nil))))
(defun org-table-fedit-line-up ()
"Move cursor one line up in the window showing the table."
(interactive)
(org-table-fedit-move 'previous-line))
(defun org-table-fedit-line-down ()
"Move cursor one line down in the window showing the table."
(interactive)
(org-table-fedit-move 'next-line))
(defun org-table-fedit-move (command)
"Move the cursor in the window showing the table.
Use COMMAND to do the motion, repeat if necessary to end up in a data line."
(let ((org-table-allow-automatic-line-recalculation nil)
(pos org-pos) (win (selected-window)) p)
(select-window (get-buffer-window (marker-buffer org-pos)))
(setq p (point))
(call-interactively command)
(while (and (org-at-table-p)
(org-at-table-hline-p))
(call-interactively command))
(or (org-at-table-p) (goto-char p))
(move-marker pos (point))
(select-window win)))
(defun org-table-fedit-scroll (N)
(interactive "p")
(let ((other-window-scroll-buffer (marker-buffer org-pos)))
(scroll-other-window N)))
(defun org-table-fedit-scroll-down (N)
(interactive "p")
(org-table-fedit-scroll (- N)))
(defun org-table-add-rectangle-overlay (beg end &optional face)
"Add a new overlay."
(let ((ov (make-overlay beg end)))
(overlay-put ov 'face (or face 'secondary-selection))
(push ov org-table-rectangle-overlays)))
(defun org-table-highlight-rectangle (&optional beg end face)
"Highlight rectangular region in a table.
When buffer positions BEG and END are provided, use them to
delimit the region to highlight. Otherwise, refer to point. Use
FACE, when non-nil, for the highlight."
(let* ((beg (or beg (point)))
(end (or end (point)))
(b (min beg end))
(e (max beg end))
(start-coordinates
(save-excursion
(goto-char b)
(cons (line-beginning-position) (org-table-current-column))))
(end-coordinates
(save-excursion
(goto-char e)
(cons (line-beginning-position) (org-table-current-column)))))
(when (boundp 'org-show-positions)
(setq org-show-positions (cons b (cons e org-show-positions))))
(goto-char (car start-coordinates))
(let ((column-start (min (cdr start-coordinates) (cdr end-coordinates)))
(column-end (max (cdr start-coordinates) (cdr end-coordinates)))
(last-row (car end-coordinates)))
(while (<= (point) last-row)
(when (looking-at org-table-dataline-regexp)
(org-table-goto-column column-start)
(skip-chars-backward "^|\n")
(let ((p (point)))
(org-table-goto-column column-end)
(skip-chars-forward "^|\n")
(org-table-add-rectangle-overlay p (point) face)))
(forward-line)))
(goto-char (car start-coordinates)))
(add-hook 'before-change-functions #'org-table-remove-rectangle-highlight))
(defun org-table-remove-rectangle-highlight (&rest _ignore)
"Remove the rectangle overlays."
(unless org-inhibit-highlight-removal
(remove-hook 'before-change-functions 'org-table-remove-rectangle-highlight)
(mapc 'delete-overlay org-table-rectangle-overlays)
(setq org-table-rectangle-overlays nil)))
(defvar-local org-table-coordinate-overlays nil
"Collects the coordinate grid overlays, so that they can be removed.")
(put 'org-table-coordinate-overlays 'permanent-local t)
(defun org-table-overlay-coordinates ()
"Add overlays to the table at point, to show row/column coordinates."
(interactive)
(mapc 'delete-overlay org-table-coordinate-overlays)
(setq org-table-coordinate-overlays nil)
(save-excursion
(let ((id 0) (ih 0) hline eol str ov)
(goto-char (org-table-begin))
(while (org-at-table-p)
(setq eol (line-end-position))
(setq ov (make-overlay (line-beginning-position)
(1+ (line-beginning-position))))
(push ov org-table-coordinate-overlays)
(setq hline (looking-at org-table-hline-regexp))
(setq str (if hline (format "I*%-2d" (setq ih (1+ ih)))
(format "%4d" (setq id (1+ id)))))
(org-overlay-before-string ov str 'org-special-keyword 'evaporate)
(when hline
(let ((ic 0))
(while (re-search-forward "[+|]\\(-+\\)" eol t)
(cl-incf ic)
(let* ((beg (1+ (match-beginning 0)))
(s1 (format "$%d" ic))
(s2 (org-number-to-letters ic))
(str (if (eq t org-table-use-standard-references) s2 s1))
(ov (make-overlay beg (+ beg (length str)))))
(push ov org-table-coordinate-overlays)
(org-overlay-display ov str 'org-special-keyword 'evaporate)))))
(forward-line)))))
;;;###autoload
(defun org-table-toggle-coordinate-overlays ()
"Toggle the display of Row/Column numbers in tables."
(interactive)
(if (not (org-at-table-p))
(user-error "Not on a table")
(setq org-table-overlay-coordinates (not org-table-overlay-coordinates))
(when (and (org-at-table-p) org-table-overlay-coordinates)
(org-table-align))
(unless org-table-overlay-coordinates
(mapc 'delete-overlay org-table-coordinate-overlays)
(setq org-table-coordinate-overlays nil))
(message "Tables Row/Column numbers display turned %s"
(if org-table-overlay-coordinates "on" "off"))))
;;;###autoload
(defun org-table-toggle-formula-debugger ()
"Toggle the formula debugger in tables."
(interactive)
(setq org-table-formula-debug (not org-table-formula-debug))
(message "Formula debugging has been turned %s"
(if org-table-formula-debug "on" "off")))
;;; Columns Shrinking
(defun org-table--shrunk-field ()
"Non-nil if current field is narrowed.
When non-nil, return the overlay narrowing the field."
(cl-some (lambda (o)
(and (eq 'table-column-hide (overlay-get o 'org-overlay-type))
o))
(overlays-at (save-excursion
(skip-chars-forward (if (org-at-table-hline-p) "^+|"
"^|")
(line-end-position))
(1- (point))))))
(defun org-table--list-shrunk-columns ()
"List currently shrunk columns in table at point."
(save-excursion
;; We really check shrunk columns in current row only. It could
;; be wrong if all rows do not contain the same number of columns
;; (i.e. the table is not properly aligned). As a consequence,
;; some columns may not be shrunk again upon aligning the table.
;;
;; For example, in the following table, cursor is on first row and
;; "<>" indicates a shrunk column.
;;
;; | |
;; | | <> |
;;
;; Aligning table from the first row will not shrink again the
;; second row, which was not visible initially.
;;
;; However, fixing it requires checking every row, which may be
;; slow on large tables. Moreover, the hindrance of this
;; pathological case is very limited.
(forward-line 0)
(search-forward "|")
(let ((separator (if (org-at-table-hline-p) "+" "|"))
(column 1)
(shrunk (and (org-table--shrunk-field) (list 1)))
(end (line-end-position)))
(while (search-forward separator end t)
(cl-incf column)
(when (org-table--shrunk-field) (push column shrunk)))
(nreverse shrunk))))
(defun org-table--make-shrinking-overlay (start end display field &optional pre)
"Create an overlay to shrink text between START and END.
Use string DISPLAY instead of the real text between the two
buffer positions. FIELD is the real contents of the field, as
a string, or nil. It is meant to be displayed upon moving the
mouse onto the overlay.
When optional argument PRE is non-nil, assume the overlay is
located at the beginning of the field, and prepend
`org-table--separator-space-pre' to it. Otherwise, concatenate
`org-table-shrunk-column-indicator' at its end.
Return the overlay."
(let ((show-before-edit
(lambda (o &rest _)
;; Removing one overlay removes all other overlays in the
;; same column.
(mapc #'delete-overlay
(cdr (overlay-get o 'org-table-column-overlays)))))
(o (make-overlay start end)))
(overlay-put o 'insert-behind-hooks (list show-before-edit))
(overlay-put o 'insert-in-front-hooks (list show-before-edit))
(overlay-put o 'modification-hooks (list show-before-edit))
(overlay-put o 'org-overlay-type 'table-column-hide)
(when (stringp field) (overlay-put o 'help-echo field))
;; Make sure overlays stays on top of table coordinates overlays.
;; See `org-table-overlay-coordinates'.
(overlay-put o 'priority 1)
(let ((d (if pre (concat org-table--separator-space-pre display)
(concat display org-table-shrunk-column-indicator))))
(org-overlay-display o d 'org-table t))
o))
(defun org-table--shrink-field (width align start end contents)
"Shrink a table field to a specified width.
WIDTH is an integer representing the number of characters to
display, in addition to `org-table-shrunk-column-indicator'.
ALIGN is the alignment of the current column, as either \"l\",
\"c\" or \"r\". START and END are, respectively, the beginning
and ending positions of the field. CONTENTS is its trimmed
contents, as a string, or `hline' for table rules.
Real field is hidden under one or two overlays. They have the
following properties:
`org-overlay-type'
Set to `table-column-hide'. Used to identify overlays
responsible for shrinking columns in a table.
`org-table-column-overlays'
It is a list with the pattern (siblings . COLUMN-OVERLAYS)
where COLUMN-OVERLAYS is the list of all overlays hiding the
same column.
Whenever the text behind or next to the overlay is modified, all
the overlays in the column are deleted, effectively displaying
the column again.
Return a list of overlays hiding the field, or nil if field is
already hidden."
(cond
((= start end) nil) ;no field to narrow
((org-table--shrunk-field) nil) ;already shrunk
((= 0 width) ;shrink to one character
(list (org-table--make-shrinking-overlay
start end "" (if (eq 'hline contents) "" contents))))
((eq contents 'hline)
(list (org-table--make-shrinking-overlay
start end (make-string (1+ width) ?-) "")))
((equal contents "") ;no contents to hide
(list
(let ((w (org-string-width (buffer-substring start end) nil 'org-table))
;; We really want WIDTH + 2 whitespace, to include blanks
;; around fields.
(full (+ 2 width)))
(if (<= w full)
(org-table--make-shrinking-overlay
(1- end) end (make-string (- full w) ?\s) "")
(org-table--make-shrinking-overlay (- end (- w full) 1) end "" "")))))
(t
;; If the field is not empty, display exactly WIDTH characters.
;; It can mean to partly hide the field, or extend it with virtual
;; blanks. To that effect, we use one or two overlays. The
;; first, optional, one may add or hide white spaces before the
;; contents of the field. The other, mandatory, one cuts the
;; field or displays white spaces at the end of the field. It
;; also always displays `org-table-shrunk-column-indicator'.
(let* ((lead (org-with-point-at start (skip-chars-forward " ")))
(trail (org-with-point-at end (abs (skip-chars-backward " "))))
(contents-width (org-string-width
(buffer-substring (+ start lead) (- end trail))
nil 'org-table)))
(cond
;; Contents are too large to fit in WIDTH character. Limit, if
;; possible, blanks at the beginning of the field to a single
;; white space, and cut the field at an appropriate location.
((<= width contents-width)
(let ((pre
(and (> lead 0)
(org-table--make-shrinking-overlay
start (+ start lead) "" contents t)))
(post
(org-table--make-shrinking-overlay
;; Find cut location so that WIDTH characters are
;; visible using dichotomy.
(let* ((begin (+ start lead))
(lower begin)
(upper (1- end))
;; Compensate the absence of leading space,
;; thus preserving alignment.
(width (if (= lead 0) (1+ width) width)))
(catch :exit
(while (> (- upper lower) 1)
(let ((mean (+ (ash lower -1)
(ash upper -1)
(logand lower upper 1))))
(pcase (org-string-width (buffer-substring begin mean) nil 'org-table)
((pred (= width)) (throw :exit mean))
((pred (< width)) (setq upper mean))
(_ (setq lower mean)))))
upper))
end "" contents)))
(if pre (list pre post) (list post))))
;; Contents fit it WIDTH characters. First compute number of
;; white spaces needed on each side of contents, then expand or
;; compact blanks on each side of the field in order to
;; preserve width and obey to alignment constraints.
(t
(let* ((required (- width contents-width))
(before
(pcase align
;; Compensate the absence of leading space, thus
;; preserving alignment.
((guard (= lead 0)) -1)
("l" 0)
("r" required)
("c" (/ required 2))))
(after (- required before))
(pre
(pcase (1- lead)
((or (guard (= lead 0)) (pred (= before))) nil)
((pred (< before))
(org-table--make-shrinking-overlay
start (+ start (- lead before)) "" contents t))
(_
(org-table--make-shrinking-overlay
start (1+ start)
(make-string (- before (1- lead)) ?\s)
contents t))))
(post
(pcase (1- trail)
((pred (= after))
(org-table--make-shrinking-overlay (1- end) end "" contents))
((pred (< after))
(org-table--make-shrinking-overlay
(+ after (- end trail)) end "" contents))
(_
(org-table--make-shrinking-overlay
(1- end) end
(make-string (- after (1- trail)) ?\s)
contents)))))
(if pre (list pre post) (list post)))))))))
(defun org-table--read-column-selection (select max)
"Read column selection select as a list of numbers.
SELECT is a string containing column ranges, separated by white
space characters, see `org-table-toggle-column-width' for details.
MAX is the maximum column number.
Return value is a sorted list of numbers. Ignore any number
outside of the [1;MAX] range."
(catch :all
(sort
(delete-dups
(cl-mapcan
(lambda (s)
(cond
((member s '("-" "1-")) (throw :all (number-sequence 1 max)))
((string-match-p "\\`[0-9]+\\'" s)
(let ((n (string-to-number s)))
(and (> n 0) (<= n max) (list n))))
((string-match "\\`\\([0-9]+\\)?-\\([0-9]+\\)?\\'" s)
(let ((n (match-string 1 s))
(m (match-string 2 s)))
(number-sequence (if n (max 1 (string-to-number n))
1)
(if m (min max (string-to-number m))
max))))
(t nil))) ;invalid specification
(split-string select)))
#'<)))
(defun org-table--shrink-columns (columns beg end)
"Shrink COLUMNS in a table.
COLUMNS is a sorted list of column numbers. BEG and END are,
respectively, the beginning position and the end position of the
table."
(org-with-wide-buffer
(font-lock-ensure beg end)
(dolist (c columns)
(goto-char beg)
(let ((align nil)
(width nil)
(fields nil))
(while (< (point) end)
(catch :continue
(let* ((hline? (org-at-table-hline-p))
(separator (if hline? "+" "|")))
;; Move to COLUMN.
(search-forward "|")
(or (= c 1) ;already there
(search-forward separator (line-end-position) t (1- c))
(throw :continue nil)) ;skip invalid columns
;; Extract boundaries and contents from current field.
;; Also set the column's width if we encounter a width
;; cookie for the first time.
(let* ((start (point))
(end (progn
(skip-chars-forward (concat "^|" separator)
(line-end-position))
(point)))
(contents (if hline? 'hline
(org-trim (buffer-substring start end)))))
(push (list start end contents) fields)
(when (and (not hline?)
(string-match "\\`<\\([lrc]\\)?\\([0-9]+\\)>\\'"
contents))
(unless align (setq align (match-string 1 contents)))
(unless width
(setq width (string-to-number (match-string 2 contents))))))))
(forward-line))
;; Link overlays for current field to the other overlays in the
;; same column.
(let ((chain (list 'siblings)))
(dolist (field fields)
(dolist (new (apply #'org-table--shrink-field
(or width 0) (or align "l") field))
(push new (cdr chain))
(overlay-put new 'org-table-column-overlays chain))))))))
;;;###autoload
(defun org-table-toggle-column-width (&optional arg)
"Shrink or expand current column in an Org table.
If a width cookie specifies a width W for the column, the first
W visible characters are displayed. Otherwise, the column is
shrunk to a single character.
When point is before the first column or after the last one, ask
for the columns to shrink or expand, as a list of ranges.
A column range can be one of the following patterns:
N column N only
N-M every column between N and M (both inclusive)
N- every column between N (inclusive) and the last column
-M every column between the first one and M (inclusive)
- every column
When optional argument ARG is a string, use it as white space
separated list of column ranges.
When called with `\\[universal-argument]' prefix, call \
`org-table-shrink', i.e.,
shrink columns with a width cookie and expand the others.
When called with `\\[universal-argument] \\[universal-argument]' \
prefix, expand all columns."
(interactive "P")
(unless (org-at-table-p) (user-error "Not in a table"))
(let* ((begin (org-table-begin))
(end (org-table-end))
;; Compute an upper bound for the number of columns.
;; Nonexistent columns are ignored anyway.
(max-columns (/ (- (line-end-position) (line-beginning-position)) 2))
(shrunk (org-table--list-shrunk-columns))
(columns
(pcase arg
(`nil
(if (save-excursion
(skip-chars-backward "^|" (line-beginning-position))
(or (bolp) (looking-at-p "[ \t]*$")))
;; Point is either before first column or past last
;; one. Ask for columns to operate on.
(org-table--read-column-selection
(read-string "Column ranges (e.g. 2-4 6-): ")
max-columns)
(list (org-table-current-column))))
((pred stringp) (org-table--read-column-selection arg max-columns))
((or `(4) `(16)) nil)
(_ (user-error "Invalid argument: %S" arg)))))
(pcase arg
(`(4) (org-table-shrink begin end))
(`(16) (org-table-expand begin end))
(_
(org-table-expand begin end)
(org-table--shrink-columns
(cl-set-exclusive-or columns shrunk) begin end)))))
;;;###autoload
(defun org-table-shrink (&optional begin end)
"Shrink all columns with a width cookie in the table at point.
Columns without a width cookie are expanded.
Optional arguments BEGIN and END, when non-nil, specify the
beginning and end position of the current table."
(interactive)
(unless (or begin (org-at-table-p)) (user-error "Not at a table"))
(org-with-wide-buffer
(let ((begin (or begin (org-table-begin)))
(end (or end (org-table-end)))
(regexp "|[ \t]*<[lrc]?[0-9]+>[ \t]*\\(|\\|$\\)")
(columns))
(goto-char begin)
(while (re-search-forward regexp end t)
(goto-char (match-beginning 1))
(cl-pushnew (org-table-current-column) columns))
(org-table-expand begin end)
;; Make sure invisible characters in the table are at the right
;; place since column widths take them into account.
(font-lock-ensure begin end)
(org-table--shrink-columns (sort columns #'<) begin end))))
;;;###autoload
(defun org-table-expand (&optional begin end)
"Expand all columns in the table at point.
Optional arguments BEGIN and END, when non-nil, specify the
beginning and end position of the current table."
(interactive)
(unless (or begin (org-at-table-p)) (user-error "Not at a table"))
(org-with-wide-buffer
(let ((begin (or begin (org-table-begin)))
(end (or end (org-table-end))))
(remove-overlays begin end 'org-overlay-type 'table-column-hide))))
;;; Generic Tools
;;;###autoload
(defun org-table-map-tables (f &optional quietly)
"Apply function F to the start of all tables in the buffer."
(org-with-point-at 1
(while (re-search-forward org-table-line-regexp nil t)
(let ((table (org-element-lineage (org-element-at-point) 'table t)))
(when table
(unless quietly
(message "Mapping tables: %d%%"
(floor (* 100.0 (point)) (buffer-size))))
(goto-char (org-element-post-affiliated table))
(let ((end (copy-marker (org-element-end table))))
(unwind-protect
(progn (funcall f) (goto-char end))
(set-marker end nil)))))))
(unless quietly (message "Mapping tables: done")))
;;;###autoload
(defun org-table-export (&optional file format)
"Export table to a file, with configurable format.
Such a file can be imported into usual spreadsheet programs.
FILE can be the output file name. If not given, it will be taken
from a TABLE_EXPORT_FILE property in the current entry or higher
up in the hierarchy, or the user will be prompted for a file
name. FORMAT can be an export format, of the same kind as it
used when `-mode' sends a table in a different format.
The command suggests a format depending on TABLE_EXPORT_FORMAT,
whether it is set locally or up in the hierarchy, then on the
extension of the given file name, and finally on the variable
`org-table-export-default-format'."
(interactive)
(unless (org-at-table-p) (user-error "No table at point"))
(org-table-align) ; Make sure we have everything we need.
(let ((file (or file (org-entry-get (point) "TABLE_EXPORT_FILE" t))))
(unless file
(setq file (read-file-name "Export table to: "))
(unless (or (not (file-exists-p file))
(y-or-n-p (format "Overwrite file %s? " file)))
(user-error "File not written")))
(when (file-directory-p file)
(user-error "This is a directory path, not a file"))
(when (and (buffer-file-name (buffer-base-buffer))
(file-equal-p
(file-truename file)
(file-truename (buffer-file-name (buffer-base-buffer)))))
(user-error "Please specify a file name that is different from current"))
(let ((fileext (concat (file-name-extension file) "$"))
(format (or format (org-entry-get (point) "TABLE_EXPORT_FORMAT" t))))
(unless format
(let* ((formats '("orgtbl-to-tsv" "orgtbl-to-csv" "orgtbl-to-latex"
"orgtbl-to-html" "orgtbl-to-generic"
"orgtbl-to-texinfo" "orgtbl-to-orgtbl"
"orgtbl-to-unicode"))
(deffmt-readable
(replace-regexp-in-string
"\t" "\\t"
(replace-regexp-in-string
"\n" "\\n"
(or (car (delq nil
(mapcar
(lambda (f)
(and (string-match-p fileext f) f))
formats)))
org-table-export-default-format)
t t)
t t)))
(setq format
(org-completing-read
"Format: " formats nil nil deffmt-readable))))
(if (string-match "\\([^ \t\r\n]+\\)\\( +.*\\)?" format)
(let ((transform (intern (match-string 1 format)))
(params (and (match-end 2)
(read (concat "(" (match-string 2 format) ")"))))
(table (org-table-to-lisp)))
(unless (fboundp transform)
(user-error "No such transformation function %s" transform))
(with-temp-file file
(insert (funcall transform table params) "\n"))
(message "Export done."))
(user-error "TABLE_EXPORT_FORMAT invalid")))))
;;;###autoload
(defun org-table--align-field (field width align)
"Format FIELD according to column WIDTH and alignment ALIGN.
FIELD is a string. WIDTH is a number. ALIGN is either \"c\",
\"l\" or\"r\"."
(let* ((spaces (- width (org-string-width field nil 'org-table)))
(prefix (pcase align
("l" "")
("r" (make-string spaces ?\s))
("c" (make-string (/ spaces 2) ?\s))))
(suffix (make-string (- spaces (length prefix)) ?\s)))
(concat org-table--separator-space-pre
prefix
field
suffix
org-table--separator-space-post)))
(defun org-table-align ()
"Align the table at point by aligning all vertical bars."
(interactive)
(let ((beg (org-table-begin))
(end (copy-marker (org-table-end))))
(org-table-save-field
;; Make sure invisible characters in the table are at the right
;; place since column widths take them into account.
(font-lock-ensure beg end)
(move-marker org-table-aligned-begin-marker beg)
(move-marker org-table-aligned-end-marker end)
(goto-char beg)
(org-table-with-shrunk-columns
(let* ((table (org-table-to-lisp))
(rows (remq 'hline table))
(widths nil)
(alignments nil)
(columns-number 1))
(if (null rows)
;; Table contains only horizontal rules. Compute the
;; number of columns anyway, and choose an arbitrary width
;; and alignment.
(let ((end (line-end-position)))
(save-excursion
(while (search-forward "+" end t)
(cl-incf columns-number)))
(setq widths (make-list columns-number 1))
(setq alignments (make-list columns-number "l")))
;; Compute alignment and width for each column.
(setq columns-number (apply #'max (mapcar #'length rows)))
(dotimes (i columns-number)
(let ((max-width 1)
(fixed-align? nil)
(numbers 0)
(non-empty 0))
(dolist (row rows)
(let ((cell (or (nth i row) "")))
(setq max-width (max max-width (org-string-width cell nil 'org-table)))
(cond (fixed-align? nil)
((equal cell "") nil)
((string-match "\\`<\\([lrc]\\)[0-9]*>\\'" cell)
(setq fixed-align? (match-string 1 cell)))
(t
(cl-incf non-empty)
(when (string-match-p org-table-number-regexp cell)
(cl-incf numbers))))))
(push max-width widths)
(push (cond
(fixed-align?)
((>= numbers (* org-table-number-fraction non-empty)) "r")
(t "l"))
alignments)))
(setq widths (nreverse widths))
(setq alignments (nreverse alignments)))
;; Store alignment of this table, for later editing of single
;; fields.
(setq org-table-last-alignment alignments)
(setq org-table-last-column-widths widths)
;; Build new table rows. Only replace rows that actually
;; changed.
(let ((rule (and (memq 'hline table)
(mapconcat (lambda (w) (make-string (+ 2 w) ?-))
widths
"+")))
(indent (progn (looking-at "[ \t]*|") (match-string 0))))
(dolist (row table)
(let ((previous (buffer-substring (point) (line-end-position)))
(new
(concat indent
(if (eq row 'hline) rule
(let* ((offset (- columns-number (length row)))
(fields (if (= 0 offset) row
;; Add missing fields.
(append row
(make-list offset "")))))
(mapconcat #'identity
(cl-mapcar #'org-table--align-field
fields
widths
alignments)
"|")))
"|")))
(if (equal new previous)
(forward-line)
(insert new "\n")
(delete-region (point) (line-beginning-position 2))))))
(set-marker end nil)
(when org-table-overlay-coordinates (org-table-overlay-coordinates))
(setq org-table-may-need-update nil))))))
;;;###autoload
(defun org-table-justify-field-maybe (&optional new)
"Justify the current field, text to left, number to right.
Optional argument NEW may specify text to replace the current field content."
;; FIXME: Prevent newlines inside field. They are currently not
;; supported.
(when (and (stringp new) (string-match-p "\n" new))
(message "Removing newlines from formula result: %S" new)
(setq new (replace-regexp-in-string
"\n" " "
(replace-regexp-in-string "\\(^\n+\\)\\|\\(\n+$\\)" "" new))))
(cond
((and (not new) org-table-may-need-update)) ; Realignment will happen anyway
((org-at-table-hline-p))
(t
(when (or (not (eq (marker-buffer org-table-aligned-begin-marker)
(current-buffer)))
(< (point) org-table-aligned-begin-marker)
(>= (point) org-table-aligned-end-marker))
;; This is not the same table, force a full re-align.
(setq org-table-may-need-update t
org-table-last-alignment nil
org-table-last-column-widths nil))
(when new
;; Realign the current field, based on previous full realign.
(let ((pos (point))
(col (org-table-current-column)))
(when (> col 0)
(skip-chars-backward "^|")
(if (not (looking-at " *\\(?:\\([^|\n]*?\\) *\\(|\\)\\|\\([^|\n]+?\\) *\\($\\)\\)"))
(setq org-table-may-need-update t)
(let* ((align (nth (1- col) org-table-last-alignment))
(width (nth (1- col) org-table-last-column-widths))
(cell (match-string 0))
(field (match-string 1))
(properly-closed? (/= (match-beginning 2) (match-end 2)))
(new-cell
(save-match-data
(cond (org-table-may-need-update
(format " %s |" (or new field)))
((not properly-closed?)
(setq org-table-may-need-update t)
(format " %s |" (or new field)))
((not new)
(concat (org-table--align-field field width align)
"|"))
((and width (<= (org-string-width new nil 'org-table) width))
(concat (org-table--align-field new width align)
"|"))
(t
(setq org-table-may-need-update t)
(format " %s |" new))))))
(unless (equal new-cell cell)
(let (org-table-may-need-update)
(replace-match new-cell t t)))
(goto-char pos)))))))))
;;;###autoload
(defun org-table-sort-lines
(&optional with-case sorting-type getkey-func compare-func interactive?)
"Sort table lines according to the column at point.
The position of point indicates the column to be used for
sorting, and the range of lines is the range between the nearest
horizontal separator lines, or the entire table of no such lines
exist. If point is before the first column, you will be prompted
for the sorting column. If there is an active region, the mark
specifies the first line and the sorting column, while point
should be in the last line to be included into the sorting.
The command then prompts for the sorting type which can be
alphabetically, numerically, or by time (as given in a time stamp
in the field, or as a HH:MM value). Sorting in reverse order is
also possible.
With prefix argument WITH-CASE, alphabetic sorting will be case-sensitive
if the locale allows for it.
If SORTING-TYPE is specified when this function is called from a Lisp
program, no prompting will take place. SORTING-TYPE must be a character,
any of (?a ?A ?n ?N ?t ?T ?f ?F) where the capital letters indicate that
sorting should be done in reverse order.
If the SORTING-TYPE is ?f or ?F, then GETKEY-FUNC specifies
a function to be called to extract the key. It must return a value
that is compatible with COMPARE-FUNC, the function used to compare
entries.
A non-nil value for INTERACTIVE? is used to signal that this
function is being called interactively."
(interactive (list current-prefix-arg nil nil nil t))
(when (org-region-active-p) (goto-char (region-beginning)))
;; Point must be either within a field or before a data line.
(save-excursion
(skip-chars-backward " \t")
(when (bolp) (search-forward "|" (line-end-position) t))
(org-table-check-inside-data-field))
;; Set appropriate case sensitivity and column used for sorting.
(let ((column (let ((c (org-table-current-column)))
(cond ((> c 0) c)
(interactive?
(read-number "Use column N for sorting: "))
(t 1))))
(sorting-type
(or sorting-type
(read-char-exclusive "Sort Table: [a]lphabetic, [n]umeric, \
\[t]ime, [f]unc. A/N/T/F means reversed: ")))
(start (org-table-begin))
(end (org-table-end)))
(save-restriction
;; Narrow buffer to appropriate sorting area.
(if (org-region-active-p)
(progn (goto-char (region-beginning))
(narrow-to-region
(point)
(save-excursion (goto-char (region-end))
(line-beginning-position 2))))
(narrow-to-region
(save-excursion
(if (re-search-backward org-table-hline-regexp start t)
(line-beginning-position 2)
start))
(if (save-excursion (re-search-forward org-table-hline-regexp end t))
(match-beginning 0)
end)))
;; Determine arguments for `sort-subr'. Also record original
;; position. `org-table-save-field' cannot help here since
;; sorting is too much destructive.
(let* ((coordinates
(cons (count-lines (point-min) (line-beginning-position))
(current-column)))
(extract-key-from-field
;; Function to be called on the contents of the field
;; used for sorting in the current row.
(cl-case sorting-type
((?n ?N) #'string-to-number)
((?a ?A) #'org-sort-remove-invisible)
((?t ?T)
(lambda (f)
(cond ((string-match org-ts-regexp-both f)
(float-time
(org-time-string-to-time (match-string 0 f))))
((org-duration-p f) (org-duration-to-minutes f))
((string-match "\\<[0-9]+:[0-9]\\{2\\}\\>" f)
(org-duration-to-minutes (match-string 0 f)))
(t 0))))
((?f ?F)
(or getkey-func
(and interactive?
(org-read-function "Function for extracting keys: "))
(error "Missing key extractor to sort rows")))
(t (user-error "Invalid sorting type `%c'" sorting-type))))
(predicate
(cl-case sorting-type
((?n ?N ?t ?T) #'<)
((?a ?A) (if with-case #'org-string<
(lambda (s1 s2) (org-string< s1 s2 nil t))))
((?f ?F)
(or compare-func
(and interactive?
(org-read-function
"Function for comparing keys (empty for default \
`sort-subr' predicate): "
'allow-empty))))))
(shrunk-columns (remq column (org-table--list-shrunk-columns))))
(goto-char (point-min))
(sort-subr (memq sorting-type '(?A ?N ?T ?F))
(lambda ()
(forward-line)
(while (and (not (eobp))
(not (looking-at org-table-dataline-regexp)))
(forward-line)))
#'end-of-line
(lambda ()
(funcall extract-key-from-field
(org-trim (org-table-get-field column))))
nil
predicate)
;; Hide all columns but the one being sorted.
(org-table--shrink-columns shrunk-columns start end)
;; Move back to initial field.
(forward-line (car coordinates))
(move-to-column (cdr coordinates))))))
(defun org-table-transpose-table-at-point ()
"Transpose Org table at point and eliminate hlines.
So a table like
| 1 | 2 | 4 | 5 |
|---+---+---+---|
| a | b | c | d |
| e | f | g | h |
will be transposed as
| 1 | a | e |
| 2 | b | f |
| 4 | c | g |
| 5 | d | h |
Note that horizontal lines disappear."
(interactive)
(let* ((table (delete 'hline (org-table-to-lisp)))
(dline_old (org-table-current-line))
(col_old (org-table-current-column))
(contents (mapcar (lambda (_)
(let ((tp table))
(mapcar
(lambda (_)
(prog1
(pop (car tp))
(setq tp (cdr tp))))
table)))
(car table))))
(goto-char (org-table-begin))
(re-search-forward "|")
(backward-char)
(delete-region (point) (org-table-end))
(insert (mapconcat
(lambda(x)
(concat "| " (mapconcat 'identity x " | " ) " |\n" ))
contents ""))
(org-table-goto-line col_old)
(org-table-goto-column dline_old))
(org-table-align))
;;;###autoload
(defun org-table-wrap-region (arg)
"Wrap several fields in a column like a paragraph.
This is useful if you'd like to spread the contents of a field over several
lines, in order to keep the table compact.
If there is an active region, and both point and mark are in the same column,
the text in the column is wrapped to minimum width for the given number of
lines. Generally, this makes the table more compact. A prefix ARG may be
used to change the number of desired lines. For example, \
`C-2 \\[org-table-wrap-region]'
formats the selected text to two lines. If the region was longer than two
lines, the remaining lines remain empty. A negative prefix argument reduces
the current number of lines by that amount. The wrapped text is pasted back
into the table. If you formatted it to more lines than it was before, fields
further down in the table get overwritten - so you might need to make space in
the table first.
If there is no region, the current field is split at the cursor position and
the text fragment to the right of the cursor is prepended to the field one
line down.
If there is no region, but you specify a prefix ARG, the current field gets
blank, and the content is appended to the field above."
(interactive "P")
(org-table-check-inside-data-field)
(if (org-region-active-p)
;; There is a region: fill as a paragraph.
(let ((start (region-beginning)))
(save-restriction
(narrow-to-region
(save-excursion (goto-char start) (move-beginning-of-line 1))
(save-excursion (org-forward-paragraph) (point)))
(org-table-cut-region (region-beginning) (region-end))
(when (> (length (car org-table-clip)) 1)
(user-error "Region must be limited to single column"))
(let ((nlines (cond ((not arg) (length org-table-clip))
((< arg 1) (+ (length org-table-clip) arg))
(t arg))))
(setq org-table-clip
(mapcar #'list
(org-wrap (mapconcat #'car org-table-clip " ")
nil
nlines))))
(goto-char start)
(org-table-paste-rectangle))
(org-table-align))
;; No region, split the current field at point.
(unless (org-get-alist-option org-M-RET-may-split-line 'table)
(skip-chars-forward "^\r\n|"))
(cond
(arg ; Combine with field above.
(let ((s (org-table-blank-field))
(col (org-table-current-column)))
(forward-line -1)
(while (org-at-table-hline-p) (forward-line -1))
(org-table-goto-column col)
(skip-chars-forward "^|")
(skip-chars-backward " ")
(insert " " (org-trim s))
(org-table-align)))
((looking-at "\\([^|]+\\)|") ; Split field.
(let ((s (match-string 1)))
(replace-match " |")
(goto-char (match-beginning 0))
(org-table-next-row)
(insert (org-trim s) " ")
(org-table-align)))
(t (org-table-next-row)))))
(defun org-table--number-for-summing (s)
(let (n)
(if (string-match "^ *|? *" s)
(setq s (replace-match "" nil nil s)))
(if (string-match " *|? *$" s)
(setq s (replace-match "" nil nil s)))
(setq n (string-to-number s))
(cond
((and (string-match "0" s)
(string-match "\\`[-+ \t0.edED]+\\'" s)) 0)
((string-match "\\`[ \t]+\\'" s) nil)
((string-match "\\`\\([0-9]+\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?\\'" s)
(let ((h (string-to-number (or (match-string 1 s) "0")))
(m (string-to-number (or (match-string 2 s) "0")))
(s (string-to-number (or (match-string 4 s) "0"))))
(if (boundp 'org-timecnt) (setq org-timecnt (1+ org-timecnt)))
(* 1.0 (+ h (/ m 60.0) (/ s 3600.0)))))
((equal n 0) nil)
(t n))))
;;;###autoload
(defun org-table-sum (&optional beg end nlast)
"Sum numbers in region of current table column.
The result will be displayed in the echo area, and will be available
as kill to be inserted with \\[yank].
If there is an active region, it is interpreted as a rectangle and all
numbers in that rectangle will be summed. If there is no active
region and point is located in a table column, sum all numbers in that
column.
If at least one number looks like a time HH:MM or HH:MM:SS, all other
numbers are assumed to be times as well (in decimal hours) and the
numbers are added as such.
If NLAST is a number, only the NLAST fields will actually be summed."
(interactive)
(save-excursion
(let (col (org-timecnt 0) diff h m s org-table-clip)
(cond
((and beg end)) ; beg and end given explicitly
((org-region-active-p)
(setq beg (region-beginning) end (region-end)))
(t
(setq col (org-table-current-column))
(goto-char (org-table-begin))
(unless (re-search-forward "^[ \t]*|[^-]" nil t)
(user-error "No table data"))
(org-table-goto-column col)
(setq beg (point))
(goto-char (org-table-end))
(unless (re-search-backward "^[ \t]*|[^-]" nil t)
(user-error "No table data"))
(org-table-goto-column col)
(setq end (point))))
(let* ((items (apply 'append (org-table-copy-region beg end)))
(items1 (cond ((not nlast) items)
((>= nlast (length items)) items)
(t (setq items (reverse items))
(setcdr (nthcdr (1- nlast) items) nil)
(nreverse items))))
(numbers (delq nil (mapcar #'org-table--number-for-summing
items1)))
(res (apply '+ numbers))
(sres (if (= org-timecnt 0)
(number-to-string res)
(setq diff (* 3600 res)
h (floor diff 3600) diff (mod diff 3600)
m (floor diff 60) diff (mod diff 60)
s diff)
(format "%.0f:%02.0f:%02.0f" h m s))))
(kill-new sres)
(when (called-interactively-p 'interactive)
(message (substitute-command-keys
(format "Sum of %d items: %-20s \
\(\\[yank] will insert result into buffer)"
(length numbers)
sres))))
sres))))
;;;###autoload
(defun org-table-analyze ()
"Analyze table at point and store results.
This function sets up the following dynamically scoped variables:
`org-table-column-name-regexp',
`org-table-column-names',
`org-table-current-begin-pos',
`org-table-current-line-types',
`org-table-current-ncol',
`org-table-dlines',
`org-table-hlines',
`org-table-local-parameters',
`org-table-named-field-locations'."
(let ((beg (org-table-begin))
(end (org-table-end)))
(save-excursion
(goto-char beg)
;; Extract column names.
(setq org-table-column-names nil)
(when (save-excursion
(re-search-forward "^[ \t]*| *! *\\(|.*\\)" end t))
(let ((c 1))
(dolist (name (org-split-string (match-string 1) " *| *"))
(cl-incf c)
(when (string-match "\\`[a-zA-Z][_a-zA-Z0-9]*\\'" name)
(push (cons name (number-to-string c)) org-table-column-names)))))
(setq org-table-column-names (nreverse org-table-column-names))
(setq org-table-column-name-regexp
(format "\\$\\(%s\\)\\>"
(regexp-opt (mapcar #'car org-table-column-names) t)))
;; Extract local parameters.
(setq org-table-local-parameters nil)
(save-excursion
(while (re-search-forward "^[ \t]*| *\\$ *\\(|.*\\)" end t)
(dolist (field (org-split-string (match-string 1) " *| *"))
(when (string-match
"\\`\\([a-zA-Z][_a-zA-Z0-9]*\\|%\\) *= *\\(.*\\)" field)
(push (cons (match-string 1 field) (match-string 2 field))
org-table-local-parameters)))))
;; Update named fields locations. We minimize `count-lines'
;; processing by storing last known number of lines in LAST.
(setq org-table-named-field-locations nil)
(save-excursion
(let ((last (cons (point) 0)))
(while (re-search-forward "^[ \t]*| *\\([_^]\\) *\\(|.*\\)" end t)
(let ((c (match-string 1))
(fields (org-split-string (match-string 2) " *| *")))
(save-excursion
(forward-line (if (equal c "_") 1 -1))
(let ((fields1
(and (looking-at "^[ \t]*|[^|]*\\(|.*\\)")
(org-split-string (match-string 1) " *| *")))
(line (cl-incf (cdr last) (count-lines (car last) (point))))
(col 1))
(setcar last (point)) ; Update last known position.
(while (and fields fields1)
(let ((field (pop fields))
(v (pop fields1)))
(cl-incf col)
(when (and (stringp field)
(stringp v)
(string-match "\\`[a-zA-Z][_a-zA-Z0-9]*\\'"
field))
(push (cons field v) org-table-local-parameters)
(push (list field line col)
org-table-named-field-locations))))))))))
;; Reuse existing markers when possible.
(if (markerp org-table-current-begin-pos)
(move-marker org-table-current-begin-pos (point))
(setq org-table-current-begin-pos (point-marker)))
;; Analyze the line types.
(let ((l 0) hlines dlines types)
(while (looking-at "[ \t]*|\\(-\\)?")
(push (if (match-end 1) 'hline 'dline) types)
(if (match-end 1) (push l hlines) (push l dlines))
(forward-line)
(cl-incf l))
(push 'hline types) ; Add an imaginary extra hline to the end.
(setq org-table-current-line-types (apply #'vector (nreverse types)))
(setq org-table-dlines (apply #'vector (cons nil (nreverse dlines))))
(setq org-table-hlines (apply #'vector (cons nil (nreverse hlines)))))
;; Get the number of columns from the first data line in table.
(goto-char beg)
(forward-line (aref org-table-dlines 1))
(setq org-table-current-ncol
(length (org-split-string
(buffer-substring (line-beginning-position) (line-end-position))
"[ \t]*|[ \t]*"))))))
(defun org-table--force-dataline ()
"Move point to the closest data line in a table.
Raise an error if the table contains no data line. Preserve
column when moving point."
(unless (org-match-line org-table-dataline-regexp)
(let* ((re org-table-dataline-regexp)
(column (current-column))
(p1 (save-excursion (re-search-forward re (org-table-end) t)))
(p2 (save-excursion (re-search-backward re (org-table-begin) t))))
(cond ((and p1 p2)
(goto-char (if (< (abs (- p1 (point))) (abs (- p2 (point))))
p1
p2)))
((or p1 p2) (goto-char (or p1 p2)))
(t (user-error "No table data line around here")))
(org-move-to-column column))))
(defun org-table-show-reference (&optional local)
"Show the location/value of the $ expression at point.
When LOCAL is non-nil, show references for the table at point."
(interactive)
(org-table-remove-rectangle-highlight)
(when local (org-table-analyze))
(catch 'exit
(let ((pos (if local (point) org-pos))
(face2 'highlight)
(org-inhibit-highlight-removal t)
(win (selected-window))
(org-show-positions nil)
var name e what match dest)
(setq what (cond
((org-in-regexp "^@[0-9]+[ \t=]")
(setq match (concat (substring (match-string 0) 0 -1)
"$1.."
(substring (match-string 0) 0 -1)
"$100"))
'range)
((or (org-in-regexp org-table-range-regexp2)
(org-in-regexp org-table-translate-regexp)
(org-in-regexp org-table-range-regexp))
(setq match
(save-match-data
(org-table-convert-refs-to-rc (match-string 0))))
'range)
((org-in-regexp "\\$[a-zA-Z][a-zA-Z0-9]*") 'name)
((org-in-regexp "\\$[0-9]+") 'column)
((not local) nil)
(t (user-error "No reference at point")))
match (and what (or match (match-string 0))))
(when (and match (not (equal (match-beginning 0) (line-beginning-position))))
(org-table-add-rectangle-overlay (match-beginning 0) (match-end 0)
'secondary-selection))
(add-hook 'before-change-functions
#'org-table-remove-rectangle-highlight)
(when (eq what 'name) (setq var (substring match 1)))
(when (eq what 'range)
(unless (eq (string-to-char match) ?@) (setq match (concat "@" match)))
(setq match (org-table-formula-substitute-names match)))
(unless local
(save-excursion
(end-of-line)
(re-search-backward "^\\S-" nil t)
(forward-line 0)
(when (looking-at "\\(\\$[0-9a-zA-Z]+\\|@[0-9]+\\$[0-9]+\\|[a-zA-Z]+\
\\([0-9]+\\|&\\)\\) *=")
(setq dest
(save-match-data
(org-table-convert-refs-to-rc (match-string 1))))
(org-table-add-rectangle-overlay
(match-beginning 1) (match-end 1) face2))))
(if (and (markerp pos) (marker-buffer pos))
(if (get-buffer-window (marker-buffer pos))
(select-window (get-buffer-window (marker-buffer pos)))
(switch-to-buffer-other-window (get-buffer-window
(marker-buffer pos)))))
(goto-char pos)
(org-table--force-dataline)
(let ((table-start
(if local org-table-current-begin-pos (org-table-begin))))
(when dest
(setq name (substring dest 1))
(cond
((string-match-p "\\`\\$[a-zA-Z][a-zA-Z0-9]*" dest)
(org-table-goto-field dest))
((string-match-p "\\`@\\([1-9][0-9]*\\)\\$\\([1-9][0-9]*\\)\\'"
dest)
(org-table-goto-field dest))
(t (org-table-goto-column (string-to-number name))))
(move-marker pos (point))
(org-table-highlight-rectangle nil nil face2))
(cond
((equal dest match))
((not match))
((eq what 'range)
(ignore-errors (org-table-get-range match table-start nil 'highlight)))
((setq e (assoc var org-table-named-field-locations))
(org-table-goto-field var)
(org-table-highlight-rectangle)
(message "Named field, column %d of line %d" (nth 2 e) (nth 1 e)))
((setq e (assoc var org-table-column-names))
(org-table-goto-column (string-to-number (cdr e)))
(org-table-highlight-rectangle)
(goto-char table-start)
(if (re-search-forward (concat "^[ \t]*| *! *.*?| *\\(" var "\\) *|")
(org-table-end) t)
(progn
(goto-char (match-beginning 1))
(org-table-highlight-rectangle)
(message "Named column (column %s)" (cdr e)))
(user-error "Column name not found")))
((eq what 'column)
;; Column number.
(org-table-goto-column (string-to-number (substring match 1)))
(org-table-highlight-rectangle)
(message "Column %s" (substring match 1)))
((setq e (assoc var org-table-local-parameters))
(goto-char table-start)
(if (re-search-forward (concat "^[ \t]*| *\\$ *.*?| *\\(" var "=\\)") nil t)
(progn
(goto-char (match-beginning 1))
(org-table-highlight-rectangle)
(message "Local parameter."))
(user-error "Parameter not found")))
((not var) (user-error "No reference at point"))
((setq e (assoc var org-table-formula-constants-local))
(message "Local Constant: $%s=%s in #+CONSTANTS line."
var (cdr e)))
((setq e (assoc var org-table-formula-constants))
(message "Constant: $%s=%s in `org-table-formula-constants'."
var (cdr e)))
((setq e (and (fboundp 'constants-get) (constants-get var)))
(message "Constant: $%s=%s, from `constants.el'%s."
var e (format " (%s units)" constants-unit-system)))
(t (user-error "Undefined name $%s" var)))
(goto-char pos)
(when (and org-show-positions
(not (memq this-command '(org-table-fedit-scroll
org-table-fedit-scroll-down))))
(push pos org-show-positions)
(push table-start org-show-positions)
(let ((min (apply 'min org-show-positions))
(max (apply 'max org-show-positions)))
(set-window-start (selected-window) min)
(goto-char max)
(or (pos-visible-in-window-p max)
(set-window-start (selected-window) max)))))
(select-window win))))
;;; The Orgtbl minor mode
;; Define a minor mode which can be used in other modes in order to
;; integrate the Org table editor.
;; This is really a hack, because the Org table editor uses several
;; keys which normally belong to the major mode, for example the TAB
;; and RET keys. Here is how it works: The minor mode defines all the
;; keys necessary to operate the table editor, but wraps the commands
;; into a function which tests if the cursor is currently inside
;; a table. If that is the case, the table editor command is
;; executed. However, when any of those keys is used outside a table,
;; the function uses `key-binding' to look up if the key has an
;; associated command in another currently active keymap (minor modes,
;; major mode, global), and executes that command. There might be
;; problems if any of the keys used by the table editor is otherwise
;; used as a prefix key.
;; Another challenge is that the key binding for TAB can be tab or \C-i,
;; likewise the binding for RET can be return or \C-m. Orgtbl-mode
;; addresses this by checking explicitly for both bindings.
;; The optimized version (see variable `orgtbl-optimized') takes over
;; all keys which are bound to `self-insert-command' in the *global map*.
;; Some modes bind other commands to simple characters, for example
;; AUCTeX binds the double quote to `Tex-insert-quote'. With orgtbl-mode
;; active, this binding is ignored inside tables and replaced with a
;; modified self-insert.
(defvar orgtbl-mode-map (make-keymap)
"Keymap for `orgtbl-mode'.")
(defvar org-old-auto-fill-inhibit-regexp nil
"Local variable used by `orgtbl-mode'.")
(defconst orgtbl-line-start-regexp
"[ \t]*\\(|\\|#\\+\\(tblfm\\|orgtbl\\|tblname\\):\\)"
"Matches a line belonging to an orgtbl.")
(defconst orgtbl-extra-font-lock-keywords
(list (list (concat "^" orgtbl-line-start-regexp ".*")
0 (quote 'org-table) 'prepend))
"Extra `font-lock-keywords' to be added when `orgtbl-mode' is active.")
;;;###autoload
(defun turn-on-orgtbl ()
"Unconditionally turn on `orgtbl-mode'."
(require 'org-table)
(orgtbl-mode 1))
;; Install it as a minor mode.
(put 'orgtbl-mode :included t)
(put 'orgtbl-mode :menu-tag "Org Table Mode")
(easy-menu-define orgtbl-mode-menu orgtbl-mode-map "OrgTbl menu."
'("OrgTbl"
["Create or convert" org-table-create-or-convert-from-region
:active (not (org-at-table-p)) :keys "C-c |" ]
"--"
["Align" org-ctrl-c-ctrl-c :active (org-at-table-p) :keys "C-c C-c"]
["Next Field" org-cycle :active (org-at-table-p) :keys "TAB"]
["Previous Field" org-shifttab :active (org-at-table-p) :keys "S-TAB"]
["Next Row" org-return :active (org-at-table-p) :keys "RET"]
"--"
["Blank Field" org-table-blank-field :active (org-at-table-p) :keys "C-c SPC"]
["Edit Field" org-table-edit-field :active (org-at-table-p) :keys "C-c ` "]
["Copy Field from Above"
org-table-copy-down :active (org-at-table-p) :keys "S-RET"]
"--"
("Column"
["Move Column Left" org-metaleft :active (org-at-table-p) :keys "M-<left>"]
["Move Column Right" org-metaright :active (org-at-table-p) :keys "M-<right>"]
["Delete Column" org-shiftmetaleft :active (org-at-table-p) :keys "M-S-<left>"]
["Insert Column" org-shiftmetaright :active (org-at-table-p) :keys "M-S-<right>"])
("Row"
["Move Row Up" org-metaup :active (org-at-table-p) :keys "M-<up>"]
["Move Row Down" org-metadown :active (org-at-table-p) :keys "M-<down>"]
["Delete Row" org-shiftmetaup :active (org-at-table-p) :keys "M-S-<up>"]
["Insert Row" org-shiftmetadown :active (org-at-table-p) :keys "M-S-<down>"]
["Sort lines in region" org-table-sort-lines :active (org-at-table-p) :keys "C-c ^"]
"--"
["Insert Hline" org-table-insert-hline :active (org-at-table-p) :keys "C-c -"])
("Rectangle"
["Copy Rectangle" org-copy-special :active (org-at-table-p)]
["Cut Rectangle" org-cut-special :active (org-at-table-p)]
["Paste Rectangle" org-paste-special :active (org-at-table-p)]
["Fill Rectangle" org-table-wrap-region :active (org-at-table-p)])
"--"
("Radio tables"
["Insert table template" orgtbl-insert-radio-table
(cl-assoc-if #'derived-mode-p orgtbl-radio-table-templates)]
["Comment/uncomment table" orgtbl-toggle-comment t])
"--"
["Set Column Formula" org-table-eval-formula :active (org-at-table-p) :keys "C-c ="]
["Set Field Formula" (org-table-eval-formula '(4)) :active (org-at-table-p) :keys "C-u C-c ="]
["Edit Formulas" org-table-edit-formulas :active (org-at-table-p) :keys "C-c '"]
["Recalculate line" org-table-recalculate :active (org-at-table-p) :keys "C-c *"]
["Recalculate all" (org-table-recalculate '(4)) :active (org-at-table-p) :keys "C-u C-c *"]
["Iterate all" (org-table-recalculate '(16)) :active (org-at-table-p) :keys "C-u C-u C-c *"]
["Toggle Recalculate Mark" org-table-rotate-recalc-marks :active (org-at-table-p) :keys "C-c #"]
["Sum Column/Rectangle" org-table-sum
:active (or (org-at-table-p) (org-region-active-p)) :keys "C-c +"]
["Which Column?" org-table-current-column :active (org-at-table-p) :keys "C-c ?"]
["Debug Formulas"
org-table-toggle-formula-debugger :active (org-at-table-p)
:keys "C-c {"
:style toggle :selected org-table-formula-debug]
["Show Col/Row Numbers"
org-table-toggle-coordinate-overlays :active (org-at-table-p)
:keys "C-c }"
:style toggle :selected org-table-overlay-coordinates]
"--"
("Plot"
["Ascii plot" orgtbl-ascii-plot :active (org-at-table-p) :keys "C-c \" a"]
["Gnuplot" org-plot/gnuplot :active (org-at-table-p) :keys "C-c \" g"])))
;;;###autoload
(define-minor-mode orgtbl-mode
"The Org mode table editor as a minor mode for use in other modes."
:lighter " OrgTbl"
(org-load-modules-maybe)
(cond
((derived-mode-p 'org-mode)
;; Exit without error, in case some hook functions calls this by
;; accident in Org mode.
(message "Orgtbl mode is not useful in Org mode, command ignored"))
(orgtbl-mode
(orgtbl-setup)
;; Make sure we are first in minor-mode-map-alist
(let ((c (assq 'orgtbl-mode minor-mode-map-alist)))
;; FIXME: maybe it should use emulation-mode-map-alists?
(and c (setq minor-mode-map-alist
(cons c (delq c minor-mode-map-alist)))))
(setq-local org-table-may-need-update t)
(add-hook 'before-change-functions 'org-before-change-function
nil 'local)
(setq-local org-old-auto-fill-inhibit-regexp
auto-fill-inhibit-regexp)
(setq-local auto-fill-inhibit-regexp
(if auto-fill-inhibit-regexp
(concat orgtbl-line-start-regexp "\\|"
auto-fill-inhibit-regexp)
orgtbl-line-start-regexp))
(font-lock-add-keywords nil orgtbl-extra-font-lock-keywords)
(org-restart-font-lock))
(t
(setq auto-fill-inhibit-regexp org-old-auto-fill-inhibit-regexp)
(remove-hook 'before-change-functions 'org-before-change-function t)
(font-lock-remove-keywords nil orgtbl-extra-font-lock-keywords)
(org-restart-font-lock)
(force-mode-line-update 'all))))
(defun orgtbl-make-binding (fun n &rest keys)
"Create a function for binding in the table minor mode.
FUN is the command to call inside a table. N is used to create a unique
command name. KEYS are keys that should be checked in for a command
to execute outside of tables."
(eval
(list 'defun
(intern (concat "orgtbl-hijacker-command-" (number-to-string n)))
'(arg)
(concat "In tables, run `" (symbol-name fun) "'.\n"
"Outside of tables, run the binding of `"
(mapconcat #'key-description keys "' or `")
"'.")
'(interactive "p")
(list 'if
'(org-at-table-p)
(list 'call-interactively (list 'quote fun))
(list 'let '(orgtbl-mode)
(list 'call-interactively
(append '(or)
(mapcar (lambda (k)
(list 'key-binding k))
keys)
'('orgtbl-error))))))))
(defun orgtbl-error ()
"Error when there is no default binding for a table key."
(interactive)
(user-error "This key has no function outside tables"))
;; Fill in orgtbl keymap.
(let ((nfunc 0)
(bindings
'(([(meta shift left)] org-table-delete-column)
([(meta left)] org-table-move-column-left)
([(meta right)] org-table-move-column-right)
([(meta shift right)] org-table-insert-column)
([(meta shift up)] org-table-kill-row)
([(meta shift down)] org-table-insert-row)
([(meta up)] org-table-move-row-up)
([(meta down)] org-table-move-row-down)
("\C-c\C-w" org-table-cut-region)
("\C-c\M-w" org-table-copy-region)
("\C-c\C-y" org-table-paste-rectangle)
("\C-c\C-w" org-table-wrap-region)
("\C-c-" org-table-insert-hline)
("\C-c}" org-table-toggle-coordinate-overlays)
("\C-c{" org-table-toggle-formula-debugger)
("\C-m" org-table-next-row)
([(shift return)] org-table-copy-down)
("\C-c?" org-table-field-info)
("\C-c " org-table-blank-field)
("\C-c+" org-table-sum)
("\C-c=" org-table-eval-formula)
("\C-c'" org-table-edit-formulas)
("\C-c`" org-table-edit-field)
("\C-c*" org-table-recalculate)
("\C-c^" org-table-sort-lines)
("\M-a" org-table-beginning-of-field)
("\M-e" org-table-end-of-field)
([(control ?#)] org-table-rotate-recalc-marks)))
elt key fun cmd)
(while (setq elt (pop bindings))
(setq nfunc (1+ nfunc))
(setq key (org-key (car elt))
fun (nth 1 elt)
cmd (orgtbl-make-binding fun nfunc key))
(org-defkey orgtbl-mode-map key cmd))
;; Special treatment needed for TAB, RET and DEL
(org-defkey orgtbl-mode-map [(return)]
(orgtbl-make-binding 'orgtbl-ret 100 [(return)] "\C-m"))
(org-defkey orgtbl-mode-map "\C-m"
(orgtbl-make-binding 'orgtbl-ret 101 "\C-m" [(return)]))
(org-defkey orgtbl-mode-map [(tab)]
(orgtbl-make-binding 'orgtbl-tab 102 [(tab)] "\C-i"))
(org-defkey orgtbl-mode-map "\C-i"
(orgtbl-make-binding 'orgtbl-tab 103 "\C-i" [(tab)]))
(org-defkey orgtbl-mode-map [(shift tab)]
(orgtbl-make-binding 'org-table-previous-field 104
[(shift tab)] [(tab)] "\C-i"))
(org-defkey orgtbl-mode-map [backspace]
(orgtbl-make-binding 'org-delete-backward-char 109
[backspace] (kbd "DEL")))
(org-defkey orgtbl-mode-map [S-iso-lefttab]
(orgtbl-make-binding 'org-table-previous-field 107
[S-iso-lefttab] [backtab] [(shift tab)]
[(tab)] "\C-i"))
(org-defkey orgtbl-mode-map [backtab]
(orgtbl-make-binding 'org-table-previous-field 108
[backtab] [S-iso-lefttab] [(shift tab)]
[(tab)] "\C-i"))
(org-defkey orgtbl-mode-map "\M-\C-m"
(orgtbl-make-binding 'org-table-wrap-region 105
"\M-\C-m" [(meta return)]))
(org-defkey orgtbl-mode-map [(meta return)]
(orgtbl-make-binding 'org-table-wrap-region 106
[(meta return)] "\M-\C-m"))
(org-defkey orgtbl-mode-map "\C-c\C-c" 'orgtbl-ctrl-c-ctrl-c)
(org-defkey orgtbl-mode-map "\C-c|" 'orgtbl-create-or-convert-from-region))
(defun orgtbl-setup ()
"Setup orgtbl keymaps."
;; If the user wants maximum table support, we need to hijack
;; some standard editing functions
(org-remap orgtbl-mode-map
'self-insert-command (and orgtbl-optimized 'orgtbl-self-insert-command)
'delete-char (and orgtbl-optimized 'org-delete-char)
'delete-forward-char (and orgtbl-optimized 'org-delete-char)
'delete-backward-char (and orgtbl-optimized 'org-delete-backward-char))
(org-defkey orgtbl-mode-map "|" (and orgtbl-optimized 'org-force-self-insert)))
(defun orgtbl-ctrl-c-ctrl-c (arg)
"If the cursor is inside a table, realign the table.
If it is a table to be sent away to a receiver, do it.
With prefix arg, also recompute table."
(interactive "P")
(let ((case-fold-search t) (pos (point)) action)
(save-excursion
(forward-line 0)
(setq action (cond
((looking-at "[ \t]*#\\+ORGTBL:.*\n[ \t]*|") (match-end 0))
((looking-at "[ \t]*|") pos)
((looking-at "[ \t]*#\\+tblfm:") 'recalc))))
(cond
((integerp action)
(goto-char action)
(org-table-maybe-eval-formula)
(if arg
(call-interactively 'org-table-recalculate)
(org-table-maybe-recalculate-line))
(call-interactively 'org-table-align)
(when (orgtbl-send-table 'maybe)
(run-hooks 'orgtbl-after-send-table-hook)))
((eq action 'recalc)
(save-excursion
(forward-line 0)
(skip-chars-backward " \r\n\t")
(if (org-at-table-p)
(org-call-with-arg 'org-table-recalculate t))))
(t (let (orgtbl-mode)
(call-interactively (key-binding "\C-c\C-c")))))))
(defun orgtbl-create-or-convert-from-region (_arg)
"Create table or convert region to table, if no conflicting binding.
This installs the table binding `C-c |', but only if there is no
conflicting binding to this key outside `orgtbl-mode'."
(interactive "P")
(let* (orgtbl-mode (cmd (key-binding "\C-c|")))
(if cmd
(call-interactively cmd)
(call-interactively 'org-table-create-or-convert-from-region))))
(defun orgtbl-tab (arg)
"Justification and field motion for `orgtbl-mode'."
(interactive "P")
(if arg (org-table-edit-field t)
(org-table-justify-field-maybe)
(org-table-next-field)))
(defun orgtbl-ret ()
"Justification and field motion for `orgtbl-mode'."
(interactive)
(if (bobp)
(newline)
(org-table-justify-field-maybe)
(org-table-next-row)))
(defun orgtbl-self-insert-command (N)
"Like `self-insert-command', use `overwrite-mode' for whitespace in tables.
If the cursor is in a table looking at whitespace, the whitespace is
overwritten, and the table is not marked as requiring realignment."
(interactive "p")
(if (and (org-at-table-p)
(or
(and org-table-auto-blank-field
(member last-command
'(orgtbl-hijacker-command-100
orgtbl-hijacker-command-101
orgtbl-hijacker-command-102
orgtbl-hijacker-command-103
orgtbl-hijacker-command-104
orgtbl-hijacker-command-105
yas/expand))
(org-table-blank-field))
t)
(eq N 1)
(looking-at "[^|\n]* \\( \\)|"))
(let (org-table-may-need-update)
(delete-region (match-beginning 1) (match-end 1))
(self-insert-command N))
(setq org-table-may-need-update t)
(let* (orgtbl-mode
(cmd (or (key-binding
(or (and (listp function-key-map)
(cdr (assoc last-command-event function-key-map)))
(vector last-command-event)))
'self-insert-command)))
(call-interactively cmd)
(if (and org-self-insert-cluster-for-undo
(eq cmd 'self-insert-command))
(if (not (eq last-command 'orgtbl-self-insert-command))
(setq org-self-insert-command-undo-counter 1)
(if (>= org-self-insert-command-undo-counter 20)
(setq org-self-insert-command-undo-counter 1)
(and (> org-self-insert-command-undo-counter 0)
buffer-undo-list
(not (cadr buffer-undo-list)) ; remove nil entry
(setcdr buffer-undo-list (cddr buffer-undo-list)))
(setq org-self-insert-command-undo-counter
(1+ org-self-insert-command-undo-counter))))))))
;;;###autoload
(defvar orgtbl-exp-regexp "^\\([-+]?[0-9][0-9.]*\\)[eE]\\([-+]?[0-9]+\\)$"
"Regular expression matching exponentials as produced by calc.")
(defun orgtbl-gather-send-defs ()
"Gather a plist of :name, :transform, :params for each destination before
a radio table."
(save-excursion
(goto-char (org-table-begin))
(let (rtn)
(forward-line -1)
(catch :bob
(while (looking-at "[ \t]*#\\+ORGTBL[: \t][ \t]*SEND[ \t]+\\([^ \t\r\n]+\\)[ \t]+\\([^ \t\r\n]+\\)\\([ \t]+.*\\)?")
(let ((name (org-no-properties (match-string 1)))
(transform (intern (match-string 2)))
(params (if (match-end 3)
(read (concat "(" (match-string 3) ")")))))
(push (list :name name :transform transform :params params)
rtn)
(when (bobp) (throw :bob nil))
(forward-line -1))))
rtn)))
(defun orgtbl-send-replace-tbl (name text)
"Find and replace table NAME with TEXT."
(save-excursion
(goto-char (point-min))
(let* ((location-flag nil)
(name (regexp-quote name))
(begin-re (format "BEGIN +RECEIVE +ORGTBL +%s\\([ \t]\\|$\\)" name))
(end-re (format "END +RECEIVE +ORGTBL +%s\\([ \t]\\|$\\)" name)))
(while (re-search-forward begin-re nil t)
(unless location-flag (setq location-flag t))
(let ((beg (line-beginning-position 2)))
(unless (re-search-forward end-re nil t)
(user-error "Cannot find end of receiver location at %d" beg))
(forward-line 0)
(delete-region beg (point))
(insert text "\n")))
(unless location-flag
(user-error "No valid receiver location found in the buffer")))))
;;;###autoload
(defun org-table-to-lisp (&optional txt)
"Convert the table at point to a Lisp structure.
The structure will be a list. Each item is either the symbol `hline'
for a horizontal separator line, or a list of field values as strings.
The table is taken from the parameter TXT, or from the buffer at point."
(if txt
(with-temp-buffer
(buffer-disable-undo)
(insert txt)
(goto-char (point-min))
(org-table-to-lisp))
(save-excursion
(goto-char (org-table-begin))
(let (table)
(while (progn (skip-chars-forward " \t")
(eq (following-char) ?|))
(forward-char)
(push
(if (eq (following-char) ?-)
'hline
(let (row)
(while (progn
(skip-chars-forward " \t")
(not (eolp)))
(let ((q (point)))
(skip-chars-forward "^|\n")
(goto-char
(prog1
(let ((p (point)))
(unless (eolp) (setq p (1+ p)))
p)
(skip-chars-backward " \t" q)
;; Preserve text properties. They are used when
;; calculating cell width.
(push (buffer-substring q (point)) row)))))
(nreverse row)))
table)
(forward-line))
(nreverse table)))))
(defun org-table-collapse-header (table &optional separator max-header-lines)
"Collapse the lines before `hline' into a single header.
The given TABLE is a list of lists as returned by `org-table-to-lisp'.
The leading lines before the first `hline' symbol are considered
forming the table header. This function collapses all leading header
lines into a single header line, followed by the `hline' symbol, and
the rest of the TABLE. Header cells are glued together with a space,
or the given SEPARATOR."
(while (eq (car table) 'hline) (pop table))
(let* ((separator (or separator " "))
(max-header-lines (or max-header-lines 4))
(trailer table)
(header-lines (cl-loop for line in table
until (eq 'hline line)
collect (pop trailer))))
(if (and trailer (<= (length header-lines) max-header-lines))
(cons (apply #'cl-mapcar
(lambda (&rest x)
(org-trim
(mapconcat #'identity x separator)))
header-lines)
trailer)
table)))
(defun orgtbl-send-table (&optional maybe)
"Send a transformed version of table at point to the receiver position.
With argument MAYBE, fail quietly if no transformation is defined
for this table."
(interactive)
(catch 'exit
(unless (org-at-table-p) (user-error "Not at a table"))
;; when non-interactive, we assume align has just happened.
(when (called-interactively-p 'any) (org-table-align))
(let ((dests (orgtbl-gather-send-defs))
(table (org-table-to-lisp))
(ntbl 0))
(unless dests
(if maybe (throw 'exit nil)
(user-error "Don't know how to transform this table")))
(dolist (dest dests)
(let ((name (plist-get dest :name))
(transform (plist-get dest :transform))
(params (plist-get dest :params)))
(unless (fboundp transform)
(user-error "No such transformation function %s" transform))
(orgtbl-send-replace-tbl name (funcall transform table params)))
(cl-incf ntbl))
(message "Table converted and installed at %d receiver location%s"
ntbl (if (> ntbl 1) "s" ""))
(and (> ntbl 0) ntbl))))
(defun org-remove-by-index (list indices &optional i0)
"Remove the elements in LIST with indices in INDICES.
First element has index 0, or I0 if given."
(if (not indices)
list
(if (integerp indices) (setq indices (list indices)))
(setq i0 (1- (or i0 0)))
(delq :rm (mapcar (lambda (x)
(setq i0 (1+ i0))
(if (memq i0 indices) :rm x))
list))))
(defun orgtbl-toggle-comment ()
"Comment or uncomment the orgtbl at point."
(interactive)
(let* ((case-fold-search t)
(re1 (concat "^" (regexp-quote comment-start) orgtbl-line-start-regexp))
(re2 (concat "^" orgtbl-line-start-regexp))
(commented (save-excursion (forward-line 0)
(cond ((looking-at re1) t)
((looking-at re2) nil)
(t (user-error "Not at an org table")))))
(re (if commented re1 re2))
beg end)
(save-excursion
(forward-line 0)
(while (and (not (eq (point) (point-min)))
(looking-at re))
(forward-line -1))
(unless (eq (point) (point-min)) (forward-line 1))
(setq beg (point))
(while (and (not (eq (point) (point-max)))
(looking-at re))
(forward-line 1))
(setq end (point)))
(comment-region beg end (if commented '(4) nil))))
(defun orgtbl-insert-radio-table ()
"Insert a radio table template appropriate for this major mode."
(interactive)
(let* ((e (cl-assoc-if #'derived-mode-p orgtbl-radio-table-templates))
(txt (nth 1 e))
name pos)
(unless e (user-error "No radio table setup defined for %s" major-mode))
(setq name (read-string "Table name: "))
(while (string-match "%n" txt)
(setq txt (replace-match name t t txt)))
(or (bolp) (insert "\n"))
(setq pos (point))
(insert txt)
(goto-char pos)))
;;;###autoload
(defun orgtbl-to-generic (table params)
"Convert the `orgtbl-mode' TABLE to some other format.
This generic routine can be used for many standard cases.
TABLE is a list, each entry either the symbol `hline' for
a horizontal separator line, or a list of fields for that
line. PARAMS is a property list of parameters that can
influence the conversion.
Valid parameters are:
:backend, :raw
Export backend used as a basis to transcode elements of the
table, when no specific parameter applies to it. It is also
used to translate cells contents. You can prevent this by
setting :raw property to a non-nil value.
:splice
When non-nil, only convert rows, not the table itself. This is
equivalent to setting to the empty string both :tstart
and :tend, which see.
:skip
When set to an integer N, skip the first N lines of the table.
Horizontal separation lines do count for this parameter!
:skipcols
List of columns that should be skipped. If the table has
a column with calculation marks, that column is automatically
discarded beforehand.
:hline
String to be inserted on horizontal separation lines. May be
nil to ignore these lines altogether.
:sep
Separator between two fields, as a string.
Each in the following group may be either a string or a function
of no arguments returning a string:
:tstart, :tend
Strings to start and end the table. Ignored when :splice is t.
:lstart, :lend
Strings to start and end a new table line.
:llstart, :llend
Strings to start and end the last table line. Default,
respectively, to :lstart and :lend.
Each in the following group may be a string or a function of one
argument (either the cells in the current row, as a list of
strings, or the current cell) returning a string:
:lfmt
Format string for an entire row, with enough %s to capture all
fields. When non-nil, :lstart, :lend, and :sep are ignored.
:llfmt
Format for the entire last line, defaults to :lfmt.
:fmt
A format to be used to wrap the field, should contain %s for
the original field value. For example, to wrap everything in
dollars, you could use :fmt \"$%s$\". This may also be
a property list with column numbers and format strings, or
functions, e.g.,
(:fmt (2 \"$%s$\" 4 (lambda (c) (format \"$%s$\" c))))
The format is ignored for empty fields. Use :raw t with non-nil
:backend option to force formatting empty fields.
:hlstart :hllstart :hlend :hllend :hsep :hlfmt :hllfmt :hfmt
Same as above, specific for the header lines in the table.
All lines before the first hline are treated as header. If
any of these is not present, the data line value is used.
This may be either a string or a function of two arguments:
:efmt
Use this format to print numbers with exponential. The format
should have %s twice for inserting mantissa and exponent, for
example \"%s\\\\times10^{%s}\". This may also be a property
list with column numbers and format strings or functions.
:fmt will still be applied after :efmt."
;; Make sure `org-export-create-backend' is available.
(require 'ox)
(let* ((backend (plist-get params :backend))
(custom-backend
;; Build a custom backend according to PARAMS. Before
;; defining a translator, check if there is anything to do.
;; When there isn't, let BACKEND handle the element.
(org-export-create-backend
:parent (or backend 'org)
:transcoders
`((table . ,(org-table--to-generic-table params))
(table-row . ,(org-table--to-generic-row params))
(table-cell . ,(org-table--to-generic-cell params))
;; Macros are not going to be expanded. However, no
;; regular backend has a transcoder for them. We
;; provide one so they are not ignored, but displayed
;; as-is instead.
(macro . (lambda (m c i) (org-element-macro-interpreter m nil))))))
data info)
;; Store TABLE as Org syntax in DATA. Tolerate non-string cells.
;; Initialize communication channel in INFO.
(with-temp-buffer
(let ((org-inhibit-startup t)) (org-mode))
(org-fold-core-ignore-modifications
(let ((standard-output (current-buffer))
(org-element-use-cache nil))
(dolist (e table)
(cond ((eq e 'hline) (princ "|--\n"))
((consp e)
(princ "| ") (dolist (c e) (princ c) (princ " |"))
(princ "\n")))))
(org-element-cache-reset)
;; Add backend specific filters, but not user-defined ones. In
;; particular, make sure to call parse-tree filters on the
;; table.
(setq info
(let ((org-export-filters-alist nil))
(org-export-install-filters
(org-combine-plists
(org-export-get-environment backend nil params)
`(:back-end ,(org-export-get-backend backend))))))
(setq data
(org-export-filter-apply-functions
(plist-get info :filter-parse-tree)
(org-element-map (org-element-parse-buffer) 'table
#'identity nil t)
info))
(when (and backend (symbolp backend) (not (org-export-get-backend backend)))
(user-error "Unknown :backend value"))))
(when (or (not backend) (plist-get info :raw)) (require 'ox-org))
;; Handle :skip parameter.
(let ((skip (plist-get info :skip)))
(when skip
(unless (wholenump skip) (user-error "Wrong :skip value"))
(let ((n 0))
(org-element-map data 'table-row
(lambda (row)
(if (>= n skip) t
(org-element-extract row)
(cl-incf n)
nil))
nil t))))
;; Handle :skipcols parameter.
(let ((skipcols (plist-get info :skipcols)))
(when skipcols
(unless (consp skipcols) (user-error "Wrong :skipcols value"))
(org-element-map data 'table
(lambda (table)
(let ((specialp (org-export-table-has-special-column-p table)))
(dolist (row (org-element-contents table))
(when (eq (org-element-property :type row) 'standard)
(let ((c 1))
(dolist (cell (nthcdr (if specialp 1 0)
(org-element-contents row)))
(when (memq c skipcols)
(org-element-extract cell))
(cl-incf c))))))))))
;; Since we are going to export using a low-level mechanism,
;; ignore special column and special rows manually.
(let ((special? (org-export-table-has-special-column-p data))
ignore)
(org-element-map data (if special? '(table-cell table-row) 'table-row)
(lambda (datum)
(when (if (org-element-type-p datum 'table-row)
(org-export-table-row-is-special-p datum nil)
(org-export-first-sibling-p datum nil))
(push datum ignore))))
(setq info (plist-put info :ignore-list ignore)))
;; We use a low-level mechanism to export DATA so as to skip all
;; usual pre-processing and post-processing, i.e., hooks, Babel
;; code evaluation, include keywords and macro expansion. Only
;; backend specific filters are retained.
(let ((output (org-export-data-with-backend data custom-backend info)))
;; Remove final newline.
(if (org-string-nw-p output) (substring-no-properties output 0 -1) ""))))
(defun org-table--generic-apply (value name &optional with-cons &rest args)
(cond ((null value) nil)
((functionp value) `(funcall ',value ,@args))
((stringp value)
(cond ((consp (car args)) `(apply #'format ,value ,@args))
(args `(format ,value ,@args))
(t value)))
((and with-cons (consp value))
`(let ((val (cadr (memq column ',value))))
(cond ((null val) contents)
((stringp val) (format val ,@args))
((functionp val) (funcall val ,@args))
(t (user-error "Wrong %s value" ,name)))))
(t (user-error "Wrong %s value" name))))
(defun org-table--to-generic-table (params)
"Return custom table transcoder according to PARAMS.
PARAMS is a plist. See `orgtbl-to-generic' for more
information."
(let ((backend (plist-get params :backend))
(splice (plist-get params :splice))
(tstart (plist-get params :tstart))
(tend (plist-get params :tend)))
`(lambda (table contents info)
(concat
,(and tstart (not splice)
`(concat ,(org-table--generic-apply tstart ":tstart") "\n"))
,(if (or (not backend) tstart tend splice) 'contents
`(org-export-with-backend ',backend table contents info))
,(org-table--generic-apply (and (not splice) tend) ":tend")))))
(defun org-table--to-generic-row (params)
"Return custom table row transcoder according to PARAMS.
PARAMS is a plist. See `orgtbl-to-generic' for more
information."
(let* ((backend (plist-get params :backend))
(lstart (plist-get params :lstart))
(llstart (plist-get params :llstart))
(hlstart (plist-get params :hlstart))
(hllstart (plist-get params :hllstart))
(lend (plist-get params :lend))
(llend (plist-get params :llend))
(hlend (plist-get params :hlend))
(hllend (plist-get params :hllend))
(lfmt (plist-get params :lfmt))
(llfmt (plist-get params :llfmt))
(hlfmt (plist-get params :hlfmt))
(hllfmt (plist-get params :hllfmt)))
`(lambda (row contents info)
(if (eq (org-element-property :type row) 'rule)
,(cond
((plist-member params :hline)
(org-table--generic-apply (plist-get params :hline) ":hline"))
(backend `(org-export-with-backend ',backend row nil info)))
(let ((headerp ,(and (or hlfmt hlstart hlend)
'(org-export-table-row-in-header-p row info)))
(last-header-p
,(and (or hllfmt hllstart hllend)
'(org-export-table-row-ends-header-p row info)))
(lastp (not (org-export-get-next-element row info))))
(when contents
;; Check if we can apply `:lfmt', `:llfmt', `:hlfmt', or
;; `:hllfmt' to CONTENTS. Otherwise, fallback on
;; `:lstart', `:lend' and their relatives.
,(let ((cells
'(org-element-map row 'table-cell
(lambda (cell)
;; Export all cells, without separators.
;;
;; Use `org-export-data-with-backend'
;; instead of `org-export-data' to eschew
;; cached values, which
;; ignore :orgtbl-ignore-sep parameter.
(org-export-data-with-backend
cell
(plist-get info :back-end)
(org-combine-plists info '(:orgtbl-ignore-sep t))))
info)))
`(cond
,(and hllfmt
`(last-header-p ,(org-table--generic-apply
hllfmt ":hllfmt" nil cells)))
,(and hlfmt
`(headerp ,(org-table--generic-apply
hlfmt ":hlfmt" nil cells)))
,(and llfmt
`(lastp ,(org-table--generic-apply
llfmt ":llfmt" nil cells)))
(t
,(if lfmt (org-table--generic-apply lfmt ":lfmt" nil cells)
`(concat
(cond
,(and
(or hllstart hllend)
`(last-header-p
(concat
,(org-table--generic-apply hllstart ":hllstart")
contents
,(org-table--generic-apply hllend ":hllend"))))
,(and
(or hlstart hlend)
`(headerp
(concat
,(org-table--generic-apply hlstart ":hlstart")
contents
,(org-table--generic-apply hlend ":hlend"))))
,(and
(or llstart llend)
`(lastp
(concat
,(org-table--generic-apply llstart ":llstart")
contents
,(org-table--generic-apply llend ":llend"))))
(t
,(cond
((or lstart lend)
`(concat
,(org-table--generic-apply lstart ":lstart")
contents
,(org-table--generic-apply lend ":lend")))
(backend
`(org-export-with-backend
',backend row contents info))
(t 'contents)))))))))))))))
(defun org-table--to-generic-cell (params)
"Return custom table cell transcoder according to PARAMS.
PARAMS is a plist. See `orgtbl-to-generic' for more
information."
(let* ((backend (plist-get params :backend))
(efmt (plist-get params :efmt))
(fmt (plist-get params :fmt))
(hfmt (plist-get params :hfmt))
(sep (plist-get params :sep))
(hsep (plist-get params :hsep)))
`(lambda (cell contents info)
;; Make sure that contents are exported as Org data when :raw
;; parameter is non-nil.
,(when (and backend (plist-get params :raw))
`(setq contents
;; Since we don't know what are the pseudo object
;; types defined in backend, we cannot pass them to
;; `org-element-interpret-data'. As a consequence,
;; they will be treated as pseudo elements, and will
;; have newlines appended instead of spaces.
;; Therefore, we must make sure :post-blank value is
;; really turned into spaces.
(replace-regexp-in-string
"\n" " "
(org-trim
(org-element-interpret-data
(org-element-contents cell))))))
(let ((headerp ,(and (or hfmt hsep)
'(org-export-table-row-in-header-p
(org-element-parent-element cell) info)))
(column
;; Call costly `org-export-table-cell-address' only if
;; absolutely necessary, i.e., if one
;; of :fmt :efmt :hfmt has a "plist type" value.
,(and (cl-some (lambda (v) (integerp (car-safe v)))
(list efmt hfmt fmt))
'(1+ (cdr (org-export-table-cell-address cell info))))))
(when contents
;; Check if we can apply `:efmt' on CONTENTS.
,(when efmt
`(when (string-match orgtbl-exp-regexp contents)
(let ((mantissa (match-string 1 contents))
(exponent (match-string 2 contents)))
(setq contents ,(org-table--generic-apply
efmt ":efmt" t 'mantissa 'exponent)))))
;; Check if we can apply FMT (or HFMT) on CONTENTS.
(cond
,(and hfmt `(headerp (setq contents ,(org-table--generic-apply
hfmt ":hfmt" t 'contents))))
,(and fmt `(t (setq contents ,(org-table--generic-apply
fmt ":fmt" t 'contents))))))
;; If a separator is provided, use it instead of BACKEND's.
;; Separators are ignored when LFMT (or equivalent) is
;; provided.
,(cond
((or hsep sep)
`(if (or ,(and (not sep) '(not headerp))
(plist-get info :orgtbl-ignore-sep)
(not (org-export-get-next-element cell info)))
,(if (not backend) 'contents
`(org-export-with-backend ',backend cell contents info))
(concat contents
,(if (and sep hsep) `(if headerp ,hsep ,sep)
(or hsep sep)))))
(backend `(org-export-with-backend ',backend cell contents info))
(t 'contents))))))
;;;###autoload
(defun orgtbl-to-tsv (table params)
"Convert the `orgtbl-mode' TABLE to TAB separated material."
(orgtbl-to-generic table (org-combine-plists '(:sep "\t") params)))
;;;###autoload
(defun orgtbl-to-csv (table params)
"Convert the `orgtbl-mode' TABLE to CSV material.
This does take care of the proper quoting of fields with comma or quotes."
(orgtbl-to-generic table
(org-combine-plists '(:sep "," :fmt org-quote-csv-field)
params)))
;;;###autoload
(defun orgtbl-to-latex (table params)
"Convert the `orgtbl-mode' TABLE to LaTeX.
TABLE is a list, each entry either the symbol `hline' for
a horizontal separator line, or a list of fields for that line.
PARAMS is a property list of parameters that can influence the
conversion. All parameters from `orgtbl-to-generic' are
supported. It is also possible to use the following ones:
:booktabs
When non-nil, use formal \"booktabs\" style.
:environment
Specify environment to use, as a string. If you use
\"longtable\", you may also want to specify :language property,
as a string, to get proper continuation strings."
(require 'ox-latex)
(orgtbl-to-generic
table
(org-combine-plists
;; Provide sane default values.
(list :backend 'latex
:latex-default-table-mode 'table
:latex-tables-centered nil
:latex-tables-booktabs (plist-get params :booktabs)
:latex-table-scientific-notation nil
:latex-default-table-environment
(or (plist-get params :environment) "tabular"))
params)))
;;;###autoload
(defun orgtbl-to-html (table params)
"Convert the `orgtbl-mode' TABLE to HTML.
TABLE is a list, each entry either the symbol `hline' for
a horizontal separator line, or a list of fields for that line.
PARAMS is a property list of parameters that can influence the
conversion. All parameters from `orgtbl-to-generic' are
supported. It is also possible to use the following one:
:attributes
Attributes and values, as a plist, which will be used in
<table> tag."
(require 'ox-html)
(orgtbl-to-generic
table
(org-combine-plists
;; Provide sane default values.
(list :backend 'html
:html-table-data-tags '("<td%s>" . "</td>")
:html-table-use-header-tags-for-first-column nil
:html-table-align-individual-fields t
:html-table-row-tags '("<tr>" . "</tr>")
:html-table-attributes
(if (plist-member params :attributes)
(plist-get params :attributes)
'(:border "2" :cellspacing "0" :cellpadding "6" :rules "groups"
:frame "hsides")))
params)))
;;;###autoload
(defun orgtbl-to-texinfo (table params)
"Convert the `orgtbl-mode' TABLE to Texinfo.
TABLE is a list, each entry either the symbol `hline' for
a horizontal separator line, or a list of fields for that line.
PARAMS is a property list of parameters that can influence the
conversion. All parameters from `orgtbl-to-generic' are
supported. It is also possible to use the following one:
:columns
Column widths, as a string. When providing column fractions,
\"@columnfractions\" command can be omitted."
(require 'ox-texinfo)
(let ((output
(orgtbl-to-generic
table
(org-combine-plists
(list :backend 'texinfo
:texinfo-tables-verbatim nil
:texinfo-table-scientific-notation nil)
params)))
(columns (let ((w (plist-get params :columns)))
(cond ((not w) nil)
((string-match-p "{\\|@columnfractions " w) w)
(t (concat "@columnfractions " w))))))
(if (not columns) output
(replace-regexp-in-string
"@multitable \\(.*\\)" columns output t nil 1))))
;;;###autoload
(defun orgtbl-to-orgtbl (table params)
"Convert the `orgtbl-mode' TABLE into another `orgtbl-mode' table.
TABLE is a list, each entry either the symbol `hline' for
a horizontal separator line, or a list of fields for that line.
PARAMS is a property list of parameters that can influence the
conversion. All parameters from `orgtbl-to-generic' are
supported.
Useful when slicing one table into many. The :hline, :sep,
:lstart, and :lend provide orgtbl framing. :tstart and :tend can
be set to provide ORGTBL directives for the generated table."
(require 'ox-org)
(orgtbl-to-generic table (org-combine-plists params (list :backend 'org))))
(defun orgtbl-to-table.el (table params)
"Convert the `orgtbl-mode' TABLE into a table.el table.
TABLE is a list, each entry either the symbol `hline' for
a horizontal separator line, or a list of fields for that line.
PARAMS is a property list of parameters that can influence the
conversion. All parameters from `orgtbl-to-generic' are
supported."
(with-temp-buffer
(insert (orgtbl-to-orgtbl table params))
(org-table-align)
(goto-char (point-min))
(while (search-forward "-|" nil t)
(replace-match "-+"))
(goto-char (point-min))
(while (search-forward "|-" nil t)
(replace-match "+-"))
(buffer-string)))
(defun orgtbl-to-unicode (table params)
"Convert the `orgtbl-mode' TABLE into a table with unicode characters.
TABLE is a list, each entry either the symbol `hline' for
a horizontal separator line, or a list of fields for that line.
PARAMS is a property list of parameters that can influence the
conversion. All parameters from `orgtbl-to-generic' are
supported. It is also possible to use the following ones:
:ascii-art
When non-nil, use \"ascii-art-to-unicode\" package to translate
the table. You can download it here:
https://gnuvola.org/software/j/aa2u/ascii-art-to-unicode.el.
:narrow
When non-nil, narrow columns width than provided width cookie,
using \"=>\" as an ellipsis, just like in an Org mode buffer."
(require 'ox-ascii)
(orgtbl-to-generic
table
(org-combine-plists
(list :backend 'ascii
:ascii-charset 'utf-8
:ascii-table-widen-columns (not (plist-get params :narrow))
:ascii-table-use-ascii-art (plist-get params :ascii-art))
params)))
;; Put the cursor in a column containing numerical values
;; of an Org table,
;; type C-c " a
;; A new column is added with a bar plot.
;; When the table is refreshed (C-u C-c *),
;; the plot is updated to reflect the new values.
(defun orgtbl-ascii-draw (value min max &optional width characters)
"Draw an ascii bar in a table.
VALUE is the value to plot, it determines the width of the bar to draw.
MIN is the value that will be displayed as empty (zero width bar).
MAX is the value that will draw a bar filling all the WIDTH.
WIDTH is the span in characters from MIN to MAX.
CHARACTERS is a string that will compose the bar, with shades of grey
from pure white to pure black. It defaults to a 10 characters string
of regular ascii characters."
(let* ((width (ceiling (or width 12)))
(characters (or characters " .:;c!lhVHW"))
(len (1- (length characters)))
(value (float (if (numberp value)
value (string-to-number value))))
(relative (/ (- value min) (- max min)))
(steps (round (* relative width len))))
(cond ((< steps 0) "too small")
((> steps (* width len)) "too large")
(t (let* ((int-division (/ steps len))
(remainder (- steps (* int-division len))))
(concat (make-string int-division (elt characters len))
(string (elt characters remainder))))))))
;;;###autoload
(defun orgtbl-ascii-plot (&optional ask)
"Draw an ASCII bar plot in a column.
With cursor in a column containing numerical values, this function
will draw a plot in a new column.
ASK, if given, is a numeric prefix to override the default 12
characters width of the plot. ASK may also be the `\\[universal-argument]' \
prefix,
which will prompt for the width."
(interactive "P")
(let ((col (org-table-current-column))
(min 1e999) ; 1e999 will be converted to infinity
(max -1e999) ; which is the desired result
(table (org-table-to-lisp))
(length
(cond ((consp ask)
(read-number "Length of column " 12))
((numberp ask) ask)
(t 12))))
;; Skip any hline a the top of table.
(while (eq (car table) 'hline) (pop table))
;; Skip table header if any.
(dolist (x (or (cdr (memq 'hline table)) table))
(when (consp x)
(setq x (nth (1- col) x))
(when (string-match
"^[-+]?\\([0-9]*[.]\\)?[0-9]*\\([eE][+-]?[0-9]+\\)?$"
x)
(setq x (string-to-number x))
(when (> min x) (setq min x))
(when (< max x) (setq max x)))))
(org-table-insert-column)
(org-table-move-column-right)
(org-table-store-formulas
(cons
(cons
(concat "$" (number-to-string (1+ col)))
(format "'(%s $%s %s %s %s)"
"orgtbl-ascii-draw" col min max length))
(org-table-get-stored-formulas)))
(org-table-recalculate t)))
;; Example of extension: unicode characters
;; Here are two examples of different styles.
;; Unicode block characters are used to give a smooth effect.
;; See https://en.wikipedia.org/wiki/Block_Elements
;; Use one of those drawing functions
;; - orgtbl-ascii-draw (the default ascii)
;; - orgtbl-uc-draw-grid (unicode with a grid effect)
;; - orgtbl-uc-draw-cont (smooth unicode)
;; This is best viewed with the "DejaVu Sans Mono" font
;; (use M-x set-frame-font).
(defun orgtbl-uc-draw-grid (value min max &optional width)
"Draw a bar in a table using block unicode characters.
It is a variant of `orgtbl-ascii-draw' with Unicode block
characters, for a smooth display. Bars appear as grids (to the
extent the font allows)."
;; https://en.wikipedia.org/wiki/Block_Elements
;; best viewed with the "DejaVu Sans Mono" font.
(orgtbl-ascii-draw value min max width
" \u258F\u258E\u258D\u258C\u258B\u258A\u2589"))
(defun orgtbl-uc-draw-cont (value min max &optional width)
"Draw a bar in a table using block unicode characters.
It is a variant of `orgtbl-ascii-draw' with Unicode block
characters, for a smooth display. Bars are solid (to the extent
the font allows)."
(orgtbl-ascii-draw value min max width
" \u258F\u258E\u258D\u258C\u258B\u258A\u2589\u2588"))
(defun org-table-get-remote-range (name-or-id form)
"Get a field value or a list of values in a range from table at ID.
NAME-OR-ID may be the name of a table in the current file as set
by a \"#+NAME:\" directive. The first table following this line
will then be used. Alternatively, it may be an ID referring to
any entry, also in a different file. In this case, the first
table in that entry will be referenced.
FORM is a field or range descriptor like \"@2$3\" or \"B3\" or
\"@I$2..@II$2\". All the references must be absolute, not relative.
The return value is either a single string for a single field, or a
list of the fields in the rectangle."
(save-match-data
(let ((case-fold-search t) (id-loc nil)
;; Protect a bunch of variables from being overwritten by
;; the context of the remote table.
org-table-column-names org-table-column-name-regexp
org-table-local-parameters org-table-named-field-locations
org-table-current-line-types
org-table-current-begin-pos org-table-dlines
org-table-current-ncol
org-table-hlines
org-table-last-column-widths
org-table-last-alignment
buffer loc)
(setq form (org-table-convert-refs-to-rc form))
(org-with-wide-buffer
(goto-char (point-min))
(if (re-search-forward
(concat "^[ \t]*#\\+\\(tbl\\)?name:[ \t]*"
(regexp-quote name-or-id) "[ \t]*$")
nil t)
(setq buffer (current-buffer) loc (match-beginning 0))
(setq id-loc (org-id-find name-or-id 'marker))
(unless (and id-loc (markerp id-loc))
(user-error "Can't find remote table \"%s\"" name-or-id))
(setq buffer (marker-buffer id-loc)
loc (marker-position id-loc))
(move-marker id-loc nil))
(with-current-buffer buffer
(org-with-wide-buffer
(goto-char loc)
(forward-char 1)
(unless (and (re-search-forward "^\\(\\*+ \\)\\|^[ \t]*|" nil t)
(not (match-beginning 1)))
(user-error "Cannot find a table at NAME or ID %s" name-or-id))
(org-table-analyze)
(setq form (org-table-formula-substitute-names
(org-table-formula-handle-first/last-rc form)))
(if (and (string-match org-table-range-regexp form)
(> (length (match-string 0 form)) 1))
(org-table-get-range
(match-string 0 form) org-table-current-begin-pos 1)
form)))))))
(defun org-table-remote-reference-indirection (form)
"Return formula with table remote references substituted by indirection.
For example \"remote($1, @>$2)\" => \"remote(year_2013, @>$1)\".
This indirection works only with the format @ROW$COLUMN. The
format \"B3\" is not supported because it can not be
distinguished from a plain table name or ID."
(let ((regexp
;; Same as in `org-table-eval-formula'.
(concat "\\<remote([ \t]*\\("
;; Allow "$1", "@<", "$-1", "@<<$1" etc.
"[@$][^ \t,]+"
"\\)[ \t]*,[ \t]*\\([^\n)]+\\))")))
(replace-regexp-in-string
regexp
(lambda (m)
(save-match-data
(let ((eq (org-table-formula-handle-first/last-rc (match-string 1 m))))
(org-table-get-range
(if (string-match-p "\\`\\$[0-9]+\\'" eq)
(concat "@0" eq)
eq)))))
form t t 1)))
(defmacro org-define-lookup-function (mode)
(let ((mode-str (symbol-name mode))
(first-p (eq mode 'first))
(all-p (eq mode 'all)))
(let ((plural-str (if all-p "s" "")))
`(defun ,(intern (format "org-lookup-%s" mode-str)) (val s-list r-list &optional predicate)
,(format "Find %s occurrence%s of VAL in S-LIST; return corresponding element%s of R-LIST.
If R-LIST is nil, return matching element%s of S-LIST.
If PREDICATE is not nil, use it instead of `equal' to match VAL.
Matching is done by (PREDICATE VAL S), where S is an element of S-LIST.
This function is generated by a call to the macro `org-define-lookup-function'."
mode-str plural-str plural-str plural-str)
(let ,(let ((lvars '((p (or predicate 'equal))
(sl s-list)
(rl (or r-list s-list))
(ret nil))))
(if first-p (cons '(match-p nil) lvars) lvars))
(while ,(if first-p '(and (not match-p) sl) 'sl)
(when (funcall p val (car sl))
,(when first-p '(setq match-p t))
(let ((rval (car rl)))
(setq ret ,(if all-p '(append ret (list rval)) 'rval))))
(setq sl (cdr sl) rl (cdr rl)))
ret)))))
(org-define-lookup-function first)
(org-define-lookup-function last)
(org-define-lookup-function all)
(provide 'org-table)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; org-table.el ends here
org-mode-9.7.29+dfsg/lisp/org-tempo.el 0000664 0000000 0000000 00000014741 15004304337 0017462 0 ustar 00root root 0000000 0000000 ;;; org-tempo.el --- Template expansion for Org structures -*- lexical-binding: t; -*-
;; Copyright (C) 2017-2025 Free Software Foundation, Inc.
;;
;; Author: Rasmus Pank Roulund <emacs at pank dot eu>
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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 <https://www.gnu.org/licenses/>.
;;
;;; Commentary:
;;
;; Org Tempo reimplements completions of structure template before
;; point in Org v9.1 and earlier.
;; For example, strings like "<e" at the beginning of the line will be
;; expanded to an example block.
;;
;; All blocks defined in `org-structure-template-alist' are added as
;; Org Tempo shortcuts, in addition to keywords defined in
;; `org-tempo-keywords-alist'.
;;
;; `tempo' can also be used to define more sophisticated keywords
;; completions. See the section "Additional keywords" below for
;; examples.
;;
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'tempo)
(require 'cl-lib)
(require 'org)
(defvar org-structure-template-alist)
(defgroup org-tempo nil
"Template expansion of Org structures."
:tag "Org structure"
:group 'org)
(defvar org-tempo-tags nil
"Tempo tags for Org mode.")
(defcustom org-tempo-keywords-alist
'(("L" . "latex")
("H" . "html")
("A" . "ascii")
("i" . "index"))
"Keyword completion elements.
This is an alist of KEY characters and corresponding KEYWORDS,
just like `org-structure-template-alist'. The tempo snippet
\"<KEY\" will be expanded using the KEYWORD value. For example
\"<L\" at the beginning of a line is expanded to \"#+latex:\".
Do not use \"I\" as a KEY, as it is reserved for expanding
\"#+include\"."
:type '(repeat (cons (string :tag "Key")
(string :tag "Keyword")))
:package-version '(Org . "9.2"))
;;; Org Tempo functions and setup.
(defun org-tempo-setup ()
"Setup tempo tags and match finder for the current buffer."
(org-tempo--update-maybe)
(tempo-use-tag-list 'org-tempo-tags)
(setq-local tempo-match-finder "^ *\\(<[[:word:]]+\\)\\="))
(defun org-tempo--keys ()
"Return a list of all Org Tempo expansion strings, like \"<s\"."
(mapcar (lambda (pair) (format "<%s" (car pair)))
(append org-structure-template-alist
org-tempo-keywords-alist)))
(defun org-tempo--update-maybe ()
"Check and add new Org Tempo templates if necessary.
In particular, if new entries were added to
`org-structure-template-alist' or `org-tempo-keywords-alist', new
Tempo templates will be added."
(unless (cl-every (lambda (key) (assoc key org-tempo-tags))
(org-tempo--keys))
(org-tempo-add-templates)))
(defun org-tempo-add-templates ()
"Update all Org Tempo templates.
Go through `org-structure-template-alist' and
`org-tempo-keywords-alist' and update tempo templates."
(mapc #'org--check-org-structure-template-alist '(org-structure-template-alist
org-tempo-keywords-alist))
(let ((keys (org-tempo--keys)))
;; Check for duplicated snippet keys and warn if any are found.
(when (> (length keys) (length (delete-dups keys)))
(warn
"Duplicated keys in `org-structure-template-alist' and `org-tempo-keywords-alist'"))
;; Remove any keys already defined in case they have been updated.
(setq org-tempo-tags
(cl-remove-if (lambda (tag) (member (car tag) keys)) org-tempo-tags))
(mapc #'org-tempo-add-block org-structure-template-alist)
(mapc #'org-tempo-add-keyword org-tempo-keywords-alist)))
(defun org-tempo-add-block (entry)
"Add block ENTRY from `org-structure-template-alist'."
(let* ((key (format "<%s" (car entry)))
(name (cdr entry))
(special (member name '("src" "export")))
(upcase? (string= (car (split-string name))
(upcase (car (split-string name))))))
(tempo-define-template (format "org-%s" (replace-regexp-in-string " " "-" name))
`(,(format "#+%s_%s%s"
(if upcase? "BEGIN" "begin")
name
(if special " " ""))
,(when special 'p) '> n ,(unless special 'p) n
,(format "#+%s_%s"
(if upcase? "END" "end")
(car (split-string name " ")))
>)
key
(format "Insert a %s block" name)
'org-tempo-tags)))
(defun org-tempo-add-keyword (entry)
"Add keyword ENTRY from `org-tempo-keywords-alist'."
(let* ((key (format "<%s" (car entry)))
(name (cdr entry)))
(tempo-define-template (format "org-%s" (replace-regexp-in-string " " "-" name))
`(,(format "#+%s: " name) p '>)
key
(format "Insert a %s keyword" name)
'org-tempo-tags)))
(defun org-tempo-complete-tag (&rest _)
"Look for a tag and expand it silently.
Unlike to `tempo-complete-tag', do not give a signal if a partial
completion or no match at all is found. Return nil if expansion
didn't succeed."
(org-tempo--update-maybe)
;; `tempo-complete-tag' returns its SILENT argument when there is no
;; completion available at all.
(not (eq 'fail (tempo-complete-tag 'fail))))
;;; Additional keywords
(defun org-tempo--include-file ()
"Add #+include: and a file name."
(let ((inhibit-quit t))
(unless (with-local-quit
(prog1 t
(insert
(format "#+include: %S "
(file-relative-name
(read-file-name "Include file: "))))))
(insert "<I")
(setq quit-flag nil))))
(tempo-define-template "org-include"
'((org-tempo--include-file)
p >)
"<I"
"Include keyword"
'org-tempo-tags)
;;; Setup of Org Tempo
;;
;; Org Tempo is set up with each new Org buffer and potentially in the
;; current Org buffer.
(add-hook 'org-mode-hook #'org-tempo-setup)
(add-hook 'org-tab-before-tab-emulation-hook #'org-tempo-complete-tag)
;; Enable Org Tempo in all open Org buffers.
(dolist (b (org-buffer-list 'files))
(with-current-buffer b (org-tempo-setup)))
(provide 'org-tempo)
;;; org-tempo.el ends here
org-mode-9.7.29+dfsg/lisp/org-timer.el 0000664 0000000 0000000 00000044231 15004304337 0017453 0 ustar 00root root 0000000 0000000 ;;; org-timer.el --- Timer code for Org mode -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2025 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://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 <https://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;; This file implements two types of timers for Org buffers:
;;
;; - A relative timer that counts up (from 0 or a specified offset)
;; - A countdown timer that counts down from a specified time
;;
;; The relative and countdown timers differ in their entry points.
;; Use `org-timer' or `org-timer-start' to start the relative timer,
;; and `org-timer-set-timer' to start the countdown timer.
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'cl-lib)
(require 'org-clock)
(declare-function org-agenda-error "org-agenda" ())
(defvar org-timer-start-time nil
"Start time for the running timer.")
(defvar org-timer-pause-time nil
"Time when the timer was paused.")
(defvar org-timer-countdown-timer nil
"Current countdown timer.
This is a timer object if there is an active countdown timer,
`paused' if there is a paused countdown timer, and nil
otherwise.")
(defvar org-timer-countdown-timer-title nil
"Title for notification displayed when a countdown finishes.")
(defconst org-timer-re "\\([-+]?[0-9]+\\):\\([0-9]\\{2\\}\\):\\([0-9]\\{2\\}\\)"
"Regular expression used to match timer stamps.")
(defcustom org-timer-format "%s "
"The format to insert the time of the timer.
This format must contain one instance of \"%s\" which will be replaced by
the value of the timer."
:group 'org-time
:type 'string)
(defcustom org-timer-default-timer "0"
"The default timer when a timer is set, in minutes or hh:mm:ss format.
When 0, the user is prompted for a value."
:group 'org-time
:version "26.1"
:package-version '(Org . "8.3")
:type 'string)
(defcustom org-timer-display 'mode-line
"Define where running timer is displayed, if at all.
When a timer is running, Org can display it in the mode line
and/or frame title. Allowed values are:
both displays in both mode line and frame title
mode-line displays only in mode line (default)
frame-title displays only in frame title
nil current timer is not displayed"
:group 'org-time
:type '(choice
(const :tag "Mode line" mode-line)
(const :tag "Frame title" frame-title)
(const :tag "Both" both)
(const :tag "None" nil)))
(defvar org-timer-start-hook nil
"Hook run after relative timer is started.")
(defvar org-timer-stop-hook nil
"Hook run before relative or countdown timer is stopped.")
(defvar org-timer-pause-hook nil
"Hook run before relative or countdown timer is paused.")
(defvar org-timer-continue-hook nil
"Hook run after relative or countdown timer is continued.")
(defvar org-timer-set-hook nil
"Hook run after countdown timer is set.")
(defvar org-timer-done-hook nil
"Hook run after countdown timer reaches zero.")
;;;###autoload
(defun org-timer-start (&optional offset)
"Set the starting time for the relative timer to now.
When called with prefix argument OFFSET, prompt the user for an offset time,
with the default taken from a timer stamp at point, if any.
If OFFSET is a string or an integer, it is directly taken to be the offset
without user interaction.
When called with a double prefix arg, all timer strings in the active
region will be shifted by a specific amount. You will be prompted for
the amount, with the default to make the first timer string in
the region 0:00:00."
(interactive "P")
(cond
((equal offset '(16))
(call-interactively 'org-timer-change-times-in-region))
(org-timer-countdown-timer
(user-error "Countdown timer is running. Cancel first"))
(t
(let (delta def s)
(if (not offset)
(setq org-timer-start-time (current-time))
(cond
((integerp offset) (setq delta offset))
((stringp offset) (setq delta (org-timer-hms-to-secs offset)))
(t
(setq def (if (org-in-regexp org-timer-re)
(match-string 0)
"0:00:00")
s (read-string
(format "Restart timer with offset [%s]: " def)))
(unless (string-match "\\S-" s) (setq s def))
(setq delta (org-timer-hms-to-secs (org-timer-fix-incomplete s)))))
(setq org-timer-start-time (time-since delta)))
(setq org-timer-pause-time nil)
(org-timer-set-mode-line 'on)
(message "Timer start time set to %s, current value is %s"
(format-time-string "%T" org-timer-start-time)
(org-timer-secs-to-hms (or delta 0)))
(run-hooks 'org-timer-start-hook)))))
;;;###autoload
(defun org-timer-pause-or-continue (&optional stop)
"Pause or continue the relative or countdown timer.
With prefix arg STOP, stop it entirely."
(interactive "P")
(cond
(stop (org-timer-stop))
((not org-timer-start-time) (error "No timer is running"))
(org-timer-pause-time
(let ((start-secs (float-time org-timer-start-time))
(pause-secs (float-time org-timer-pause-time)))
(if org-timer-countdown-timer
(let ((new-secs (- start-secs pause-secs)))
(setq org-timer-countdown-timer
(org-timer--run-countdown-timer
new-secs org-timer-countdown-timer-title))
(setq org-timer-start-time (time-add nil new-secs)))
(setq org-timer-start-time
(time-since (- pause-secs start-secs))))
(setq org-timer-pause-time nil)
(org-timer-set-mode-line 'on)
(run-hooks 'org-timer-continue-hook)
(message "Timer continues at %s" (org-timer-value-string))))
(t
;; pause timer
(when org-timer-countdown-timer
(cancel-timer org-timer-countdown-timer)
(setq org-timer-countdown-timer 'paused))
(run-hooks 'org-timer-pause-hook)
(setq org-timer-pause-time (current-time))
(org-timer-set-mode-line 'paused)
(message "Timer paused at %s" (org-timer-value-string)))))
;;;###autoload
(defun org-timer-stop ()
"Stop the relative or countdown timer."
(interactive)
(unless org-timer-start-time
(user-error "No timer running"))
(when (timerp org-timer-countdown-timer)
(cancel-timer org-timer-countdown-timer))
(run-hooks 'org-timer-stop-hook)
(setq org-timer-start-time nil
org-timer-pause-time nil
org-timer-countdown-timer nil)
(org-timer-set-mode-line 'off)
(message "Timer stopped"))
;;;###autoload
(defun org-timer (&optional restart no-insert)
"Insert a H:MM:SS string from the timer into the buffer.
The first time this command is used, the timer is started.
When used with a `\\[universal-argument]' prefix RESTART, force
restarting the timer.
When used with a `\\[universal-argument] \\[universal-argument]' prefix
RESTART, change all the timer strings in the region by a fixed amount.
This can be used to re-calibrate a timer that was not started at the
correct moment.
If NO-INSERT is non-nil, return the string instead of inserting it in
the buffer."
(interactive "P")
(if (equal restart '(16))
(org-timer-start restart)
(when (or (equal restart '(4)) (not org-timer-start-time))
(org-timer-start))
(if no-insert
(org-timer-value-string)
(insert (org-timer-value-string)))))
(defun org-timer-value-string ()
"Return current timer string."
(format org-timer-format
(org-timer-secs-to-hms
(let ((time (- (float-time org-timer-pause-time)
(float-time org-timer-start-time))))
(abs (floor (if org-timer-countdown-timer (- time) time)))))))
;;;###autoload
(defun org-timer-change-times-in-region (beg end delta)
"Change all h:mm:ss time in region BEG..END by a DELTA."
(interactive
"r\nsEnter time difference like \"-1:08:26\". Default is first time to zero: ")
(let ((re "[-+]?[0-9]+:[0-9]\\{2\\}:[0-9]\\{2\\}") p)
(unless (string-match "\\S-" delta)
(save-excursion
(goto-char beg)
(when (re-search-forward re end t)
(setq delta (match-string 0))
(if (equal (string-to-char delta) ?-)
(setq delta (substring delta 1))
(setq delta (concat "-" delta))))))
(setq delta (org-timer-hms-to-secs (org-timer-fix-incomplete delta)))
(when (= delta 0) (error "No change"))
(save-excursion
(goto-char end)
(while (re-search-backward re beg t)
(setq p (point))
(replace-match
(save-match-data
(org-timer-secs-to-hms (+ (org-timer-hms-to-secs (match-string 0)) delta)))
t t)
(goto-char p)))))
;;;###autoload
(defun org-timer-item (&optional arg)
"Insert a description-type item with the current timer value.
Prefix argument ARG is passed to `org-timer'."
(interactive "P")
(let ((itemp (org-in-item-p)) (pos (point)))
(cond
;; In a timer list, insert with `org-list-insert-item',
;; then fix the list.
((and itemp (goto-char itemp) (org-at-item-timer-p))
(let* ((struct (org-list-struct))
(prevs (org-list-prevs-alist struct))
(s (concat (org-timer (when arg '(4)) t) ":: ")))
(setq struct (org-list-insert-item pos struct prevs nil s))
(org-list-write-struct struct (org-list-parents-alist struct))
(looking-at org-list-full-item-re)
(goto-char (match-end 0))))
;; In a list of another type, don't break anything: throw an error.
(itemp (goto-char pos) (error "This is not a timer list"))
;; Else, start a new list.
(t
(forward-line 0)
(org-indent-line)
(insert "- ")
(org-timer (when arg '(4)))
(insert ":: ")))))
(defun org-timer-fix-incomplete (hms)
"If HMS is a H:MM:SS string with missing hour or hour and minute, fix it."
(if (string-match "\\(?:\\([0-9]+:\\)?\\([0-9]+:\\)\\)?\\([0-9]+\\)" hms)
(replace-match
(format "%d:%02d:%02d"
(if (match-end 1) (string-to-number (match-string 1 hms)) 0)
(if (match-end 2) (string-to-number (match-string 2 hms)) 0)
(string-to-number (match-string 3 hms)))
t t hms)
(error "Cannot parse HMS string \"%s\"" hms)))
(defun org-timer-hms-to-secs (hms)
"Convert h:mm:ss (HMS) string to an integer time.
If the string starts with a minus sign, the integer will be negative."
(if (not (string-match
"\\([-+]?[0-9]+\\):\\([0-9]\\{2\\}\\):\\([0-9]\\{2\\}\\)"
hms))
0
(let* ((h (string-to-number (match-string 1 hms)))
(m (string-to-number (match-string 2 hms)))
(s (string-to-number (match-string 3 hms)))
(sign (equal (substring (match-string 1 hms) 0 1) "-")))
(setq h (abs h))
(* (if sign -1 1) (+ s (* 60 (+ m (* 60 h))))))))
(defun org-timer-secs-to-hms (s)
"Convert integer S into h:mm:ss.
If the integer is negative, the string will start with \"-\"."
(let (sign m h)
(setq sign (if (< s 0) "-" "")
s (abs s)
m (/ s 60) s (- s (* 60 m))
h (/ m 60) m (- m (* 60 h)))
(format "%s%d:%02d:%02d" sign h m s)))
(defvar org-timer-mode-line-timer nil)
(defvar org-timer-mode-line-string nil)
(defun org-timer-set-mode-line (value)
"Set the mode-line display for relative or countdown timer.
VALUE can be `on', `off', or `paused'."
(when (or (eq org-timer-display 'mode-line)
(eq org-timer-display 'both))
(or global-mode-string (setq global-mode-string '("")))
(or (memq 'org-timer-mode-line-string global-mode-string)
(setq global-mode-string
(append global-mode-string '(org-timer-mode-line-string)))))
(when (or (eq org-timer-display 'frame-title)
(eq org-timer-display 'both))
(or (memq 'org-timer-mode-line-string frame-title-format)
(setq frame-title-format
(append frame-title-format '(org-timer-mode-line-string)))))
(cl-case value
(off
(when org-timer-mode-line-timer
(cancel-timer org-timer-mode-line-timer)
(setq org-timer-mode-line-timer nil))
(when (or (eq org-timer-display 'mode-line)
(eq org-timer-display 'both))
(setq global-mode-string
(delq 'org-timer-mode-line-string global-mode-string)))
(when (or (eq org-timer-display 'frame-title)
(eq org-timer-display 'both))
(setq frame-title-format
(delq 'org-timer-mode-line-string frame-title-format)))
(force-mode-line-update))
(paused
(when org-timer-mode-line-timer
(cancel-timer org-timer-mode-line-timer)
(setq org-timer-mode-line-timer nil)))
(on
(when (or (eq org-timer-display 'mode-line)
(eq org-timer-display 'both))
(or global-mode-string (setq global-mode-string '("")))
(or (memq 'org-timer-mode-line-string global-mode-string)
(setq global-mode-string
(append global-mode-string '(org-timer-mode-line-string)))))
(when (or (eq org-timer-display 'frame-title)
(eq org-timer-display 'both))
(or (memq 'org-timer-mode-line-string frame-title-format)
(setq frame-title-format
(append frame-title-format '(org-timer-mode-line-string)))))
(org-timer-update-mode-line)
(when org-timer-mode-line-timer
(cancel-timer org-timer-mode-line-timer)
(setq org-timer-mode-line-timer nil))
(when org-timer-display
(setq org-timer-mode-line-timer
(run-with-timer 1 1 #'org-timer-update-mode-line))))))
(defun org-timer-update-mode-line ()
"Update the timer time in the mode line."
(if org-timer-pause-time
nil
(setq org-timer-mode-line-string
(concat " <" (substring (org-timer-value-string) 0 -1) ">"))
(force-mode-line-update)))
(defun org-timer-show-remaining-time ()
"Display the remaining time before the timer ends."
(interactive)
(message
(if (not org-timer-countdown-timer)
"No timer set"
(format-seconds
"%m minute(s) %s seconds left before next time out"
;; Note: Once our minimal require is Emacs 27, we can drop this
;; org-time-convert-to-integer call.
(org-time-convert-to-integer
(time-subtract (timer--time org-timer-countdown-timer) nil))))))
;;;###autoload
(defun org-timer-set-timer (&optional opt)
"Prompt for a duration in minutes or hh:mm:ss and set a timer.
If `org-timer-default-timer' is not \"0\", suggest this value as
the default duration for the timer. If a timer is already set,
prompt the user if she wants to replace it.
Called with a numeric prefix argument OPT, use this numeric value as
the duration of the timer in minutes.
Called with a \\[universal-argument] prefix argument OPT, use
`org-timer-default-timer' without prompting the user for a duration.
With two \\[universal-argument] prefix arguments OPT, use
`org-timer-default-timer' without prompting the user for a duration
and automatically replace any running timer.
By default, the timer duration will be set to the number of
minutes in the Effort property, if any. You can ignore this by
using three \\[universal-argument] prefix arguments."
(interactive "P")
(when (and org-timer-start-time
(not org-timer-countdown-timer))
(user-error "Relative timer is running. Stop first"))
(let* ((default-timer
;; `org-timer-default-timer' used to be a number, don't choke:
(if (numberp org-timer-default-timer)
(number-to-string org-timer-default-timer)
org-timer-default-timer))
(effort-minutes
(cond ((derived-mode-p 'org-agenda-mode)
(org-get-at-bol 'effort-minutes))
((derived-mode-p 'org-mode)
(let ((effort (org-entry-get nil org-effort-property)))
(when (org-string-nw-p effort)
(floor (org-duration-to-minutes effort)))))
(t nil)))
(minutes (or (and (numberp opt) (number-to-string opt))
(and (not (equal opt '(64)))
effort-minutes
(number-to-string effort-minutes))
(and (consp opt) default-timer)
(and (stringp opt) opt)
(read-from-minibuffer
"How much time left? (minutes or h:mm:ss) "
(and (not (string-equal default-timer "0")) default-timer)))))
(when (string-match "\\`[0-9]+\\'" minutes)
(setq minutes (concat minutes ":00")))
(if (not (string-match "[0-9]+" minutes))
(org-timer-show-remaining-time)
(let ((secs (org-timer-hms-to-secs (org-timer-fix-incomplete minutes))))
(if (and org-timer-countdown-timer
(not (or (equal opt '(16))
(y-or-n-p "Replace current timer? "))))
(message "No timer set")
(when (timerp org-timer-countdown-timer)
(cancel-timer org-timer-countdown-timer))
(setq org-timer-countdown-timer-title
(org-timer--get-timer-title))
(setq org-timer-countdown-timer
(org-timer--run-countdown-timer
secs org-timer-countdown-timer-title))
(run-hooks 'org-timer-set-hook)
(setq org-timer-start-time (time-add nil secs))
(setq org-timer-pause-time nil)
(org-timer-set-mode-line 'on))))))
(defun org-timer--run-countdown-timer (secs title)
"Start countdown timer that will last SECS.
TITLE will be appended to the notification message displayed when
time is up."
(let ((msg (format "%s: time out" title))
(sound org-clock-sound))
(run-with-timer
secs nil (lambda ()
(setq org-timer-countdown-timer nil
org-timer-start-time nil)
(org-notify msg sound)
(org-timer-set-mode-line 'off)
(run-hooks 'org-timer-done-hook)))))
(defun org-timer--get-timer-title ()
"Construct timer title.
Try to use an Org header, otherwise use the buffer name."
(cond
((derived-mode-p 'org-agenda-mode)
(let* ((marker (or (get-text-property (point) 'org-marker)))
(hdmarker (or (get-text-property (point) 'org-hd-marker)
marker)))
(when (and marker (marker-buffer marker))
(with-current-buffer (marker-buffer marker)
(org-with-wide-buffer
(goto-char hdmarker)
(or (ignore-errors (org-get-heading))
(buffer-name (buffer-base-buffer))))))))
((derived-mode-p 'org-mode)
(ignore-errors (org-get-heading)))
(t (buffer-name (buffer-base-buffer)))))
(provide 'org-timer)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; org-timer.el ends here
org-mode-9.7.29+dfsg/lisp/org.el 0000664 0000000 0000000 00003320526 15004304337 0016344 0 ustar 00root root 0000000 0000000 ;;; org.el --- Outline-based notes management and organizer -*- lexical-binding: t; -*-
;; Carstens outline-mode for keeping track of everything.
;; Copyright (C) 2004-2025 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
;; Maintainer: Bastien Guerry <bzg@gnu.org>
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;; Package-Requires: ((emacs "26.1"))
;; Version: 9.7.29
;; 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 <https://www.gnu.org/licenses/>.
;;
;;; Commentary:
;;
;; Org is a mode for keeping notes, maintaining ToDo lists, and doing
;; project planning with a fast and effective plain-text system.
;;
;; Org mode develops organizational tasks around NOTES files that
;; contain information about projects as plain text. Org mode is
;; implemented on top of outline-mode, which makes it possible to keep
;; the content of large files well structured. Visibility cycling and
;; structure editing help to work with the tree. Tables are easily
;; created with a built-in table editor. Org mode supports ToDo
;; items, deadlines, time stamps, and scheduling. It dynamically
;; compiles entries into an agenda that utilizes and smoothly
;; integrates much of the Emacs calendar and diary. Plain text
;; URL-like links connect to websites, emails, Usenet messages, BBDB
;; entries, and any files related to the projects. For printing and
;; sharing of notes, an Org file can be exported as a structured ASCII
;; file, as HTML, or (todo and agenda items only) as an iCalendar
;; file. It can also serve as a publishing tool for a set of linked
;; webpages.
;;
;; Installation and Activation
;; ---------------------------
;; See the corresponding sections in the manual at
;;
;; https://orgmode.org/org.html#Installation
;;
;; Documentation
;; -------------
;; The documentation of Org mode can be found in the TeXInfo file. The
;; distribution also contains a PDF version of it. At the Org mode website,
;; you can read the same text online as HTML. There is also an excellent
;; reference card made by Philip Rooke. This card can be found in the
;; doc/ directory.
;;
;; A list of recent changes can be found at
;; https://orgmode.org/Changes.html
;;
;;; Code:
(defvar org-inhibit-highlight-removal nil) ; dynamically scoped param
(defvar org-inlinetask-min-level)
;;;; Require other packages
(require 'org-compat)
(org-assert-version)
(require 'cl-lib)
(eval-when-compile (require 'gnus-sum))
(require 'calendar)
(require 'find-func)
(require 'format-spec)
(require 'thingatpt)
(condition-case nil
(load (concat (file-name-directory load-file-name)
"org-loaddefs")
nil t nil t)
(error
(message "WARNING: No org-loaddefs.el file could be found from where org.el is loaded.")
(sit-for 3)
(message "You need to run \"make\" or \"make autoloads\" from Org lisp directory")
(sit-for 3)))
(eval-and-compile (require 'org-macs))
(require 'org-compat)
(require 'org-keys)
(require 'ol)
(require 'oc)
(require 'org-table)
(require 'org-fold)
(require 'org-cycle)
(defalias 'org-global-cycle #'org-cycle-global)
(defalias 'org-overview #'org-cycle-overview)
(defalias 'org-content #'org-cycle-content)
(defalias 'org-reveal #'org-fold-reveal)
(defalias 'org-force-cycle-archived #'org-cycle-force-archived)
;; `org-outline-regexp' ought to be a defconst but is let-bound in
;; some places -- e.g. see the macro `org-with-limited-levels'.
(defvar org-outline-regexp "\\*+ "
"Regexp to match Org headlines.")
(defvar org-outline-regexp-bol "^\\*+ "
"Regexp to match Org headlines.
This is similar to `org-outline-regexp' but additionally makes
sure that we are at the beginning of the line.")
(defvar org-heading-regexp "^\\(\\*+\\)\\(?: +\\(.*?\\)\\)?[ \t]*$"
"Matches a headline, putting stars and text into groups.
Stars are put in group 1 and the trimmed body in group 2.")
(declare-function calendar-check-holidays "holidays" (date))
(declare-function cdlatex-environment "ext:cdlatex" (environment item))
(declare-function cdlatex-math-symbol "ext:cdlatex")
(declare-function Info-goto-node "info" (nodename &optional fork strict-case))
(declare-function isearch-no-upper-case-p "isearch" (string regexp-flag))
(declare-function org-add-archive-files "org-archive" (files))
(declare-function org-agenda-entry-get-agenda-timestamp "org-agenda" (pom))
(declare-function org-agenda-todo-yesterday "org-agenda" (&optional arg))
(declare-function org-agenda-list "org-agenda" (&optional arg start-day span with-hour))
(declare-function org-agenda-redo "org-agenda" (&optional all))
(declare-function org-agenda-remove-restriction-lock "org-agenda" (&optional noupdate))
(declare-function org-archive-subtree "org-archive" (&optional find-done))
(declare-function org-archive-subtree-default "org-archive" ())
(declare-function org-archive-to-archive-sibling "org-archive" ())
(declare-function org-attach "org-attach" ())
(declare-function org-attach-dir "org-attach"
(&optional create-if-not-exists-p no-fs-check))
(declare-function org-babel-do-in-edit-buffer "ob-core" (&rest body) t)
(declare-function org-babel-tangle-file "ob-tangle" (file &optional target-file lang))
(declare-function org-beamer-mode "ox-beamer" (&optional prefix) t)
(declare-function org-clock-auto-clockout "org-clock" ())
(declare-function org-clock-cancel "org-clock" ())
(declare-function org-clock-display "org-clock" (&optional arg))
(declare-function org-clock-get-last-clock-out-time "org-clock" ())
(declare-function org-clock-goto "org-clock" (&optional select))
(declare-function org-clock-in "org-clock" (&optional select start-time))
(declare-function org-clock-in-last "org-clock" (&optional arg))
(declare-function org-clock-out "org-clock" (&optional switch-to-state fail-quietly at-time))
(declare-function org-clock-out-if-current "org-clock" ())
(declare-function org-clock-remove-overlays "org-clock" (&optional beg end noremove))
(declare-function org-clock-report "org-clock" (&optional arg))
(declare-function org-clock-sum "org-clock" (&optional tstart tend headline-filter propname))
(declare-function org-clock-sum-current-item "org-clock" (&optional tstart))
(declare-function org-clock-timestamps-down "org-clock" (&optional n))
(declare-function org-clock-timestamps-up "org-clock" (&optional n))
(declare-function org-clock-update-time-maybe "org-clock" ())
(declare-function org-clocktable-shift "org-clock" (dir n))
(declare-function org-columns-quit "org-colview" ())
(declare-function org-columns-insert-dblock "org-colview" ())
(declare-function org-duration-from-minutes "org-duration" (minutes &optional fmt canonical))
(declare-function org-duration-to-minutes "org-duration" (duration &optional canonical))
(declare-function org-element-at-point "org-element" (&optional pom cached-only))
(declare-function org-element-at-point-no-context "org-element" (&optional pom))
(declare-function org-element-cache-refresh "org-element" (pos))
(declare-function org-element-cache-reset "org-element" (&optional all no-persistence))
(declare-function org-element-cache-map "org-element" (func &rest keys))
(declare-function org-element-contents "org-element-ast" (node))
(declare-function org-element-context "org-element" (&optional element))
(declare-function org-element-copy "org-element-ast" (datum))
(declare-function org-element-create "org-element-ast" (type &optional props &rest children))
(declare-function org-element-extract "org-element-ast" (node))
(declare-function org-element-insert-before "org-element-ast" (node location))
(declare-function org-element-interpret-data "org-element" (data))
(declare-function org-element-keyword-parser "org-element" (limit affiliated))
(declare-function org-element-lineage "org-element-ast" (blob &optional types with-self))
(declare-function org-element-property-inherited "org-element-ast"
(property node &optional with-self accumulate literal-nil include-nil))
(declare-function org-element-lineage-map "org-element-ast"
(datum fun &optional types with-self first-match))
(declare-function org-element-link-parser "org-element" ())
(declare-function org-element-map "org-element" (data types fun &optional info first-match no-recursion with-affiliated))
(declare-function org-element-nested-p "org-element" (elem-a elem-b))
(declare-function org-element-parse-buffer "org-element" (&optional granularity visible-only keep-deferred))
(declare-function org-element-parse-secondary-string "org-element" (string restriction &optional parent))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-begin "org-element" (node))
(declare-function org-element-end "org-element" (node))
(declare-function org-element-contents-begin "org-element" (node))
(declare-function org-element-contents-end "org-element" (node))
(declare-function org-element-post-affiliated "org-element" (node))
(declare-function org-element-post-blank "org-element" (node))
(declare-function org-element-parent "org-element-ast" (node))
(declare-function org-element-put-property "org-element-ast" (node property value))
(declare-function org-element-restriction "org-element" (element))
(declare-function org-element-swap-A-B "org-element" (elem-a elem-b))
(declare-function org-element-timestamp-parser "org-element" ())
(declare-function org-element-type "org-element-ast" (node &optional anonymous))
(declare-function org-element-type-p "org-element-ast" (node types))
(declare-function org-export-dispatch "ox" (&optional arg))
(declare-function org-export-get-backend "ox" (name))
(declare-function org-export-get-environment "ox" (&optional backend subtreep ext-plist))
(declare-function org-feed-goto-inbox "org-feed" (feed))
(declare-function org-feed-update-all "org-feed" ())
(declare-function org-goto "org-goto" (&optional alternative-interface))
(declare-function org-id-find-id-file "org-id" (id))
(declare-function org-id-get-create "org-id" (&optional force))
(declare-function org-inlinetask-at-task-p "org-inlinetask" ())
(declare-function org-inlinetask-outline-regexp "org-inlinetask" ())
(declare-function org-inlinetask-toggle-visibility "org-inlinetask" ())
(declare-function org-latex-make-preamble "ox-latex" (info &optional template snippet?))
(declare-function org-num-mode "org-num" (&optional arg))
(declare-function org-plot/gnuplot "org-plot" (&optional params))
(declare-function org-persist-load "org-persist")
(declare-function org-tags-view "org-agenda" (&optional todo-only match))
(declare-function org-timer "org-timer" (&optional restart no-insert))
(declare-function org-timer-item "org-timer" (&optional arg))
(declare-function org-timer-pause-or-continue "org-timer" (&optional stop))
(declare-function org-timer-set-timer "org-timer" (&optional opt))
(declare-function org-timer-start "org-timer" (&optional offset))
(declare-function org-timer-stop "org-timer" ())
(declare-function org-toggle-archive-tag "org-archive" (&optional find-done))
(declare-function org-update-radio-target-regexp "ol" ())
(defvar org-agenda-buffer-name)
(defvar org-element-paragraph-separate)
(defvar org-element-cache-map-continue-from)
(defvar org-element--timestamp-regexp)
(defvar org-indent-indentation-per-level)
(defvar org-radio-target-regexp)
(defvar org-target-link-regexp)
(defvar org-target-regexp)
(defvar org-id-overriding-file-name)
;; load languages based on value of `org-babel-load-languages'
(defvar org-babel-load-languages)
(defvar crm-separator) ; dynamically scoped param
;;;###autoload
(defun org-babel-do-load-languages (sym value)
"Load the languages defined in `org-babel-load-languages'."
(set-default-toplevel-value sym value)
(dolist (pair org-babel-load-languages)
(let ((active (cdr pair)) (lang (symbol-name (car pair))))
(if active
(require (intern (concat "ob-" lang)))
(fmakunbound
(intern (concat "org-babel-execute:" lang)))
(fmakunbound
(intern (concat "org-babel-expand-body:" lang)))))))
;;;###autoload
(defun org-babel-load-file (file &optional compile)
"Load Emacs Lisp source code blocks in the Org FILE.
This function exports the source code using `org-babel-tangle'
and then loads the resulting file using `load-file'. With
optional prefix argument COMPILE, the tangled Emacs Lisp file is
byte-compiled before it is loaded."
(interactive "fFile to load: \nP")
(let ((tangled-file (concat (file-name-sans-extension file) ".el")))
;; Tangle only if the Elisp file is older than the Org file.
;; Catch the case when the .el file exists while the .org file is missing.
(unless (file-exists-p file)
(error "File to tangle does not exist: %s" file))
(when (file-newer-than-file-p file tangled-file)
(org-babel-tangle-file file
tangled-file
(rx string-start
(or "emacs-lisp" "elisp")
string-end))
;; Make sure that tangled file modification time is
;; updated even when `org-babel-tangle-file' does not make changes.
;; This avoids re-tangling changed FILE where the changes did
;; not affect the tangled code.
(when (file-exists-p tangled-file)
(set-file-times tangled-file)))
(if compile
(progn
(byte-compile-file tangled-file)
(load-file (byte-compile-dest-file tangled-file))
(message "Compiled and loaded %s" tangled-file))
(load-file tangled-file)
(message "Loaded %s" tangled-file))))
(defcustom org-babel-load-languages '((emacs-lisp . t))
"Languages which can be evaluated in Org buffers.
\\<org-mode-map>
This list can be used to load support for any of the available
languages with babel support (see info node `(org) Languages'). Each
language will depend on a different set of system executables and/or
Emacs modes.
When a language is \"loaded\", code blocks in that language can
be evaluated with `org-babel-execute-src-block', which is bound
by default to \\[org-ctrl-c-ctrl-c].
The `org-babel-no-eval-on-ctrl-c-ctrl-c' option can be set to
remove code block evaluation from \\[org-ctrl-c-ctrl-c]. By
default, only Emacs Lisp is loaded, since it has no specific
requirement."
:group 'org-babel
:set 'org-babel-do-load-languages
:package-version '(Org . "9.6")
:type '(alist :tag "Babel Languages"
:key-type
(choice
(const :tag "Awk" awk)
(const :tag "C, D, C++, and cpp" C)
(const :tag "R" R)
(const :tag "Calc" calc)
(const :tag "Clojure and ClojureScript" clojure)
(const :tag "CSS" css)
(const :tag "Ditaa" ditaa)
(const :tag "Dot" dot)
(const :tag "Emacs Lisp" emacs-lisp)
(const :tag "Eshell" eshell)
(const :tag "Forth" forth)
(const :tag "Fortran" fortran)
(const :tag "GnuPlot" gnuplot)
(const :tag "Groovy" groovy)
(const :tag "Haskell" haskell)
(const :tag "Java" java)
(const :tag "JavaScript" js)
(const :tag "Julia" julia)
(const :tag "LaTeX" latex)
(const :tag "LilyPond" lilypond)
(const :tag "Lisp" lisp)
(const :tag "Lua" lua)
(const :tag "Makefile" makefile)
(const :tag "Maxima" maxima)
(const :tag "OCaml" ocaml)
(const :tag "Octave and MatLab" octave)
(const :tag "Org" org)
(const :tag "Perl" perl)
(const :tag "Processing" processing)
(const :tag "PlantUML" plantuml)
(const :tag "Python" python)
(const :tag "Ruby" ruby)
(const :tag "Sass" sass)
(const :tag "Scheme" scheme)
(const :tag "Screen" screen)
(const :tag "Sed" sed)
(const :tag "Shell Script" shell)
(const :tag "Sql" sql)
(const :tag "Sqlite" sqlite))
:value-type (boolean :tag "Activate" :value t)))
;;;; Customization variables
(defcustom org-clone-delete-id nil
"Remove ID property of clones of a subtree.
When non-nil, clones of a subtree don't inherit the ID property.
Otherwise they inherit the ID property with a new unique
identifier."
:type 'boolean
:version "24.1"
:group 'org-id)
;;; Version
(org-check-version)
;;;###autoload
(defun org-version (&optional here full message)
"Show the Org version.
Interactively, or when MESSAGE is non-nil, show it in echo area.
With prefix argument, or when HERE is non-nil, insert it at point.
In non-interactive uses, a reduced version string is output unless
FULL is given."
(interactive (list current-prefix-arg t (not current-prefix-arg)))
(let ((org-dir (ignore-errors (org-find-library-dir "org")))
(save-load-suffixes load-suffixes)
(load-suffixes (list ".el"))
(org-install-dir
(ignore-errors (org-find-library-dir "org-loaddefs"))))
(unless (and (fboundp 'org-release) (fboundp 'org-git-version))
(org-load-noerror-mustsuffix (concat org-dir "org-version")))
(let* ((load-suffixes save-load-suffixes)
(release (org-release))
(git-version (org-git-version))
(version (format "Org mode version %s (%s @ %s)"
release
git-version
(if org-install-dir
(if (string= org-dir org-install-dir)
org-install-dir
(concat "mixed installation! "
org-install-dir
" and "
org-dir))
"org-loaddefs.el can not be found!")))
(version1 (if full version release)))
(when here (insert version1))
(when message (message "%s" version1))
version1)))
(defconst org-version (org-version))
;;; Syntax Constants
;;;; Comments
(defconst org-comment-regexp
(rx (seq bol (zero-or-more (any "\t ")) "#" (or " " eol)))
"Regular expression for comment lines.")
;;;; Keyword
(defconst org-keyword-regexp "^[ \t]*#\\+\\(\\S-+?\\):[ \t]*\\(.*\\)$"
"Regular expression for keyword-lines.")
;;;; Block
(defconst org-block-regexp
"^[ \t]*#\\+begin_?\\([^ \n]+\\)\\(\\([^\n]+\\)\\)?\n\\(\\(?:.\\|\n\\)+?\\)#\\+end_?\\1[ \t]*$"
"Regular expression for hiding blocks.")
(defconst org-dblock-start-re
"^[ \t]*#\\+\\(?:BEGIN\\|begin\\):[ \t]+\\(\\S-+\\)\\([ \t]+\\(.*\\)\\)?"
"Matches the start line of a dynamic block, with parameters.")
(defconst org-dblock-end-re "^[ \t]*#\\+\\(?:END\\|end\\)\\([: \t\r\n]\\|$\\)"
"Matches the end of a dynamic block.")
;;;; Timestamp
(defconst org-ts--internal-regexp
(rx (seq
(= 4 digit) "-" (= 2 digit) "-" (= 2 digit)
(optional " " (*? nonl))))
"Regular expression matching the innards of a time stamp.")
(defconst org-ts-regexp (format "<\\(%s\\)>" org-ts--internal-regexp)
"Regular expression for fast time stamp matching.")
(defconst org-ts-regexp-inactive
(format "\\[\\(%s\\)\\]" org-ts--internal-regexp)
"Regular expression for fast inactive time stamp matching.")
(defconst org-ts-regexp-both (format "[[<]\\(%s\\)[]>]" org-ts--internal-regexp)
"Regular expression for fast time stamp matching.")
(defconst org-ts-regexp0
"\\(\\([0-9]\\{4\\}\\)-\\([0-9]\\{2\\}\\)-\\([0-9]\\{2\\}\\)\\( +[^]+0-9>\r\n -]+\\)?\\( +\\([0-9]\\{1,2\\}\\):\\([0-9]\\{2\\}\\)\\)?\\)"
"Regular expression matching time strings for analysis.
This one does not require the space after the date, so it can be used
on a string that terminates immediately after the date.")
(defconst org-ts-regexp1 "\\(\\([0-9]\\{4\\}\\)-\\([0-9]\\{2\\}\\)-\\([0-9]\\{2\\}\\)\\(?: *\\([^]+0-9>\r\n -]+\\)\\)?\\( \\([0-9]\\{1,2\\}\\):\\([0-9]\\{2\\}\\)\\)?\\)"
"Regular expression matching time strings for analysis.")
(defconst org-ts-regexp2 (concat "<" org-ts-regexp1 "[^>\n]\\{0,16\\}>")
"Regular expression matching time stamps, with groups.")
(defconst org-ts-regexp3 (concat "[[<]" org-ts-regexp1 "[^]>\n]\\{0,16\\}[]>]")
"Regular expression matching time stamps (also [..]), with groups.")
(defconst org-tr-regexp (concat org-ts-regexp "--?-?" org-ts-regexp)
"Regular expression matching a time stamp range.")
(defconst org-tr-regexp-both
(concat org-ts-regexp-both "--?-?" org-ts-regexp-both)
"Regular expression matching a time stamp range.")
(defconst org-tsr-regexp (concat org-ts-regexp "\\(--?-?"
org-ts-regexp "\\)?")
"Regular expression matching a time stamp or time stamp range.")
(defconst org-tsr-regexp-both
(concat org-ts-regexp-both "\\(--?-?"
org-ts-regexp-both "\\)?")
"Regular expression matching a time stamp or time stamp range.
The time stamps may be either active or inactive.")
(defconst org-repeat-re
"<[0-9]\\{4\\}-[0-9][0-9]-[0-9][0-9] [^>\n]*?\
\\([.+]?\\+[0-9]+[hdwmy]\\(/[0-9]+[hdwmy]\\)?\\)"
"Regular expression for specifying repeated events.
After a match, group 1 contains the repeat expression.")
(defvaralias 'org-time-stamp-formats 'org-timestamp-formats)
(defconst org-timestamp-formats '("%Y-%m-%d %a" . "%Y-%m-%d %a %H:%M")
"Formats for `format-time-string' which are used for time stamps.
The value is a cons cell containing two strings. The `car' and `cdr'
of the cons cell are used to format time stamps that do not and do
contain time, respectively.
Leading \"<\"/\"[\" and trailing \">\"/\"]\" pair will be stripped
from the format strings.
Also, see `org-time-stamp-format'.")
;;;; Clock and Planning
(defconst org-clock-string "CLOCK:"
"String used as prefix for timestamps clocking work hours on an item.")
(defvar org-closed-string "CLOSED:"
"String used as the prefix for timestamps logging closing a TODO entry.")
(defvar org-deadline-string "DEADLINE:"
"String to mark deadline entries.
\\<org-mode-map>
A deadline is this string, followed by a time stamp. It must be
a word, terminated by a colon. You can insert a schedule keyword
and a timestamp with `\\[org-deadline]'.")
(defvar org-scheduled-string "SCHEDULED:"
"String to mark scheduled TODO entries.
\\<org-mode-map>
A schedule is this string, followed by a time stamp. It must be
a word, terminated by a colon. You can insert a schedule keyword
and a timestamp with `\\[org-schedule]'.")
(defconst org-ds-keyword-length
(+ 2
(apply #'max
(mapcar #'length
(list org-deadline-string org-scheduled-string
org-clock-string org-closed-string))))
"Maximum length of the DEADLINE and SCHEDULED keywords.")
(defconst org-planning-line-re
(concat "^[ \t]*"
(regexp-opt
(list org-closed-string org-deadline-string org-scheduled-string)
t))
"Matches a line with planning info.
Matched keyword is in group 1.")
(defconst org-clock-line-re
(concat "^[ \t]*" org-clock-string)
"Matches a line with clock info.")
(defconst org-deadline-regexp (concat "\\<" org-deadline-string)
"Matches the DEADLINE keyword.")
(defconst org-deadline-time-regexp
(concat "\\<" org-deadline-string " *<\\([^>]+\\)>")
"Matches the DEADLINE keyword together with a time stamp.")
(defconst org-deadline-time-hour-regexp
(concat "\\<" org-deadline-string
" *<\\([^>]+[0-9]\\{1,2\\}:[0-9]\\{2\\}[0-9+:hdwmy/ \t.-]*\\)>")
"Matches the DEADLINE keyword together with a time-and-hour stamp.")
(defconst org-deadline-line-regexp
(concat "\\<\\(" org-deadline-string "\\).*")
"Matches the DEADLINE keyword and the rest of the line.")
(defconst org-scheduled-regexp (concat "\\<" org-scheduled-string)
"Matches the SCHEDULED keyword.")
(defconst org-scheduled-time-regexp
(concat "\\<" org-scheduled-string " *<\\([^>]+\\)>")
"Matches the SCHEDULED keyword together with a time stamp.")
(defconst org-scheduled-time-hour-regexp
(concat "\\<" org-scheduled-string
" *<\\([^>]+[0-9]\\{1,2\\}:[0-9]\\{2\\}[0-9+:hdwmy/ \t.-]*\\)>")
"Matches the SCHEDULED keyword together with a time-and-hour stamp.")
(defconst org-closed-time-regexp
(concat "\\<" org-closed-string " *\\[\\([^]]+\\)\\]")
"Matches the CLOSED keyword together with a time stamp.")
(defconst org-keyword-time-regexp
(concat "\\<"
(regexp-opt
(list org-scheduled-string org-deadline-string org-closed-string
org-clock-string)
t)
" *[[<]\\([^]>]+\\)[]>]")
"Matches any of the 4 keywords, together with the time stamp.")
(defconst org-keyword-time-not-clock-regexp
(concat
"\\<"
(regexp-opt
(list org-scheduled-string org-deadline-string org-closed-string) t)
" *[[<]\\([^]>]+\\)[]>]")
"Matches any of the 3 keywords, together with the time stamp.")
(defconst org-all-time-keywords
(mapcar (lambda (w) (substring w 0 -1))
(list org-scheduled-string org-deadline-string
org-clock-string org-closed-string))
"List of time keywords.")
;;;; Drawer
(defconst org-drawer-regexp
;; FIXME: Duplicate of `org-element-drawer-re'.
(rx line-start (0+ (any ?\s ?\t))
":" (group (1+ (any ?- ?_ word))) ":"
(0+ (any ?\s ?\t)) line-end)
"Matches first or last line of a hidden block.
Group 1 contains drawer's name or \"END\".")
(defconst org-property-start-re "^[ \t]*:PROPERTIES:[ \t]*$"
"Regular expression matching the first line of a property drawer.")
(defconst org-property-end-re "^[ \t]*:END:[ \t]*$"
"Regular expression matching the last line of a property drawer.")
(defconst org-clock-drawer-start-re "^[ \t]*:CLOCK:[ \t]*$"
"Regular expression matching the first line of a clock drawer.")
(defconst org-clock-drawer-end-re "^[ \t]*:END:[ \t]*$"
"Regular expression matching the last line of a clock drawer.")
(defconst org-logbook-drawer-re
(rx (seq bol (0+ (any "\t ")) ":LOGBOOK:" (0+ (any "\t ")) "\n"
(*? (0+ nonl) "\n")
(0+ (any "\t ")) ":END:" (0+ (any "\t ")) eol))
"Matches an entire LOGBOOK drawer.")
(defconst org-property-drawer-re
(concat "^[ \t]*:PROPERTIES:[ \t]*\n"
"\\(?:[ \t]*:\\S-+:\\(?:[ \t].*\\)?[ \t]*\n\\)*?"
"[ \t]*:END:[ \t]*$")
"Matches an entire property drawer.")
(defconst org-clock-drawer-re
(concat "\\(" org-clock-drawer-start-re "\\)\\(?:.\\|\n\\)*?\\("
org-clock-drawer-end-re "\\)\n?")
"Matches an entire clock drawer.")
;;;; Headline
(defconst org-heading-keyword-regexp-format
"^\\(\\*+\\)\\(?: +%s\\)\\(?: +\\(.*?\\)\\)?[ \t]*$"
"Printf format for a regexp matching a headline with some keyword.
This regexp will match the headline of any node which has the
exact keyword that is put into the format. The keyword isn't in
any group by default, but the stars and the body are.")
(defconst org-heading-keyword-maybe-regexp-format
"^\\(\\*+\\)\\(?: +%s\\)?\\(?: +\\(.*?\\)\\)?[ \t]*$"
"Printf format for a regexp matching a headline, possibly with some keyword.
This regexp can match any headline with the specified keyword, or
without a keyword. The keyword isn't in any group by default,
but the stars and the body are.")
(defconst org-archive-tag "ARCHIVE"
"The tag that marks a subtree as archived.
An archived subtree does not open during visibility cycling, and does
not contribute to the agenda listings.")
(defconst org-tag-re "[[:alnum:]_@#%]+"
"Regexp matching a single tag.")
(defconst org-tag-group-re "[ \t]+\\(:\\([[:alnum:]_@#%:]+\\):\\)[ \t]*$"
"Regexp matching the tag group at the end of a line, with leading spaces.
Tags are stored in match group 1. Match group 2 stores the tags
without the enclosing colons.")
(defconst org-tag-line-re
"^\\*+ \\(?:.*[ \t]\\)?\\(:\\([[:alnum:]_@#%:]+\\):\\)[ \t]*$"
"Regexp matching tags in a headline.
Tags are stored in match group 1. Match group 2 stores the tags
without the enclosing colons.")
(eval-and-compile
(defconst org-comment-string "COMMENT"
"Entries starting with this keyword will never be exported.
\\<org-mode-map>
An entry can be toggled between COMMENT and normal with
`\\[org-toggle-comment]'."))
;;;; LaTeX Environments and Fragments
(defconst org-latex-regexps
'(("begin" "^[ \t]*\\(\\\\begin{\\([a-zA-Z0-9\\*]+\\)\\(?:.\\|\n\\)+?\\\\end{\\2}\\)" 1 t)
;; ("$" "\\([ \t(]\\|^\\)\\(\\(\\([$]\\)\\([^ \t\n,.$].*?\\(\n.*?\\)\\{0,5\\}[^ \t\n,.$]\\)\\4\\)\\)\\([ \t.,?;:'\")]\\|$\\)" 2 nil)
("$1" "\\([^$]\\|^\\)\\(\\$[^ \t\r\n,;.$]\\$\\)\\(\\s.\\|\\s-\\|\\s(\\|\\s)\\|\\s\"\\|'\\|$\\)" 2 nil)
("$" "\\([^$]\\|^\\)\\(\\(\\$\\([^ \t\n,;.$][^$\n\r]*?\\(\n[^$\n\r]*?\\)\\{0,2\\}[^ \t\n,.$]\\)\\$\\)\\)\\(\\s.\\|\\s-\\|\\s(\\|\\s)\\|\\s\"\\|'\\|$\\)" 2 nil)
("\\(" "\\\\(\\(?:.\\|\n\\)*?\\\\)" 0 nil)
("\\[" "\\\\\\[\\(?:.\\|\n\\)*?\\\\\\]" 0 nil)
("$$" "\\$\\$\\(?:.\\|\n\\)*?\\$\\$" 0 nil))
"Regular expressions for matching embedded LaTeX.")
;;;; Node Property
(defconst org-effort-property "Effort"
"The property that is being used to keep track of effort estimates.
Effort estimates given in this property need to be in the format
defined in org-duration.el.")
;;; The custom variables
(defgroup org nil
"Outline-based notes management and organizer."
:tag "Org"
:group 'outlines
:group 'calendar)
(defcustom org-mode-hook nil
"Mode hook for Org mode, run after the mode was turned on."
:group 'org
:type 'hook)
(defcustom org-load-hook nil
"Hook that is run after org.el has been loaded."
:group 'org
:type 'hook)
(make-obsolete-variable
'org-load-hook
"use `with-eval-after-load' instead." "9.5")
(defcustom org-log-buffer-setup-hook nil
"Hook that is run after an Org log buffer is created."
:group 'org
:version "24.1"
:type 'hook)
(defvar org-modules) ; defined below
(defvar org-modules-loaded nil
"Have the modules been loaded already?")
;;;###autoload
(defun org-load-modules-maybe (&optional force)
"Load all extensions listed in `org-modules'."
(when (or force (not org-modules-loaded))
(dolist (ext org-modules)
(condition-case-unless-debug nil (require ext)
(error (message "Problems while trying to load feature `%s'" ext))))
(setq org-modules-loaded t)))
(defun org-set-modules (var value)
"Set VAR to VALUE and call `org-load-modules-maybe' with the force flag."
(set-default-toplevel-value var value)
(when (featurep 'org)
(org-load-modules-maybe 'force)
;; FIXME: We can't have all the requires at top-level due to
;; circular dependencies. Yet, this function might sometimes be
;; called when 'org-element is not loaded.
(require 'org-element)
(org-element-cache-reset 'all)))
(defcustom org-modules '(ol-doi ol-w3m ol-bbdb ol-bibtex ol-docview ol-gnus ol-info ol-irc ol-mhe ol-rmail ol-eww)
"Modules that should always be loaded together with org.el.
If a description starts with <C>, the file is not part of Emacs and Org mode,
so loading it will require that you have properly installed org-contrib
package from NonGNU Emacs Lisp Package Archive
https://elpa.nongnu.org/nongnu/org-contrib.html
You can also use this system to load external packages (i.e. neither Org
core modules, nor org-contrib modules). Just add symbols
to the end of the list. If the package is called org-xyz.el, then you need
to add the symbol `xyz', and the package must have a call to:
(provide \\='org-xyz)
For export specific modules, see also `org-export-backends'."
:group 'org
:set 'org-set-modules
:package-version '(Org . "9.5")
:type
'(set :greedy t
(const :tag " bbdb: Links to BBDB entries" ol-bbdb)
(const :tag " bibtex: Links to BibTeX entries" ol-bibtex)
(const :tag " crypt: Encryption of subtrees" org-crypt)
(const :tag " ctags: Access to Emacs tags with links" org-ctags)
(const :tag " docview: Links to Docview buffers" ol-docview)
(const :tag " doi: Links to DOI references" ol-doi)
(const :tag " eww: Store link to URL of Eww" ol-eww)
(const :tag " gnus: Links to GNUS folders/messages" ol-gnus)
(const :tag " habit: Track your consistency with habits" org-habit)
(const :tag " id: Global IDs for identifying entries" org-id)
(const :tag " info: Links to Info nodes" ol-info)
(const :tag " inlinetask: Tasks independent of outline hierarchy" org-inlinetask)
(const :tag " irc: Links to IRC/ERC chat sessions" ol-irc)
(const :tag " mhe: Links to MHE folders/messages" ol-mhe)
(const :tag " mouse: Additional mouse support" org-mouse)
(const :tag " protocol: Intercept calls from emacsclient" org-protocol)
(const :tag " rmail: Links to RMAIL folders/messages" ol-rmail)
(const :tag " tempo: Fast completion for structures" org-tempo)
(const :tag " w3m: Special cut/paste from w3m to Org mode." ol-w3m)
(const :tag " eshell: Links to working directories in Eshell" ol-eshell)
(const :tag "C annotate-file: Annotate a file with Org syntax" org-annotate-file)
(const :tag "C bookmark: Links to bookmarks" ol-bookmark)
(const :tag "C checklist: Extra functions for checklists in repeated tasks" org-checklist)
(const :tag "C choose: Use TODO keywords to mark decisions states" org-choose)
(const :tag "C collector: Collect properties into tables" org-collector)
(const :tag "C depend: TODO dependencies for Org mode\n\t\t\t(PARTIALLY OBSOLETE, see built-in dependency support))" org-depend)
(const :tag "C elisp-symbol: Links to emacs-lisp symbols" ol-elisp-symbol)
(const :tag "C eval-light: Evaluate inbuffer-code on demand" org-eval-light)
(const :tag "C eval: Include command output as text" org-eval)
(const :tag "C expiry: Expiry mechanism for Org entries" org-expiry)
(const :tag "C git-link: Links to specific file version" ol-git-link)
(const :tag "C interactive-query: Interactive modification of tags query\n\t\t\t(PARTIALLY OBSOLETE, see secondary filtering)" org-interactive-query)
(const :tag "C invoice: Help manage client invoices in Org mode" org-invoice)
(const :tag "C learn: SuperMemo's incremental learning algorithm" org-learn)
(const :tag "C mac-iCal: Imports events from iCal.app to the Emacs diary" org-mac-iCal)
(const :tag "C mac-link: Grab links and url from various mac Applications" org-mac-link)
(const :tag "C mairix: Hook mairix search into Org for different MUAs" org-mairix)
(const :tag "C man: Links to man pages in Org mode" ol-man)
(const :tag "C mew: Links to Mew folders/messages" ol-mew)
(const :tag "C notify: Notifications for Org mode" org-notify)
(const :tag "C notmuch: Provide Org links to notmuch searches or messages" ol-notmuch)
(const :tag "C panel: Simple routines for us with bad memory" org-panel)
(const :tag "C registry: A registry for Org links" org-registry)
(const :tag "C screen: Visit screen sessions through links" org-screen)
(const :tag "C screenshot: Take and manage screenshots in Org files" org-screenshot)
(const :tag "C secretary: Team management with Org" org-secretary)
(const :tag "C sqlinsert: Convert Org tables to SQL insertions" orgtbl-sqlinsert)
(const :tag "C toc: Table of contents for Org buffer" org-toc)
(const :tag "C track: Keep up with Org mode development" org-track)
(const :tag "C velocity Something like Notational Velocity for Org" org-velocity)
(const :tag "C vm: Links to VM folders/messages" ol-vm)
(const :tag "C wikinodes: CamelCase wiki-like links" org-wikinodes)
(const :tag "C wl: Links to Wanderlust folders/messages" ol-wl)
(repeat :tag "External packages" :inline t (symbol :tag "Package"))))
(defvar org-export-registered-backends) ; From ox.el.
(declare-function org-export-derived-backend-p "ox" (backend &rest backends))
(declare-function org-export-backend-name "ox" (backend) t)
(defcustom org-export-backends '(ascii html icalendar latex odt)
"List of export backends that should be always available.
If a description starts with <C>, the file is not part of Emacs and Org mode,
so loading it will require that you have properly installed org-contrib
package from NonGNU Emacs Lisp Package Archive
https://elpa.nongnu.org/nongnu/org-contrib.html
Unlike to `org-modules', libraries in this list will not be
loaded along with Org, but only once the export framework is
needed.
This variable needs to be set before org.el is loaded. If you
need to make a change while Emacs is running, use the customize
interface or run the following code, where VAL stands for the new
value of the variable, after updating it:
(progn
(setq org-export-registered-backends
(cl-remove-if-not
(lambda (backend)
(let ((name (org-export-backend-name backend)))
(or (memq name val)
(catch \\='parentp
(dolist (b val)
(and (org-export-derived-backend-p b name)
(throw \\='parentp t)))))))
org-export-registered-backends))
(let ((new-list (mapcar #\\='org-export-backend-name
org-export-registered-backends)))
(dolist (backend val)
(cond
((not (load (format \"ox-%s\" backend) t t))
(message \"Problems while trying to load export backend \\=`%s\\='\"
backend))
((not (memq backend new-list)) (push backend new-list))))
(set-default \\='org-export-backends new-list)))
Adding a backend to this list will also pull the backend it
depends on, if any."
:group 'org
:group 'org-export
:version "26.1"
:package-version '(Org . "9.0")
:initialize 'custom-initialize-set
:set (lambda (var val)
(if (not (featurep 'ox)) (set-default-toplevel-value var val)
;; Any backend not required anymore (not present in VAL and not
;; a parent of any backend in the new value) is removed from the
;; list of registered backends.
(setq org-export-registered-backends
(cl-remove-if-not
(lambda (backend)
(let ((name (org-export-backend-name backend)))
(or (memq name val)
(catch 'parentp
(dolist (b val)
(and (org-export-derived-backend-p b name)
(throw 'parentp t)))))))
org-export-registered-backends))
;; Now build NEW-LIST of both new backends and required
;; parents.
(let ((new-list (mapcar #'org-export-backend-name
org-export-registered-backends)))
(dolist (backend val)
(cond
((not (load (format "ox-%s" backend) t t))
(message "Problems while trying to load export backend `%s'"
backend))
((not (memq backend new-list)) (push backend new-list))))
;; Set VAR to that list with fixed dependencies.
(set-default-toplevel-value var new-list))))
:type '(set :greedy t
(const :tag " ascii Export buffer to ASCII format" ascii)
(const :tag " beamer Export buffer to Beamer presentation" beamer)
(const :tag " html Export buffer to HTML format" html)
(const :tag " icalendar Export buffer to iCalendar format" icalendar)
(const :tag " latex Export buffer to LaTeX format" latex)
(const :tag " man Export buffer to MAN format" man)
(const :tag " md Export buffer to Markdown format" md)
(const :tag " odt Export buffer to ODT format" odt)
(const :tag " org Export buffer to Org format" org)
(const :tag " texinfo Export buffer to Texinfo format" texinfo)
(const :tag "C confluence Export buffer to Confluence Wiki format" confluence)
(const :tag "C deck Export buffer to deck.js presentations" deck)
(const :tag "C freemind Export buffer to Freemind mindmap format" freemind)
(const :tag "C groff Export buffer to Groff format" groff)
(const :tag "C koma-letter Export buffer to KOMA Scrlttrl2 format" koma-letter)
(const :tag "C RSS 2.0 Export buffer to RSS 2.0 format" rss)
(const :tag "C s5 Export buffer to s5 presentations" s5)
(const :tag "C taskjuggler Export buffer to TaskJuggler format" taskjuggler)))
(eval-after-load 'ox
'(dolist (backend org-export-backends)
(condition-case-unless-debug nil (require (intern (format "ox-%s" backend)))
(error (message "Problems while trying to load export backend `%s'"
backend)))))
(defcustom org-support-shift-select nil
"Non-nil means make shift-cursor commands select text when possible.
\\<org-mode-map>
In Emacs 23, when `shift-select-mode' is on, shifted cursor keys
start selecting a region, or enlarge regions started in this way.
In Org mode, in special contexts, these same keys are used for
other purposes, important enough to compete with shift selection.
Org tries to balance these needs by supporting `shift-select-mode'
outside these special contexts, under control of this variable.
The default of this variable is nil, to avoid confusing behavior. Shifted
cursor keys will then execute Org commands in the following contexts:
- on a headline, changing TODO state (left/right) and priority (up/down)
- on a time stamp, changing the time
- in a plain list item, changing the bullet type
- in a property definition line, switching between allowed values
- in the BEGIN line of a clock table (changing the time block).
- in a table, moving the cell in the specified direction.
Outside these contexts, the commands will throw an error.
When this variable is t and the cursor is not in a special
context, Org mode will support shift-selection for making and
enlarging regions. To make this more effective, the bullet
cycling will no longer happen anywhere in an item line, but only
if the cursor is exactly on the bullet.
If you set this variable to the symbol `always', then the keys
will not be special in headlines, property lines, item lines, and
table cells, to make shift selection work there as well. If this is
what you want, you can use the following alternative commands:
`\\[org-todo]' and `\\[org-priority]' \
to change TODO state and priority,
`\\[universal-argument] \\[universal-argument] \\[org-todo]' \
can be used to switch TODO sets,
`\\[org-ctrl-c-minus]' to cycle item bullet types,
and properties can be edited by hand or in column view.
However, when the cursor is on a timestamp, shift-cursor commands
will still edit the time stamp - this is just too good to give up."
:group 'org
:type '(choice
(const :tag "Never" nil)
(const :tag "When outside special context" t)
(const :tag "Everywhere except timestamps" always)))
(defcustom org-loop-over-headlines-in-active-region t
"Shall some commands act upon headlines in the active region?
When set to t, some commands will be performed in all headlines
within the active region.
When set to `start-level', some commands will be performed in all
headlines within the active region, provided that these headlines
are of the same level than the first one.
When set to a string, those commands will be performed on the
matching headlines within the active region. Such string must be
a tags/property/todo match as it is used in the agenda tags view.
The list of commands is: `org-schedule', `org-deadline',
`org-todo', `org-set-tags-command', `org-archive-subtree',
`org-archive-set-tag', `org-toggle-archive-tag' and
`org-archive-to-archive-sibling'. The archiving commands skip
already archived entries.
See `org-agenda-loop-over-headlines-in-active-region' for the
equivalent option for agenda views."
:type '(choice (const :tag "Don't loop" nil)
(const :tag "All headlines in active region" t)
(const :tag "In active region, headlines at the same level than the first one" start-level)
(string :tag "Tags/Property/Todo matcher"))
:package-version '(Org . "9.4")
:group 'org-todo
:group 'org-archive)
(defgroup org-startup nil
"Startup options Org uses when first visiting a file."
:tag "Org Startup"
:group 'org)
(defcustom org-startup-folded 'showeverything
"Initial folding state of headings when entering Org mode.
Allowed values are:
symbol `nofold'
Do not fold headings.
symbol `fold'
Fold everything, leaving only top-level headings visible.
symbol `content'
Leave all the headings and sub-headings visible, but hide their
text. This is an equivalent of table of contents.
symbol `show2levels', `show3levels', `show4levels', `show5levels'
Show headings up to Nth level.
symbol `showeverything' (default)
Start Org mode in fully unfolded state. Unlike all other allowed
values, this value prevents drawers, blocks, and archived subtrees
from being folded even when `org-cycle-hide-block-startup',
`org-cycle-open-archived-trees', or `org-cycle-hide-drawer-startup'
are non-nil. Per-subtree visibility settings (see manual node
`(org)Initial visibility)') are also ignored.
This can also be configured on a per-file basis by adding one of
the following lines anywhere in the buffer:
#+STARTUP: fold (or `overview', this is equivalent)
#+STARTUP: nofold (or `showall', this is equivalent)
#+STARTUP: content
#+STARTUP: show<n>levels (<n> = 2..5)
#+STARTUP: showeverything
Set `org-agenda-inhibit-startup' to a non-nil value if you want
to ignore this option when Org opens agenda files for the first
time."
:group 'org-startup
:package-version '(Org . "9.4")
:type '(choice
(const :tag "nofold: show all" nofold)
(const :tag "fold: overview" fold)
(const :tag "fold: show two levels" show2levels)
(const :tag "fold: show three levels" show3levels)
(const :tag "fold: show four levels" show4evels)
(const :tag "fold: show five levels" show5levels)
(const :tag "content: all headlines" content)
(const :tag "show everything, even drawers" showeverything)))
(defcustom org-startup-truncated t
"Non-nil means entering Org mode will set `truncate-lines'.
This is useful since some lines containing links can be very long and
uninteresting. Also tables look terrible when wrapped.
The variable `org-startup-truncated' enables you to configure
truncation for Org mode different to the other modes that use the
variable `truncate-lines' and as a shortcut instead of putting
the variable `truncate-lines' into the `org-mode-hook'. If one
wants to configure truncation for Org mode not statically but
dynamically e.g. in a hook like `ediff-prepare-buffer-hook' then
the variable `truncate-lines' has to be used because in such a
case it is too late to set the variable `org-startup-truncated'."
:group 'org-startup
:type 'boolean)
(defcustom org-startup-indented nil
"Non-nil means turn on `org-indent-mode' on startup.
This can also be configured on a per-file basis by adding one of
the following lines anywhere in the buffer:
#+STARTUP: indent
#+STARTUP: noindent"
:group 'org-structure
:type '(choice
(const :tag "Not" nil)
(const :tag "Globally (slow on startup in large files)" t)))
(defcustom org-startup-numerated nil
"Non-nil means turn on `org-num-mode' on startup.
This can also be configured on a per-file basis by adding one of
the following lines anywhere in the buffer:
#+STARTUP: num
#+STARTUP: nonum"
:group 'org-structure
:package-version '(Org . "9.4")
:type '(choice
(const :tag "Not" nil)
(const :tag "Globally" t)))
(defcustom org-use-sub-superscripts t
"Non-nil means interpret \"_\" and \"^\" for display.
If you want to control how Org exports those characters, see
`org-export-with-sub-superscripts'.
When this option is turned on, you can use TeX-like syntax for
sub- and superscripts within the buffer. Several characters after
\"_\" or \"^\" will be considered as a single item - so grouping
with {} is normally not needed. For example, the following things
will be parsed as single sub- or superscripts:
10^24 or 10^tau several digits will be considered 1 item.
10^-12 or 10^-tau a leading sign with digits or a word
x^2-y^3 will be read as x^2 - y^3, because items are
terminated by almost any nonword/nondigit char.
x^(2 - i) expression inside round braces, including the
braces is read as a sub/superscript.
x_{i^2} curly braces do grouping; braces are not
considered a part of the sub/superscript.
Still, ambiguity is possible. So when in doubt, use {} to enclose
the sub/superscript. If you set this variable to the symbol `{}',
the curly braces are *required* in order to trigger interpretations as
sub/superscript. This can be helpful in documents that need \"_\"
frequently in plain text.
Setting this variable does not change Org mode markup. Org mode will
still parse the matching text as sub/superscript internally. It is
only the visual appearance that will be changed."
:group 'org-startup
:version "24.4"
:package-version '(Org . "8.0")
:type '(choice
(const :tag "Always interpret" t)
(const :tag "Only with curly braces" {})
(const :tag "Never interpret" nil)))
(defcustom org-startup-with-beamer-mode nil
"Non-nil means turn on `org-beamer-mode' on startup.
This can also be configured on a per-file basis by adding one of
the following lines anywhere in the buffer:
#+STARTUP: beamer"
:group 'org-startup
:version "24.1"
:type 'boolean)
(defcustom org-startup-align-all-tables nil
"Non-nil means align all tables when visiting a file.
This can also be configured on a per-file basis by adding one of
the following lines anywhere in the buffer:
#+STARTUP: align
#+STARTUP: noalign"
:group 'org-startup
:type 'boolean)
(defcustom org-startup-shrink-all-tables nil
"Non-nil means shrink all table columns with a width cookie.
This can also be configured on a per-file basis by adding one of
the following lines anywhere in the buffer:
#+STARTUP: shrink"
:group 'org-startup
:type 'boolean
:version "27.1"
:package-version '(Org . "9.2")
:safe #'booleanp)
(defcustom org-startup-with-inline-images nil
"Non-nil means show inline images when loading a new Org file.
This can also be configured on a per-file basis by adding one of
the following lines anywhere in the buffer:
#+STARTUP: inlineimages
#+STARTUP: noinlineimages"
:group 'org-startup
:version "24.1"
:type 'boolean)
(defcustom org-startup-with-latex-preview nil
"Non-nil means preview LaTeX fragments when loading a new Org file.
This can also be configured on a per-file basis by adding one of
the following lines anywhere in the buffer:
#+STARTUP: latexpreview
#+STARTUP: nolatexpreview"
:group 'org-startup
:version "24.4"
:package-version '(Org . "8.0")
:type 'boolean)
(unless (boundp 'untrusted-content)
(defvar untrusted-content nil))
(defvar untrusted-content) ; defined in files.el since Emacs 29.3
(defvar org--latex-preview-when-risky nil
"If non-nil, enable LaTeX preview in Org buffers from unsafe source.
Some specially designed LaTeX code may generate huge pdf or log files
that may exhaust disk space.
This variable controls how to handle LaTeX preview when rendering LaTeX
fragments that originate from incoming email messages. It has no effect
when Org mode is unable to determine the origin of the Org buffer.
An Org buffer is considered to be from unsafe source when the
variable `untrusted-content' has a non-nil value in the buffer.
If this variable is non-nil, LaTeX previews are rendered unconditionally.
This variable may be renamed or changed in the future.")
(defcustom org-insert-mode-line-in-empty-file nil
"Non-nil means insert the first line setting Org mode in empty files.
When the function `org-mode' is called interactively in an empty file, this
normally means that the file name does not automatically trigger Org mode.
To ensure that the file will always be in Org mode in the future, a
line enforcing Org mode will be inserted into the buffer, if this option
has been set."
:group 'org-startup
:type 'boolean)
(defcustom org-ellipsis nil
"The ellipsis to use in the Org mode outline.
When nil, just use the standard three dots. When a non-empty string,
use that string instead.
The change affects only Org mode (which will then use its own display table).
Changing this requires executing `\\[org-mode]' in a buffer to become
effective. It cannot be set as a local variable."
:group 'org-startup
:type '(choice (const :tag "Default" nil)
(string :tag "String" :value "...#")))
(defvar org-display-table nil
"The display table for Org mode, in case `org-ellipsis' is non-nil.")
(defcustom org-directory "~/org"
"Directory with Org files.
This is just a default location to look for Org files. There is no need
at all to put your files into this directory. It is used in the
following situations:
1. When a capture template specifies a target file that is not an
absolute path. The path will then be interpreted relative to
`org-directory'
2. When the value of variable `org-agenda-files' is a single file, any
relative paths in this file will be taken as relative to
`org-directory'."
:group 'org-refile
:group 'org-capture
:type 'directory)
(defcustom org-default-notes-file (convert-standard-filename "~/.notes")
"Default target for storing notes.
Used as a fall back file for org-capture.el, for templates that
do not specify a target file."
:group 'org-refile
:group 'org-capture
:type 'file)
(defcustom org-reverse-note-order nil
"Non-nil means store new notes at the beginning of a file or entry.
When nil, new notes will be filed to the end of a file or entry.
This can also be a list with cons cells of regular expressions that
are matched against file names, and values."
:group 'org-capture
:group 'org-refile
:type '(choice
(const :tag "Reverse always" t)
(const :tag "Reverse never" nil)
(repeat :tag "By file name regexp"
(cons regexp boolean))))
(defgroup org-keywords nil
"Keywords in Org mode."
:tag "Org Keywords"
:group 'org)
(defcustom org-closed-keep-when-no-todo nil
"Remove CLOSED: timestamp when switching back to a non-todo state?"
:group 'org-todo
:group 'org-keywords
:version "24.4"
:package-version '(Org . "8.0")
:type 'boolean)
(defgroup org-structure nil
"Options concerning the general structure of Org files."
:tag "Org Structure"
:group 'org)
(defcustom org-indirect-buffer-display 'other-window
"How should indirect tree buffers be displayed?
This applies to indirect buffers created with the commands
`org-tree-to-indirect-buffer' and `org-agenda-tree-to-indirect-buffer'.
Valid values are:
current-window Display in the current window
other-window Just display in another window.
dedicated-frame Create one new frame, and reuse it each time.
new-frame Make a new frame each time. Note that in this case
previously-made indirect buffers are kept, and you need to
kill these buffers yourself."
:group 'org-structure
:group 'org-agenda-windows
:type '(choice
(const :tag "In current window" current-window)
(const :tag "In current frame, other window" other-window)
(const :tag "Each time a new frame" new-frame)
(const :tag "One dedicated frame" dedicated-frame)))
(defconst org-file-apps-gnu
'((remote . emacs)
(system . mailcap)
(t . mailcap))
"Default file applications on a UNIX or GNU/Linux system.
See `org-file-apps'.")
(defconst org-file-apps-macos
'((remote . emacs)
(system . "open %s")
("ps.gz" . "gv %s")
("eps.gz" . "gv %s")
("dvi" . "xdvi %s")
("fig" . "xfig %s")
(t . "open %s"))
"Default file applications on a macOS system.
The system \"open\" is known as a default, but we use X11 applications
for some files for which the OS does not have a good default.
See `org-file-apps'.")
(defconst org-file-apps-windowsnt
(list '(remote . emacs)
(cons 'system (lambda (file _path)
(with-no-warnings (w32-shell-execute "open" file))))
(cons t (lambda (file _path)
(with-no-warnings (w32-shell-execute "open" file)))))
"Default file applications on a Windows NT system.
The system \"open\" is used for most files.
See `org-file-apps'.")
(defcustom org-file-apps
'((auto-mode . emacs)
(directory . emacs)
("\\.mm\\'" . default)
("\\.x?html?\\'" . default)
("\\.pdf\\'" . default))
"Applications for opening `file:path' items in a document.
\\<org-mode-map>
Org mode uses system defaults for different file types, but you
can use this variable to set the application for a given file
extension. The entries in this list are cons cells where the car
identifies files and the cdr the corresponding command.
Possible values for the file identifier are:
\"string\" A string as a file identifier can be interpreted in different
ways, depending on its contents:
- Alphanumeric characters only:
Match links with this file extension.
Example: (\"pdf\" . \"evince %s\")
to open PDFs with evince.
- Regular expression: Match links where the
filename matches the regexp. If you want to
use groups here, use shy groups.
Example: (\"\\\\.x?html\\\\\\='\" . \"firefox %s\")
(\"\\\\(?:xhtml\\\\|html\\\\)\\\\\\='\" . \"firefox %s\")
to open *.html and *.xhtml with firefox.
- Regular expression which contains (non-shy) groups:
Match links where the whole link, including \"::\", and
anything after that, matches the regexp.
In a custom command string, %1, %2, etc. are replaced with
the parts of the link that were matched by the groups.
For backwards compatibility, if a command string is given
that does not use any of the group matches, this case is
handled identically to the second one (i.e. match against
file name only).
In a custom function, you can access the group matches with
(match-string n link).
Example: (\"\\\\.pdf::\\\\([0-9]+\\\\)\\\\\\='\" . \
\"evince -p %1 %s\")
to open [[file:document.pdf::5]] with evince at page 5.
Likely, you will need more entries: without page
number; with search pattern; with
cross-reference anchor; some combination of
options. Consider simple pattern here and a
Lisp function to determine command line
arguments instead. Passing an argument list to
`call-process' or `make-process' directly avoids
treating some character in peculiar file names
as shell specials that prompt parts of said file
names to be executed as subcommands.
`directory' Matches a directory
`remote' Matches a remote file, accessible through tramp.
Remote files most likely should be visited through Emacs
because external applications cannot handle such paths.
`auto-mode' Matches files that are matched by any entry in `auto-mode-alist',
so all files Emacs knows how to handle. Using this with
command `emacs' will open most files in Emacs. Beware that this
will also open html files inside Emacs, unless you add
(\"html\" . default) to the list as well.
`system' The system command to open files, like `open' on Windows
and macOS, and mailcap under GNU/Linux. This is the command
that will be selected if you call `org-open-at-point' with a
double prefix argument (`\\[universal-argument] \
\\[universal-argument] \\[org-open-at-point]').
t Default for files not matched by any of the other options.
Possible values for the command are:
`emacs' The file will be visited by the current Emacs process.
`default' Use the default application for this file type, which is the
association for t in the list, most likely in the system-specific
part. This can be used to overrule an unwanted setting in the
system-specific variable.
`system' Use the system command for opening files, like \"open\".
This command is specified by the entry whose car is `system'.
Most likely, the system-specific version of this variable
does define this command, but you can overrule/replace it
here.
`mailcap' Use command specified in the mailcaps.
string A command to be executed by a shell; %s will be replaced
by the path to the file.
function A Lisp function, which will be called with two arguments:
the file path and the original link string, without the
\"file:\" prefix.
For more examples, see the system specific constants
`org-file-apps-macos'
`org-file-apps-windowsnt'
`org-file-apps-gnu'."
:group 'org
:package-version '(Org . "9.4")
:type '(repeat
(cons (choice :value ""
(string :tag "Extension")
(const :tag "System command to open files" system)
(const :tag "Default for unrecognized files" t)
(const :tag "Remote file" remote)
(const :tag "Links to a directory" directory)
(const :tag "Any files that have Emacs modes"
auto-mode))
(choice :value ""
(const :tag "Visit with Emacs" emacs)
(const :tag "Use default" default)
(const :tag "Use the system command" system)
(string :tag "Command")
(function :tag "Function")))))
(defcustom org-resource-download-policy 'prompt
"The policy applied to requests to obtain remote resources.
This affects keywords like #+setupfile and #+include on export,
`org-persist-write:url',and `org-attach-url' in non-interactive
Emacs sessions.
This recognizes four possible values:
- t (dangerous), remote resources should always be downloaded.
- prompt, you will be prompted to download resources not considered safe.
- safe, only resources considered safe will be downloaded.
- nil, never download remote resources.
A resource is considered safe if it matches one of the patterns
in `org-safe-remote-resources'."
:group 'org
:package-version '(Org . "9.6")
:type '(choice (const :tag "Always download remote resources (dangerous)" t)
(const :tag "Prompt before downloading an unsafe resource" prompt)
(const :tag "Only download resources considered safe" safe)
(const :tag "Never download any resources" nil)))
(defcustom org-safe-remote-resources nil
"A list of regexp patterns matching safe URIs.
URI regexps are applied to both URLs and Org files requesting
remote resources."
:group 'org
:package-version '(Org . "9.6")
:type '(repeat regexp))
(defcustom org-open-non-existing-files nil
"Non-nil means `org-open-file' opens non-existing files.
When nil, an error is thrown.
This variable applies only to external applications because they
might choke on non-existing files. If the link is to a file that
will be opened in Emacs, the variable is ignored."
:group 'org
:type 'boolean
:safe #'booleanp)
(defcustom org-open-directory-means-index-dot-org nil
"When non-nil a link to a directory really means to \"index.org\".
When nil, following a directory link runs Dired or opens
a finder/explorer window on that directory."
:group 'org
:type 'boolean
:safe #'booleanp)
(defcustom org-bookmark-names-plist
'(:last-capture "org-capture-last-stored"
:last-refile "org-refile-last-stored"
:last-capture-marker "org-capture-last-stored-marker")
"Names for bookmarks automatically set by some Org commands.
This can provide strings as names for a number of bookmarks Org sets
automatically. The following keys are currently implemented:
:last-capture
:last-capture-marker
:last-refile
When a key does not show up in the property list, the corresponding bookmark
is not set."
:group 'org-structure
:type 'plist)
(defgroup org-edit-structure nil
"Options concerning structure editing in Org mode."
:tag "Org Edit Structure"
:group 'org-structure)
(defcustom org-odd-levels-only nil
"Non-nil means skip even levels and only use odd levels for the outline.
This has the effect that two stars are being added/taken away in
promotion/demotion commands. It also influences how levels are
handled by the exporters.
Changing it requires restart of `font-lock-mode' to become effective
for fontification also in regions already fontified.
You may also set this on a per-file basis by adding one of the following
lines to the buffer:
#+STARTUP: odd
#+STARTUP: oddeven"
:group 'org-edit-structure
:group 'org-appearance
:type 'boolean)
(defcustom org-adapt-indentation nil
"Non-nil means adapt indentation to outline node level.
When set to t, Org assumes that you write outlines by indenting
text in each node to align with the headline, after the stars.
When this variable is set to `headline-data', Org only adapts the
indentation of the data lines right below the headline, such as
planning/clock lines and property/logbook drawers.
The following issues are influenced by this variable:
- The indentation is increased by one space in a demotion
command, and decreased by one in a promotion command. However,
in the latter case, if shifting some line in the entry body
would alter document structure (e.g., insert a new headline),
indentation is not changed at all.
- Property drawers and planning information is inserted indented
when this variable is set. When nil, they will not be indented.
- TAB indents a line relative to current level. The lines below
a headline will be indented when this variable is set to t.
Note that this is all about true indentation, by adding and
removing space characters. See also \"org-indent.el\" which does
level-dependent indentation in a virtual way, i.e. at display
time in Emacs."
:group 'org-edit-structure
:type '(choice
(const :tag "Adapt indentation for all lines" t)
(const :tag "Adapt indentation for headline data lines"
headline-data)
(const :tag "Do not adapt indentation at all" nil))
:safe (lambda (x) (memq x '(t nil headline-data))))
(defvaralias 'org-special-ctrl-a 'org-special-ctrl-a/e)
(defcustom org-special-ctrl-a/e nil
"Non-nil means `C-a' and `C-e' behave specially in headlines and items.
When t, `C-a' will bring back the cursor to the beginning of the
headline text, i.e. after the stars and after a possible TODO
keyword. In an item, this will be the position after bullet and
check-box, if any. When the cursor is already at that position,
another `C-a' will bring it to the beginning of the line.
`C-e' will jump to the end of the headline, ignoring the presence
of tags in the headline. A second `C-e' will then jump to the
true end of the line, after any tags. This also means that, when
this variable is non-nil, `C-e' also will never jump beyond the
end of the heading of a folded section, i.e. not after the
ellipses.
When set to the symbol `reversed', the first `C-a' or `C-e' works
normally, going to the true line boundary first. Only a directly
following, identical keypress will bring the cursor to the
special positions.
This may also be a cons cell where the behavior for `C-a' and
`C-e' is set separately."
:group 'org-edit-structure
:type '(choice
(const :tag "off" nil)
(const :tag "on: after stars/bullet and before tags first" t)
(const :tag "reversed: true line boundary first" reversed)
(cons :tag "Set C-a and C-e separately"
(choice :tag "Special C-a"
(const :tag "off" nil)
(const :tag "on: after stars/bullet first" t)
(const :tag "reversed: before stars/bullet first" reversed))
(choice :tag "Special C-e"
(const :tag "off" nil)
(const :tag "on: before tags first" t)
(const :tag "reversed: after tags first" reversed)))))
(defcustom org-special-ctrl-k nil
"Non-nil means that \\<org-mode-map>\\[org-kill-line] \
will behave specially in headlines.
When nil, \\[org-kill-line] will call the default `kill-line' command.
Otherwise, the following will happen when point is in a headline:
- At the beginning of a headline, kill the entire line.
- In the middle of the headline text, kill the text up to the tags.
- After the headline text and before the tags, kill all the tags."
:group 'org-edit-structure
:type 'boolean)
(defcustom org-ctrl-k-protect-subtree nil
"Non-nil means, do not delete a hidden subtree with `C-k'.
When set to the symbol `error', simply throw an error when `C-k' is
used to kill (part-of) a headline that has hidden text behind it.
Any other non-nil value will result in a query to the user, if it is
OK to kill that hidden subtree. When nil, kill without remorse."
:group 'org-edit-structure
:version "24.1"
:type '(choice
(const :tag "Do not protect hidden subtrees" nil)
(const :tag "Protect hidden subtrees with a security query" t)
(const :tag "Never kill a hidden subtree with C-k" error)))
(defcustom org-special-ctrl-o t
"Non-nil means, make `open-line' (\\[open-line]) insert a row in tables."
:group 'org-edit-structure
:type 'boolean)
(defcustom org-yank-folded-subtrees t
"Non-nil means when yanking subtrees, fold them.
If the kill is a single subtree, or a sequence of subtrees, i.e. if
it starts with a heading and all other headings in it are either children
or siblings, then fold all the subtrees. However, do this only if no
text after the yank would be swallowed into a folded tree by this action."
:group 'org-edit-structure
:type 'boolean)
(defcustom org-yank-adjusted-subtrees nil
"Non-nil means when yanking subtrees, adjust the level.
With this setting, `org-paste-subtree' is used to insert the subtree, see
this function for details."
:group 'org-edit-structure
:type 'boolean)
(defcustom org-M-RET-may-split-line '((default . t))
"Non-nil means M-RET will split the line at the cursor position.
When nil, it will go to the end of the line before making a
new line.
You may also set this option in a different way for different
contexts. Valid contexts are:
headline when creating a new headline
item when creating a new item
table in a table field
default the value to be used for all contexts not explicitly
customized"
:group 'org-structure
:group 'org-table
:type '(choice
(const :tag "Always" t)
(const :tag "Never" nil)
(repeat :greedy t :tag "Individual contexts"
(cons
(choice :tag "Context"
(const headline)
(const item)
(const table)
(const default))
(boolean)))))
(defcustom org-insert-heading-respect-content nil
"Non-nil means insert new headings after the current subtree.
\\<org-mode-map>
When nil, the new heading is created directly after the current line.
The commands `\\[org-insert-heading-respect-content]' and \
`\\[org-insert-todo-heading-respect-content]' turn this variable on
for the duration of the command."
:group 'org-structure
:type 'boolean)
(defcustom org-blank-before-new-entry '((heading . auto)
(plain-list-item . auto))
"Should `org-insert-heading' leave a blank line before new heading/item?
The value is an alist, with `heading' and `plain-list-item' as CAR,
and a boolean flag as CDR. The cdr may also be the symbol `auto', in
which case Org will look at the surrounding headings/items and try to
make an intelligent decision whether to insert a blank line or not."
:group 'org-edit-structure
:type '(list
(cons (const heading)
(choice (const :tag "Never" nil)
(const :tag "Always" t)
(const :tag "Auto" auto)))
(cons (const plain-list-item)
(choice (const :tag "Never" nil)
(const :tag "Always" t)
(const :tag "Auto" auto)))))
(defcustom org-insert-heading-hook nil
"Hook being run after inserting a new heading."
:group 'org-edit-structure
:type 'hook)
(defgroup org-sparse-trees nil
"Options concerning sparse trees in Org mode."
:tag "Org Sparse Trees"
:group 'org-structure)
(defcustom org-highlight-sparse-tree-matches t
"Non-nil means highlight all matches that define a sparse tree.
The highlights will automatically disappear the next time the buffer is
changed by an edit command."
:group 'org-sparse-trees
:type 'boolean)
(defcustom org-remove-highlights-with-change t
"Non-nil means any change to the buffer will remove temporary highlights.
\\<org-mode-map>\
Such highlights are created by `org-occur' and `org-clock-display'.
When nil, `\\[org-ctrl-c-ctrl-c]' needs to be used \
to get rid of the highlights.
The highlights created by `org-latex-preview' always need
`\\[org-latex-preview]' to be removed."
:group 'org-sparse-trees
:group 'org-time
:type 'boolean)
(defcustom org-occur-case-fold-search t
"Non-nil means `org-occur' should be case-insensitive.
If set to `smart' the search will be case-insensitive only if it
doesn't specify any upper case character."
:group 'org-sparse-trees
:version "26.1"
:type '(choice
(const :tag "Case-sensitive" nil)
(const :tag "Case-insensitive" t)
(const :tag "Case-insensitive for lower case searches only" smart)))
(defcustom org-occur-hook '(org-first-headline-recenter)
"Hook that is run after `org-occur' has constructed a sparse tree.
This can be used to recenter the window to show as much of the structure
as possible."
:group 'org-sparse-trees
:type 'hook)
(defcustom org-self-insert-cluster-for-undo nil
"Non-nil means cluster self-insert commands for undo when possible.
If this is set, then, like in the Emacs command loop, 20 consecutive
characters will be undone together.
This is configurable, because there is some impact on typing performance."
:group 'org-table
:type 'boolean)
(defvaralias 'org-activate-links 'org-highlight-links)
(defcustom org-highlight-links '(bracket angle plain radio tag date footnote)
"Types of links that should be highlighted in Org files.
This is a list of symbols, each one of them leading to the
highlighting of a certain link type.
You can still open links that are not highlighted.
In principle, it does not hurt to turn on highlighting for all
link types. There may be a small gain when turning off unused
link types. The types are:
bracket The recommended [[link][description]] or [[link]] links with hiding.
angle Links in angular brackets that may contain whitespace like
<bbdb:Carsten Dominik>.
plain Plain links in normal text, no whitespace, like https://gnu.org.
radio Text that is matched by a radio target, see manual for details.
tag Tag settings in a headline (link to tag search).
date Time stamps (link to calendar).
footnote Footnote labels.
If you set this variable during an Emacs session, use `org-mode-restart'
in the Org buffer so that the change takes effect."
:group 'org-appearance
:type '(set :greedy t
(const :tag "Double bracket links" bracket)
(const :tag "Angular bracket links" angle)
(const :tag "Plain text links" plain)
(const :tag "Radio target matches" radio)
(const :tag "Tags" tag)
(const :tag "Timestamps" date)
(const :tag "Footnotes" footnote)))
(defcustom org-mark-ring-length 4
"Number of different positions to be recorded in the ring.
Changing this requires a restart of Emacs to work correctly."
:group 'org-link-follow
:type 'integer)
(defgroup org-todo nil
"Options concerning TODO items in Org mode."
:tag "Org TODO"
:group 'org)
(defgroup org-progress nil
"Options concerning Progress logging in Org mode."
:tag "Org Progress"
:group 'org-time)
(defvar org-todo-interpretation-widgets
'((:tag "Sequence (cycling hits every state)" sequence)
(:tag "Type (cycling directly to DONE)" type))
"The available interpretation symbols for customizing `org-todo-keywords'.
Interested libraries should add to this list.")
(defcustom org-todo-keywords '((sequence "TODO" "DONE"))
"List of TODO entry keyword sequences and their interpretation.
\\<org-mode-map>This is a list of sequences.
Each sequence starts with a symbol, either `sequence' or `type',
indicating if the keywords should be interpreted as a sequence of
action steps, or as different types of TODO items. The first
keywords are states requiring action - these states will select a headline
for inclusion into the global TODO list Org produces. If one of the
\"keywords\" is the vertical bar, \"|\", the remaining keywords
signify that no further action is necessary. If \"|\" is not found,
the last keyword is treated as the only DONE state of the sequence.
The command `\\[org-todo]' cycles an entry through these states, and one
additional state where no keyword is present. For details about this
cycling, see the manual.
TODO keywords and interpretation can also be set on a per-file basis with
the special #+SEQ_TODO and #+TYP_TODO lines.
Each keyword can optionally specify a character for fast state selection
\(in combination with the variable `org-use-fast-todo-selection')
and specifiers for state change logging, using the same syntax that
is used in the \"#+TODO:\" lines. For example, \"WAIT(w)\" says that
the WAIT state can be selected with the \"w\" key. \"WAIT(w!)\"
indicates to record a time stamp each time this state is selected.
Each keyword may also specify if a timestamp or a note should be
recorded when entering or leaving the state, by adding additional
characters in the parenthesis after the keyword. This looks like this:
\"WAIT(w@/!)\". \"@\" means to add a note (with time), \"!\" means to
record only the time of the state change. With X and Y being either
\"@\" or \"!\", \"X/Y\" means use X when entering the state, and use
Y when leaving the state if and only if the *target* state does not
define X. You may omit any of the fast-selection key or X or /Y,
so WAIT(w@), WAIT(w/@) and WAIT(@/@) are all valid.
For backward compatibility, this variable may also be just a list
of keywords. In this case the interpretation (sequence or type) will be
taken from the (otherwise obsolete) variable `org-todo-interpretation'."
:group 'org-todo
:group 'org-keywords
:type '(choice
(repeat :tag "Old syntax, just keywords"
(string :tag "Keyword"))
(repeat :tag "New syntax"
(cons
(choice
:tag "Interpretation"
;;Quick and dirty way to see
;;`org-todo-interpretation'. This takes the
;;place of item arguments
:convert-widget
(lambda (widget)
(widget-put widget
:args (mapcar
(lambda (x)
(widget-convert
(cons 'const x)))
org-todo-interpretation-widgets))
widget))
(repeat
(string :tag "Keyword"))))))
(defvar-local org-todo-keywords-1 nil
"All TODO and DONE keywords active in a buffer.")
(defvar org-todo-keywords-for-agenda nil)
(defvar org-done-keywords-for-agenda nil)
(defvar org-todo-keyword-alist-for-agenda nil)
(defvar org-tag-alist-for-agenda nil
"Alist of all tags from all agenda files.")
(defvar org-tag-groups-alist-for-agenda nil
"Alist of all groups tags from all current agenda files.")
(defvar-local org-tag-groups-alist nil)
(defvar org-agenda-contributing-files nil)
(defvar-local org-current-tag-alist nil
"Alist of all tag groups in current buffer.
This variable takes into consideration `org-tag-alist',
`org-tag-persistent-alist' and TAGS keywords in the buffer.")
(defvar-local org-not-done-keywords nil)
(defvar-local org-done-keywords nil)
(defvar-local org-todo-heads nil)
(defvar-local org-todo-sets nil)
(defvar-local org-todo-log-states nil)
(defvar-local org-todo-kwd-alist nil)
(defvar-local org-todo-key-alist nil)
(defvar-local org-todo-key-trigger nil)
(defcustom org-todo-interpretation 'sequence
"Controls how TODO keywords are interpreted.
This variable is in principle obsolete and is only used for
backward compatibility, if the interpretation of todo keywords is
not given already in `org-todo-keywords'. See that variable for
more information."
:group 'org-todo
:group 'org-keywords
:type '(choice (const sequence)
(const type)))
(defcustom org-use-fast-todo-selection 'auto
"\\<org-mode-map>\
Non-nil means use the fast todo selection scheme with `\\[org-todo]'.
This variable describes if and under what circumstances the cycling
mechanism for TODO keywords will be replaced by a single-key, direct
selection scheme, where the choices are displayed in a little window.
When nil, fast selection is never used. This means that the command
will always switch to the next state.
When it is the symbol `auto', fast selection is whenever selection
keys have been defined.
`expert' is like `auto', but no special window with the keyword
will be shown, choices will only be listed in the prompt.
In all cases, the special interface is only used if access keys have
actually been assigned by the user, i.e. if keywords in the configuration
are followed by a letter in parenthesis, like TODO(t)."
:group 'org-todo
:set (lambda (var val)
(cond
((eq var t) (set-default-toplevel-value var 'auto))
((eq var 'prefix) (set-default-toplevel-value var nil))
(t (set-default-toplevel-value var val))))
:type '(choice
(const :tag "Never" nil)
(const :tag "Automatically, when key letter have been defined" auto)
(const :tag "Automatically, but don't show the selection window" expert)))
(defcustom org-provide-todo-statistics t
"Non-nil means update todo statistics after insert and toggle.
ALL-HEADLINES means update todo statistics by including headlines
with no TODO keyword as well, counting them as not done.
A list of TODO keywords means the same, but skip keywords that are
not in this list.
When set to a list of two lists, the first list contains keywords
to consider as TODO keywords, the second list contains keywords
to consider as DONE keywords.
When this is set, todo statistics is updated in the parent of the
current entry each time a todo state is changed."
:group 'org-todo
:type '(choice
(const :tag "Yes, only for TODO entries" t)
(const :tag "Yes, including all entries" all-headlines)
(repeat :tag "Yes, for TODOs in this list"
(string :tag "TODO keyword"))
(list :tag "Yes, for TODOs and DONEs in these lists"
(repeat (string :tag "TODO keyword"))
(repeat (string :tag "DONE keyword")))
(other :tag "No TODO statistics" nil)))
(defcustom org-hierarchical-todo-statistics t
"Non-nil means TODO statistics covers just direct children.
When nil, all entries in the subtree are considered.
This has only an effect if `org-provide-todo-statistics' is set.
To set this to nil for only a single subtree, use a COOKIE_DATA
property and include the word \"recursive\" into the value."
:group 'org-todo
:type 'boolean)
(defcustom org-after-todo-state-change-hook nil
"Hook which is run after the state of a TODO item was changed.
The new state (a string with a TODO keyword, or nil) is available in the
Lisp variable `org-state'."
:group 'org-todo
:type 'hook)
(defcustom org-after-note-stored-hook nil
"Hook triggered after a note is stored.
The point is at the stored note when the hook is executed."
:group 'org-progress
:type 'hook
:package-version '(Org . "9.7"))
(defvar org-blocker-hook nil
"Hook for functions that are allowed to block a state change.
Functions in this hook should not modify the buffer.
Each function gets as its single argument a property list,
see `org-trigger-hook' for more information about this list.
If any of the functions in this hook returns nil, the state change
is blocked.")
(defvar org-trigger-hook nil
"Hook for functions that are triggered by a state change.
Each function gets as its single argument a property list with at
least the following elements:
(:type type-of-change :position pos-at-entry-start
:from old-state :to new-state)
Depending on the type, more properties may be present.
This mechanism is currently implemented for:
TODO state changes
------------------
:type todo-state-change
:from previous state (keyword as a string), or nil, or a symbol
`todo' or `done', to indicate the general type of state.
:to new state, like in :from")
(defcustom org-enforce-todo-dependencies nil
"Non-nil means undone TODO entries will block switching the parent to DONE.
Also, if a parent has an :ORDERED: property, switching an entry to DONE will
be blocked if any prior sibling is not yet done.
Finally, if the parent is blocked because of ordered siblings of its own,
the child will also be blocked."
:set (lambda (var val)
(set-default-toplevel-value var val)
(if val
(add-hook 'org-blocker-hook
'org-block-todo-from-children-or-siblings-or-parent)
(remove-hook 'org-blocker-hook
'org-block-todo-from-children-or-siblings-or-parent)))
:group 'org-todo
:type 'boolean)
(defcustom org-enforce-todo-checkbox-dependencies nil
"Non-nil means unchecked boxes will block switching the parent to DONE.
When this is nil, checkboxes have no influence on switching TODO states.
When non-nil, you first need to check off all check boxes before the TODO
entry can be switched to DONE.
This variable needs to be set before org.el is loaded, and you need to
restart Emacs after a change to make the change effective. The only way
to change it while Emacs is running is through the customize interface."
:set (lambda (var val)
(set-default-toplevel-value var val)
(if val
(add-hook 'org-blocker-hook
'org-block-todo-from-checkboxes)
(remove-hook 'org-blocker-hook
'org-block-todo-from-checkboxes)))
:group 'org-todo
:type 'boolean)
(defcustom org-treat-insert-todo-heading-as-state-change nil
"Non-nil means inserting a TODO heading is treated as state change.
So when the command `\\[org-insert-todo-heading]' is used, state change
logging will apply if appropriate. When nil, the new TODO item will
be inserted directly, and no logging will take place."
:group 'org-todo
:type 'boolean)
(defcustom org-treat-S-cursor-todo-selection-as-state-change t
"Non-nil means switching TODO states with S-cursor counts as state change.
This is the default behavior. However, setting this to nil allows a
convenient way to select a TODO state and bypass any logging associated
with that."
:group 'org-todo
:type 'boolean)
(defcustom org-todo-state-tags-triggers nil
"Tag changes that should be triggered by TODO state changes.
This is a list. Each entry is
(state-change (tag . flag) .......)
State-change can be a string with a state, and empty string to indicate the
state that has no TODO keyword, or it can be one of the symbols `todo'
or `done', meaning any not-done or done state, respectively."
:group 'org-todo
:group 'org-tags
:type '(repeat
(cons (choice :tag "When changing to"
(const :tag "Not-done state" todo)
(const :tag "Done state" done)
(string :tag "State"))
(repeat
(cons :tag "Tag action"
(string :tag "Tag")
(choice (const :tag "Add" t) (const :tag "Remove" nil)))))))
(defcustom org-log-done nil
"Information to record when a task moves to the DONE state.
Possible values are:
nil Don't add anything, just change the keyword
time Add a time stamp to the task
note Prompt for a note and add it with template `org-log-note-headings'
This option can also be set with on a per-file-basis with
#+STARTUP: nologdone
#+STARTUP: logdone
#+STARTUP: lognotedone
You can have local logging settings for a subtree by setting the LOGGING
property to one or more of these keywords."
:group 'org-todo
:group 'org-progress
:type '(choice
(const :tag "No logging" nil)
(const :tag "Record CLOSED timestamp" time)
(const :tag "Record CLOSED timestamp with note." note)))
;; Normalize old uses of org-log-done.
(cond
((eq org-log-done t) (setq org-log-done 'time))
((and (listp org-log-done) (memq 'done org-log-done))
(setq org-log-done 'note)))
(defcustom org-log-reschedule nil
"Information to record when the scheduling date of a task is modified.
Possible values are:
nil Don't add anything, just change the date
time Add a time stamp to the task
note Prompt for a note and add it with template `org-log-note-headings'
This option can also be set with on a per-file-basis with
#+STARTUP: nologreschedule
#+STARTUP: logreschedule
#+STARTUP: lognotereschedule
You can have local logging settings for a subtree by setting the LOGGING
property to one or more of these keywords.
This variable has an effect when calling `org-schedule' or
`org-agenda-schedule' only."
:group 'org-todo
:group 'org-progress
:type '(choice
(const :tag "No logging" nil)
(const :tag "Record timestamp" time)
(const :tag "Record timestamp with note" note)))
(defcustom org-log-redeadline nil
"Information to record when the deadline date of a task is modified.
Possible values are:
nil Don't add anything, just change the date
time Add a time stamp to the task
note Prompt for a note and add it with template `org-log-note-headings'
This option can also be set with on a per-file-basis with
#+STARTUP: nologredeadline
#+STARTUP: logredeadline
#+STARTUP: lognoteredeadline
You can have local logging settings for a subtree by setting the LOGGING
property to one or more of these keywords.
This variable has an effect when calling `org-deadline' or
`org-agenda-deadline' only."
:group 'org-todo
:group 'org-progress
:type '(choice
(const :tag "No logging" nil)
(const :tag "Record timestamp" time)
(const :tag "Record timestamp with note." note)))
(defcustom org-log-note-clock-out nil
"Non-nil means record a note when clocking out of an item.
This can also be configured on a per-file basis by adding one of
the following lines anywhere in the buffer:
#+STARTUP: lognoteclock-out
#+STARTUP: nolognoteclock-out"
:group 'org-todo
:group 'org-progress
:type 'boolean)
(defcustom org-log-done-with-time t
"Non-nil means the CLOSED time stamp will contain date and time.
When nil, only the date will be recorded."
:group 'org-progress
:type 'boolean)
(defcustom org-log-note-headings
'((done . "CLOSING NOTE %t")
(state . "State %-12s from %-12S %t")
(note . "Note taken on %t")
(reschedule . "Rescheduled from %S on %t")
(delschedule . "Not scheduled, was %S on %t")
(redeadline . "New deadline from %S on %t")
(deldeadline . "Removed deadline, was %S on %t")
(refile . "Refiled on %t")
(clock-out . ""))
"Headings for notes added to entries.
The value is an alist, with the car being a symbol indicating the
note context, and the cdr is the heading to be used. The heading
may also be the empty string. The following placeholders can be
used:
%t a time stamp.
%T an active time stamp instead the default inactive one
%d a short-format time stamp.
%D an active short-format time stamp.
%s the new TODO state or time stamp (inactive), in double quotes.
%S the old TODO state or time stamp (inactive), in double quotes.
%u the user name.
%U full user name.
In fact, it is not a good idea to change the `state' entry,
because Agenda Log mode depends on the format of these entries."
:group 'org-todo
:group 'org-progress
:type '(list :greedy t
(cons (const :tag "Heading when closing an item" done) string)
(cons (const :tag
"Heading when changing todo state (todo sequence only)"
state) string)
(cons (const :tag "Heading when just taking a note" note) string)
(cons (const :tag "Heading when rescheduling" reschedule) string)
(cons (const :tag "Heading when an item is no longer scheduled" delschedule) string)
(cons (const :tag "Heading when changing deadline" redeadline) string)
(cons (const :tag "Heading when deleting a deadline" deldeadline) string)
(cons (const :tag "Heading when refiling" refile) string)
(cons (const :tag "Heading when clocking out" clock-out) string)))
(unless (assq 'note org-log-note-headings)
(push '(note . "%t") org-log-note-headings))
(defvaralias 'org-log-state-notes-into-drawer 'org-log-into-drawer)
(defcustom org-log-into-drawer nil
"Non-nil means insert state change notes and time stamps into a drawer.
When nil, state changes notes will be inserted after the headline and
any scheduling and clock lines, but not inside a drawer.
The value of this variable should be the name of the drawer to use.
LOGBOOK is proposed as the default drawer for this purpose, you can
also set this to a string to define the drawer of your choice.
A value of t is also allowed, representing \"LOGBOOK\".
A value of t or nil can also be set with on a per-file-basis with
#+STARTUP: logdrawer
#+STARTUP: nologdrawer
If this variable is set, `org-log-state-notes-insert-after-drawers'
will be ignored.
You can set the property LOG_INTO_DRAWER to overrule this setting for
a subtree.
Do not check directly this variable in a Lisp program. Call
function `org-log-into-drawer' instead."
:group 'org-todo
:group 'org-progress
:type '(choice
(const :tag "Not into a drawer" nil)
(const :tag "LOGBOOK" t)
(string :tag "Other")))
(defun org-log-into-drawer ()
"Name of the log drawer, as a string, or nil.
This is the value of `org-log-into-drawer'. However, if the
current entry has or inherits a LOG_INTO_DRAWER property, it will
be used instead of the default value."
(let ((p (org-entry-get nil "LOG_INTO_DRAWER" 'inherit t)))
(cond ((equal p "nil") nil)
((equal p "t") "LOGBOOK")
((stringp p) p)
(p "LOGBOOK")
((stringp org-log-into-drawer) org-log-into-drawer)
(org-log-into-drawer "LOGBOOK"))))
(defcustom org-log-state-notes-insert-after-drawers nil
"Non-nil means insert state change notes after any drawers in entry.
Only the drawers that *immediately* follow the headline and the
deadline/scheduled line are skipped.
When nil, insert notes right after the heading and perhaps the line
with deadline/scheduling if present.
This variable will have no effect if `org-log-into-drawer' is
set."
:group 'org-todo
:group 'org-progress
:type 'boolean)
(defcustom org-log-states-order-reversed t
"Non-nil means the latest state note will be directly after heading.
When nil, the state change notes will be ordered according to time.
This option can also be set with on a per-file-basis with
#+STARTUP: logstatesreversed
#+STARTUP: nologstatesreversed"
:group 'org-todo
:group 'org-progress
:type 'boolean)
(defcustom org-todo-repeat-to-state nil
"The TODO state to which a repeater should return the repeating task.
By default this is the first task of a TODO sequence or the
previous state of a TYPE_TODO set. But you can specify to use
the previous state in a TODO sequence or a string.
Alternatively, you can set the :REPEAT_TO_STATE: property of the
entry, which has precedence over this option."
:group 'org-todo
:version "24.1"
:type '(choice (const :tag "Use the previous TODO state" t)
(const :tag "Use the head of the TODO sequence" nil)
(string :tag "Use a specific TODO state")))
(defcustom org-log-repeat 'time
"Non-nil means record moving through the DONE state when triggering repeat.
An auto-repeating task is immediately switched back to TODO when
marked DONE. If you are not logging state changes (by adding \"@\"
or \"!\" to the TODO keyword definition), or set `org-log-done' to
record a closing note, there will be no record of the task moving
through DONE. This variable forces taking a note anyway.
nil Don't force a record
time Record a time stamp
note Prompt for a note and add it with template `org-log-note-headings'
This option can also be set with on a per-file-basis with
#+STARTUP: nologrepeat
#+STARTUP: logrepeat
#+STARTUP: lognoterepeat
You can have local logging settings for a subtree by setting the LOGGING
property to one or more of these keywords."
:group 'org-todo
:group 'org-progress
:type '(choice
(const :tag "Don't force a record" nil)
(const :tag "Force recording the DONE state" time)
(const :tag "Force recording a note with the DONE state" note)))
(defcustom org-todo-repeat-hook nil
"Hook that is run after a task has been repeated."
:package-version '(Org . "9.2")
:group 'org-todo
:type 'hook)
(defgroup org-priorities nil
"Priorities in Org mode."
:tag "Org Priorities"
:group 'org-todo)
(defvaralias 'org-enable-priority-commands 'org-priority-enable-commands)
(defcustom org-priority-enable-commands t
"Non-nil means priority commands are active.
When nil, these commands will be disabled, so that you never accidentally
set a priority."
:group 'org-priorities
:type 'boolean)
(defvaralias 'org-highest-priority 'org-priority-highest)
(defcustom org-priority-highest ?A
"The highest priority of TODO items.
A character like ?A, ?B, etc., or a numeric value like 1, 2, etc.
The default is the character ?A, which is 65 as a numeric value.
If you set `org-priority-highest' to a numeric value inferior to
65, Org assumes you want to use digits for the priority cookie.
If you set it to >=65, Org assumes you want to use alphabetical
characters.
In both cases, the value of `org-priority-highest' must be
smaller than `org-priority-lowest': for example, if \"A\" is the
highest priority, it is smaller than the lowest \"C\" priority:
65 < 67."
:group 'org-priorities
:type '(choice
(character :tag "Character")
(integer :tag "Integer (< 65)")))
(defvaralias 'org-lowest-priority 'org-priority-lowest)
(defcustom org-priority-lowest ?C
"The lowest priority of TODO items.
A character like ?C, ?B, etc., or a numeric value like 9, 8, etc.
The default is the character ?C, which is 67 as a numeric value.
If you set `org-priority-lowest' to a numeric value inferior to
65, Org assumes you want to use digits for the priority cookie.
If you set it to >=65, Org assumes you want to use alphabetical
characters.
In both cases, the value of `org-priority-lowest' must be greater
than `org-priority-highest': for example, if \"C\" is the lowest
priority, it is greater than the highest \"A\" priority: 67 >
65."
:group 'org-priorities
:type '(choice
(character :tag "Character")
(integer :tag "Integer (< 65)")))
(defvaralias 'org-default-priority 'org-priority-default)
(defcustom org-priority-default ?B
"The default priority of TODO items.
This is the priority an item gets if no explicit priority is given.
When starting to cycle on an empty priority the first step in the cycle
depends on `org-priority-start-cycle-with-default'. The resulting first
step priority must not exceed the range from `org-priority-highest' to
`org-priority-lowest' which means that `org-priority-default' has to be
in this range exclusive or inclusive to the range boundaries. Else the
first step refuses to set the default and the second will fall back on
\(depending on the command used) the highest or lowest priority."
:group 'org-priorities
:type '(choice
(character :tag "Character")
(integer :tag "Integer (< 65)")))
(defcustom org-priority-start-cycle-with-default t
"Non-nil means start with default priority when starting to cycle.
When this is nil, the first step in the cycle will be (depending on the
command used) one higher or lower than the default priority.
See also `org-priority-default'."
:group 'org-priorities
:type 'boolean)
(defvaralias 'org-get-priority-function 'org-priority-get-priority-function)
(defcustom org-priority-get-priority-function nil
"Function to extract the priority from a string.
The string is normally the headline. If this is nil, Org
computes the priority from the priority cookie like [#A] in the
headline. It returns an integer, increasing by 1000 for each
priority level.
The user can set a different function here, which should take a
string as an argument and return the numeric priority."
:group 'org-priorities
:version "24.1"
:type '(choice
(const nil)
(function)))
(defgroup org-time nil
"Options concerning time stamps and deadlines in Org mode."
:tag "Org Time"
:group 'org)
(defvaralias 'org-time-stamp-rounding-minutes 'org-timestamp-rounding-minutes)
(defcustom org-timestamp-rounding-minutes '(0 5)
"Number of minutes to round time stamps to.
\\<org-mode-map>\
These are two values, the first applies when first creating a time stamp.
The second applies when changing it with the commands `S-up' and `S-down'.
When changing the time stamp, this means that it will change in steps
of N minutes, as given by the second value.
When a setting is 0 or 1, insert the time unmodified. Useful rounding
numbers should be factors of 60, so for example 5, 10, 15.
When this is larger than 1, you can still force an exact time stamp by using
a double prefix argument to a time stamp command like \
`\\[org-timestamp]' or `\\[org-timestamp-inactive],
and by using a prefix arg to `S-up/down' to specify the exact number
of minutes to shift."
:group 'org-time
:get (lambda (var) ; Make sure both elements are there
(if (integerp (default-value var))
(list (default-value var) 5)
(default-value var)))
:type '(list
(integer :tag "when inserting times")
(integer :tag "when modifying times")))
;; Normalize old customizations of this variable.
(when (integerp org-timestamp-rounding-minutes)
(setq org-timestamp-rounding-minutes
(list org-timestamp-rounding-minutes
org-timestamp-rounding-minutes)))
(defcustom org-display-custom-times nil
"Non-nil means overlay custom formats over all time stamps.
The formats are defined through the variable `org-timestamp-custom-formats'.
To turn this on on a per-file basis, insert anywhere in the file:
#+STARTUP: customtime"
:group 'org-time
:type 'sexp)
(make-variable-buffer-local 'org-display-custom-times)
(defvaralias 'org-time-stamp-custom-formats 'org-timestamp-custom-formats)
(defcustom org-timestamp-custom-formats
'("%m/%d/%y %a" . "%m/%d/%y %a %H:%M") ; american
"Custom formats for time stamps.
See `format-time-string' for the syntax.
These are overlaid over the default ISO format if the variable
`org-display-custom-times' is set. Time like %H:%M should be at the
end of the second format. The custom formats are also honored by export
commands, if custom time display is turned on at the time of export.
This variable also affects how timestamps are exported.
Leading \"<\" and trailing \">\" pair will be stripped from the format
strings."
:group 'org-time
:package-version '(Org . "9.6")
:type '(cons string string))
(defun org-time-stamp-format (&optional with-time inactive custom)
"Get timestamp format for a time string.
The format is based on `org-timestamp-formats' (if CUSTOM is nil) or or
`org-timestamp-custom-formats' (if CUSTOM if non-nil).
When optional argument WITH-TIME is non-nil, the timestamp will contain
time.
When optional argument INACTIVE is nil, format active timestamp.
When `no-brackets', strip timestamp brackets.
Otherwise, format inactive timestamp."
(let ((format (funcall
(if with-time #'cdr #'car)
(if custom
org-timestamp-custom-formats
org-timestamp-formats))))
;; Strip brackets, if any.
(when (or (and (string-prefix-p "<" format)
(string-suffix-p ">" format))
(and (string-prefix-p "[" format)
(string-suffix-p "]" format)))
(setq format (substring format 1 -1)))
(pcase inactive
(`no-brackets format)
(`nil (concat "<" format ">"))
(_ (concat "[" format "]")))))
(defcustom org-deadline-warning-days 14
"Number of days before expiration during which a deadline becomes active.
This variable governs the display in sparse trees and in the agenda.
When 0 or negative, it means use this number (the absolute value of it)
even if a deadline has a different individual lead time specified.
Custom commands can set this variable in the options section."
:group 'org-time
:group 'org-agenda-daily/weekly
:type 'integer)
(defcustom org-scheduled-delay-days 0
"Number of days before a scheduled item becomes active.
This variable governs the display in sparse trees and in the agenda.
The default value (i.e. 0) means: don't delay scheduled item.
When negative, it means use this number (the absolute value of it)
even if a scheduled item has a different individual delay time
specified.
Custom commands can set this variable in the options section."
:group 'org-time
:group 'org-agenda-daily/weekly
:version "24.4"
:package-version '(Org . "8.0")
:type 'integer)
(defcustom org-read-date-prefer-future t
"Non-nil means assume future for incomplete date input from user.
This affects the following situations:
1. The user gives a month but not a year.
For example, if it is April and you enter \"feb 2\", this will be read
as Feb 2, *next* year. \"May 5\", however, will be this year.
2. The user gives a day, but no month.
For example, if today is the 15th, and you enter \"3\", Org will read
this as the third of *next* month. However, if you enter \"17\",
it will be considered as *this* month.
If you set this variable to the symbol `time', then also the following
will work:
3. If the user gives a time.
If the time is before now, it will be interpreted as tomorrow.
Currently none of this works for ISO week specifications.
When this option is nil, the current day, month and year will always be
used as defaults.
See also `org-agenda-jump-prefer-future'."
:group 'org-time
:type '(choice
(const :tag "Never" nil)
(const :tag "Check month and day" t)
(const :tag "Check month, day, and time" time)))
(defcustom org-agenda-jump-prefer-future 'org-read-date-prefer-future
"Should the agenda jump command prefer the future for incomplete dates?
The default is to do the same as configured in `org-read-date-prefer-future'.
But you can also set a deviating value here.
This may t or nil, or the symbol `org-read-date-prefer-future'."
:group 'org-agenda
:group 'org-time
:version "24.1"
:type '(choice
(const :tag "Use org-read-date-prefer-future"
org-read-date-prefer-future)
(const :tag "Never" nil)
(const :tag "Always" t)))
(defcustom org-read-date-force-compatible-dates t
"Should date/time prompt force dates that are guaranteed to work in Emacs?
Depending on the system Emacs is running on, certain dates cannot
be represented with the type used internally to represent time.
Dates between 1970-1-1 and 2038-1-1 can always be represented
correctly. Some systems allow for earlier dates, some for later,
some for both. One way to find out is to insert any date into an
Org buffer, putting the cursor on the year and hitting S-up and
S-down to test the range.
When this variable is set to t, the date/time prompt will not let
you specify dates outside the 1970-2037 range, so it is certain that
these dates will work in whatever version of Emacs you are
running, and also that you can move a file from one Emacs implementation
to another. Whenever Org is forcing the year for you, it will display
a message and beep.
When this variable is nil, Org will check if the date is
representable in the specific Emacs implementation you are using.
If not, it will force a year, usually the current year, and beep
to remind you. Currently this setting is not recommended because
the likelihood that you will open your Org files in an Emacs that
has limited date range is not negligible.
A workaround for this problem is to use diary sexp dates for time
stamps outside of this range."
:group 'org-time
:version "24.1"
:type 'boolean)
(defcustom org-read-date-display-live t
"Non-nil means display current interpretation of date prompt live.
This display will be in an overlay, in the minibuffer. Note that
live display is only active when `org-read-date-popup-calendar'
is non-nil."
:group 'org-time
:type 'boolean)
(defvaralias 'org-popup-calendar-for-date-prompt
'org-read-date-popup-calendar)
(defcustom org-read-date-popup-calendar t
"Non-nil means pop up a calendar when prompting for a date.
In the calendar, the date can be selected with \\`mouse-1'. However, the
minibuffer will also be active, and you can simply enter the date as well.
When nil, only the minibuffer will be available."
:group 'org-time
:type 'boolean)
(defcustom org-extend-today-until 0
"The hour when your day really ends. Must be an integer.
This has influence for the following applications:
- When switching the agenda to \"today\". If it is still earlier than
the time given here, the day recognized as TODAY is actually yesterday.
- When a date is read from the user and it is still before the time given
here, the current date and time will be assumed to be yesterday, 23:59.
Also, timestamps inserted in capture templates follow this rule.
IMPORTANT: This is a feature whose implementation is and likely will
remain incomplete. Really, it is only here because past midnight seems to
be the favorite working time of John Wiegley :-)"
:group 'org-time
:type 'integer)
(defcustom org-use-effective-time nil
"If non-nil, consider `org-extend-today-until' when creating timestamps.
For example, if `org-extend-today-until' is 8, and it's 4am, then the
\"effective time\" of any timestamps between midnight and 8am will be
23:59 of the previous day."
:group 'org-time
:version "24.1"
:type 'boolean)
(defcustom org-use-last-clock-out-time-as-effective-time nil
"When non-nil, use the last clock out time for `org-todo'.
Note that this option has precedence over the combined use of
`org-use-effective-time' and `org-extend-today-until'."
:group 'org-time
:version "24.4"
:package-version '(Org . "8.0")
:type 'boolean)
(defcustom org-edit-timestamp-down-means-later nil
"Non-nil means S-down will increase the time in a time stamp.
When nil, S-up will increase."
:group 'org-time
:type 'boolean)
(defcustom org-calendar-follow-timestamp-change t
"Non-nil means make the calendar window follow timestamp changes.
When a timestamp is modified and the calendar window is visible, it will be
moved to the new date."
:group 'org-time
:type 'boolean)
(defgroup org-tags nil
"Options concerning tags in Org mode."
:tag "Org Tags"
:group 'org)
(defcustom org-tag-alist nil
"Default tags available in Org files.
The value of this variable is an alist. Associations either:
(TAG)
(TAG . SELECT)
(SPECIAL)
where TAG is a tag as a string, SELECT is character, used to
select that tag through the fast tag selection interface, and
SPECIAL is one of the following keywords: `:startgroup',
`:startgrouptag', `:grouptags', `:endgroup', `:endgrouptag' or
`:newline'. These keywords are used to define a hierarchy of
tags. See manual for details.
When this variable is nil, Org mode bases tag input on what is
already in the buffer. The value can be overridden locally by
using a TAGS keyword, e.g.,
#+TAGS: tag1 tag2
See also `org-tag-persistent-alist' to sidestep this behavior."
:group 'org-tags
:type '(repeat
(choice
(cons :tag "Tag with key"
(string :tag "Tag name")
(character :tag "Access char"))
(list :tag "Tag" (string :tag "Tag name"))
(const :tag "Start radio group" (:startgroup))
(const :tag "Start tag group, non distinct" (:startgrouptag))
(const :tag "Group tags delimiter" (:grouptags))
(const :tag "End radio group" (:endgroup))
(const :tag "End tag group, non distinct" (:endgrouptag))
(const :tag "New line" (:newline)))))
(defcustom org-tag-persistent-alist nil
"Tags always available in Org files.
The value of this variable is an alist. Associations either:
(TAG)
(TAG . SELECT)
(SPECIAL)
where TAG is a tag as a string, SELECT is a character, used to
select that tag through the fast tag selection interface, and
SPECIAL is one of the following keywords: `:startgroup',
`:startgrouptag', `:grouptags', `:endgroup', `:endgrouptag' or
`:newline'. These keywords are used to define a hierarchy of
tags. See manual for details.
Unlike to `org-tag-alist', tags defined in this variable do not
depend on a local TAGS keyword. Instead, to disable these tags
on a per-file basis, insert anywhere in the file:
#+STARTUP: noptag"
:group 'org-tags
:type '(repeat
(choice
(cons :tag "Tag with key"
(string :tag "Tag name")
(character :tag "Access char"))
(list :tag "Tag" (string :tag "Tag name"))
(const :tag "Start radio group" (:startgroup))
(const :tag "Start tag group, non distinct" (:startgrouptag))
(const :tag "Group tags delimiter" (:grouptags))
(const :tag "End radio group" (:endgroup))
(const :tag "End tag group, non distinct" (:endgrouptag))
(const :tag "New line" (:newline)))))
(defcustom org-complete-tags-always-offer-all-agenda-tags nil
"If non-nil, always offer completion for all tags of all agenda files.
Setting this variable locally allows for dynamic generation of tag
completions in capture buffers.
(add-hook \\='org-capture-mode-hook
(lambda ()
(setq-local org-complete-tags-always-offer-all-agenda-tags t)))"
:group 'org-tags
:version "24.1"
:type 'boolean)
(defvar org-file-tags nil
"List of tags that can be inherited by all entries in the file.
The tags will be inherited if the variable `org-use-tag-inheritance'
says they should be.
This variable is populated from #+FILETAGS lines.")
(defcustom org-use-fast-tag-selection 'auto
"Non-nil means use fast tag selection scheme.
This is a special interface to select and deselect tags with single keys.
When nil, fast selection is never used.
When the symbol `auto', fast selection is used if and only if selection
characters for tags have been configured, either through the variable
`org-tag-alist' or through a #+TAGS line in the buffer.
When t, fast selection is always used and selection keys are assigned
automatically if necessary."
:group 'org-tags
:type '(choice
(const :tag "Always" t)
(const :tag "Never" nil)
(const :tag "When selection characters are configured" auto)))
(defcustom org-fast-tag-selection-single-key nil
"Non-nil means fast tag selection exits after first change.
When nil, you have to press RET to exit it.
During fast tag selection, you can toggle this flag with `C-c'.
This variable can also have the value `expert'. In this case, the window
displaying the tags menu is not even shown, until you press `C-c' again."
:group 'org-tags
:type '(choice
(const :tag "No" nil)
(const :tag "Yes" t)
(const :tag "Expert" expert)))
(defvar org--fast-tag-selection-keys
(string-to-list "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ{|}~")
"List of chars to be used as bindings by `org-fast-tag-selection'.")
(defcustom org-fast-tag-selection-maximum-tags (length org--fast-tag-selection-keys)
"Set the maximum tags number for fast tag selection.
This variable only affects tags without explicit key bindings outside
tag groups. All the tags with user bindings and all the tags
corresponding to tag groups are always displayed.
When the number of tags with bindings + tags inside tag groups is
smaller than `org-fast-tag-selection-maximum-tags', tags without
explicit bindings will be assigned a binding and displayed up to the
limit."
:package-version '(Org . "9.7")
:group 'org-tags
:type 'number
:safe #'numberp)
(defvar org-fast-tag-selection-include-todo nil
"Non-nil means fast tags selection interface will also offer TODO states.
This is an undocumented feature, you should not rely on it.")
(defcustom org-tags-column -77
"The column to which tags should be indented in a headline.
If this number is positive, it specifies the column. If it is negative,
it means that the tags should be flushright to that column. For example,
-80 works well for a normal 80 character screen.
When 0, place tags directly after headline text, with only one space in
between."
:group 'org-tags
:type 'integer)
(defcustom org-auto-align-tags t
"Non-nil keeps tags aligned when modifying headlines.
Some operations (i.e. demoting) change the length of a headline and
therefore shift the tags around. With this option turned on, after
each such operation the tags are again aligned to `org-tags-column'."
:group 'org-tags
:type 'boolean)
(defcustom org-use-tag-inheritance t
"Non-nil means tags in levels apply also for sublevels.
When nil, only the tags directly given in a specific line apply there.
This may also be a list of tags that should be inherited, or a regexp that
matches tags that should be inherited. Additional control is possible
with the variable `org-tags-exclude-from-inheritance' which gives an
explicit list of tags to be excluded from inheritance, even if the value of
`org-use-tag-inheritance' would select it for inheritance.
If this option is t, a match early-on in a tree can lead to a large
number of matches in the subtree when constructing the agenda or creating
a sparse tree. If you only want to see the first match in a tree during
a search, check out the variable `org-tags-match-list-sublevels'."
:group 'org-tags
:type '(choice
(const :tag "Not" nil)
(const :tag "Always" t)
(repeat :tag "Specific tags" (string :tag "Tag"))
(regexp :tag "Tags matched by regexp")))
(defcustom org-tags-exclude-from-inheritance nil
"List of tags that should never be inherited.
This is a way to exclude a few tags from inheritance. For way to do
the opposite, to actively allow inheritance for selected tags,
see the variable `org-use-tag-inheritance'."
:group 'org-tags
:type '(repeat (string :tag "Tag")))
(defun org-tag-inherit-p (tag)
"Check if TAG is one that should be inherited."
(cond
((member tag org-tags-exclude-from-inheritance) nil)
((eq org-use-tag-inheritance t) t)
((not org-use-tag-inheritance) nil)
((stringp org-use-tag-inheritance)
(string-match org-use-tag-inheritance tag))
((listp org-use-tag-inheritance)
(member tag org-use-tag-inheritance))
(t (error "Invalid setting of `org-use-tag-inheritance'"))))
(defcustom org-tags-match-list-sublevels t
"Non-nil means list also sublevels of headlines matching a search.
This variable applies to tags/property searches, and also to stuck
projects because this search is based on a tags match as well.
When set to the symbol `indented', sublevels are indented with
leading dots.
Because of tag inheritance (see variable `org-use-tag-inheritance'),
the sublevels of a headline matching a tag search often also match
the same search. Listing all of them can create very long lists.
Setting this variable to nil causes subtrees of a match to be skipped.
This variable is semi-obsolete and probably should always be true. It
is better to limit inheritance to certain tags using the variables
`org-use-tag-inheritance' and `org-tags-exclude-from-inheritance'."
:group 'org-tags
:type '(choice
(const :tag "No, don't list them" nil)
(const :tag "Yes, do list them" t)
(const :tag "List them, indented with leading dots" indented)))
(defcustom org-tags-sort-function nil
"When set, tags are sorted using this function as a comparator.
When the value is nil, use default sorting order. The default sorting
is alphabetical, except in `org-set-tags' where no sorting is done by
default."
:group 'org-tags
:type '(choice
(const :tag "Default sorting" nil)
(const :tag "Alphabetical" org-string<)
(const :tag "Reverse alphabetical" org-string>)
(function :tag "Custom function" nil)))
(defvar org-tags-history nil
"History of minibuffer reads for tags.")
(defvar org-last-tags-completion-table nil
"The last used completion table for tags.")
(defvar org-after-tags-change-hook nil
"Hook that is run after the tags in a line have changed.")
(defgroup org-properties nil
"Options concerning properties in Org mode."
:tag "Org Properties"
:group 'org)
(defcustom org-property-format "%-10s %s"
"How property key/value pairs should be formatted by `indent-line'.
When `indent-line' hits a property definition, it will format the line
according to this format, mainly to make sure that the values are
lined-up with respect to each other."
:group 'org-properties
:type 'string)
(defcustom org-properties-postprocess-alist nil
"Alist of properties and functions to adjust inserted values.
Elements of this alist must be of the form
([string] [function])
where [string] must be a property name and [function] must be a
lambda expression: this lambda expression must take one argument,
the value to adjust, and return the new value as a string.
For example, this element will allow the property \"Remaining\"
to be updated wrt the relation between the \"Effort\" property
and the clock summary:
((\"Remaining\" (lambda(value)
(let ((clocksum (org-clock-sum-current-item))
(effort (org-duration-to-minutes
(org-entry-get (point) \"Effort\"))))
(org-minutes-to-clocksum-string (- effort clocksum))))))"
:group 'org-properties
:version "24.1"
:type '(alist :key-type (string :tag "Property")
:value-type (function :tag "Function")))
(defcustom org-use-property-inheritance nil
"Non-nil means properties apply also for sublevels.
This setting is chiefly used during property searches. Turning it on can
cause significant overhead when doing a search, which is why it is not
on by default.
When nil, only the properties directly given in the current entry count.
When t, every property is inherited. The value may also be a list of
properties that should have inheritance, or a regular expression matching
properties that should be inherited.
However, note that some special properties use inheritance under special
circumstances (not in searches). Examples are CATEGORY, ARCHIVE, COLUMNS,
and the properties ending in \"_ALL\" when they are used as descriptor
for valid values of a property.
Note for programmers:
When querying an entry with `org-entry-get', you can control if inheritance
should be used. By default, `org-entry-get' looks only at the local
properties. You can request inheritance by setting the inherit argument
to t (to force inheritance) or to `selective' (to respect the setting
in this variable)."
:group 'org-properties
:type '(choice
(const :tag "Not" nil)
(const :tag "Always" t)
(repeat :tag "Specific properties" (string :tag "Property"))
(regexp :tag "Properties matched by regexp")))
(defun org-property-inherit-p (property)
"Return a non-nil value if PROPERTY should be inherited."
(cond
((eq org-use-property-inheritance t) t)
((not org-use-property-inheritance) nil)
((stringp org-use-property-inheritance)
(string-match org-use-property-inheritance property))
((listp org-use-property-inheritance)
(member-ignore-case property org-use-property-inheritance))
(t (error "Invalid setting of `org-use-property-inheritance'"))))
(defcustom org-property-separators nil
"An alist to control how properties are combined.
The car of each item should be either a list of property names or
a regular expression, while the cdr should be the separator to
use when combining that property.
If an alist item cannot be found that matches a given property, a
single space will be used as the separator."
:group 'org-properties
:package-version '(Org . "9.6")
:type '(alist :key-type (choice (repeat :tag "Properties" string)
(string :tag "Regular Expression"))
:value-type (restricted-sexp :tag "Separator"
:match-alternatives (stringp)
:value " ")))
(defun org--property-get-separator (property)
"Get the separator to use for combining PROPERTY."
(or
(catch 'separator
(dolist (spec org-property-separators)
(if (listp (car spec))
(if (member property (car spec))
(throw 'separator (cdr spec)))
(if (string-match-p (car spec) property)
(throw 'separator (cdr spec))))))
" "))
(defcustom org-columns-default-format "%25ITEM %TODO %3PRIORITY %TAGS"
"The default column format, if no other format has been defined.
This variable can be set on the per-file basis by inserting a line
#+COLUMNS: %25ITEM ....."
:group 'org-properties
:type 'string)
(defcustom org-columns-default-format-for-agenda nil
"The default column format in an agenda buffer.
This will be used for column view in the agenda unless a format has
been set by adding `org-overriding-columns-format' to the local
settings list of a custom agenda view. When nil, the columns format
for the first item in the agenda list will be used, or as a fall-back,
`org-columns-default-format'."
:group 'org-properties
:type '(choice
(const :tag "No default" nil)
(string :tag "Format string")))
(defcustom org-columns-ellipses ".."
"The ellipses to be used when a field in column view is truncated.
When this is the empty string, as many characters as possible are shown,
but then there will be no visual indication that the field has been truncated.
When this is a string of length N, the last N characters of a truncated
field are replaced by this string. If the column is narrower than the
ellipses string, only part of the ellipses string will be shown."
:group 'org-properties
:type 'string)
(defconst org-global-properties-fixed
'(("VISIBILITY_ALL" . "folded children content all")
("CLOCK_MODELINE_TOTAL_ALL" . "current today repeat all auto"))
"List of property/value pairs that can be inherited by any entry.
These are fixed values, for the preset properties. The user variable
that can be used to add to this list is `org-global-properties'.
The entries in this list are cons cells where the car is a property
name and cdr is a string with the value. If the value represents
multiple items like an \"_ALL\" property, separate the items by
spaces.")
(defcustom org-global-properties nil
"List of property/value pairs that can be inherited by any entry.
This list will be combined with the constant `org-global-properties-fixed'.
The entries in this list are cons cells where the car is a property
name and cdr is a string with the value.
Buffer local properties are added either by a document property drawer
:PROPERTIES:
:NAME: VALUE
:END:
or by adding lines like
#+PROPERTY: NAME VALUE"
:group 'org-properties
:type '(repeat
(cons (string :tag "Property")
(string :tag "Value"))))
(defvar-local org-keyword-properties nil
"List of property/value pairs inherited by any entry.
Valid for the current buffer. This variable is populated from
PROPERTY keywords.
Note that properties are defined also in property drawers.
Properties defined there take precedence over properties defined
as keywords.")
(defgroup org-agenda nil
"Options concerning agenda views in Org mode."
:tag "Org Agenda"
:group 'org)
(defvar-local org-category nil
"Variable used by Org files to set a category for agenda display.
There are multiple ways to set the category. One way is to set
it in the document property drawer. For example:
:PROPERTIES:
:CATEGORY: Elisp
:END:
Other ways to define it is as an Emacs file variable, for example
# -*- mode: org; org-category: \"Elisp\"
or for the file to contain a special line:
#+CATEGORY: Elisp
If the file does not specify a category, then file's base name
is used instead.")
(put 'org-category 'safe-local-variable (lambda (x) (or (symbolp x) (stringp x))))
(defcustom org-agenda-files nil
"The files to be used for agenda display.
If an entry is a directory, all files in that directory that are matched
by `org-agenda-file-regexp' will be part of the file list.
If the value of the variable is not a list but a single file name, then
the list of agenda files is actually stored and maintained in that file,
one agenda file per line. In this file paths can be given relative to
`org-directory'. Tilde expansion and environment variable substitution
are also made.
Entries may be added to this list with `\\[org-agenda-file-to-front]'
and removed with `\\[org-remove-file]'."
:group 'org-agenda
:type '(choice
(repeat :tag "List of files and directories" file)
(file :tag "Store list in a file\n" :value "~/.agenda_files")))
(defcustom org-agenda-file-regexp "\\`[^.].*\\.org\\'"
"Regular expression to match files for `org-agenda-files'.
If any element in the list in that variable contains a directory instead
of a normal file, all files in that directory that are matched by this
regular expression will be included."
:group 'org-agenda
:type 'regexp)
(defvaralias 'org-agenda-multi-occur-extra-files
'org-agenda-text-search-extra-files)
(defcustom org-agenda-text-search-extra-files nil
"List of extra files to be searched by text search commands.
These files will be searched in addition to the agenda files by the
commands `org-search-view' (`\\[org-agenda] s') \
and `org-occur-in-agenda-files'.
Note that these files will only be searched for text search commands,
not for the other agenda views like todo lists, tag searches or the weekly
agenda. This variable is intended to list notes and possibly archive files
that should also be searched by these two commands.
In fact, if the first element in the list is the symbol `agenda-archives',
then all archive files of all agenda files will be added to the search
scope."
:group 'org-agenda
:type '(set :greedy t
(const :tag "Agenda Archives" agenda-archives)
(repeat :inline t (file))))
(defcustom org-agenda-skip-unavailable-files nil
"Non-nil means to just skip non-reachable files in `org-agenda-files'.
A nil value means to remove them, after a query, from the list."
:group 'org-agenda
:type 'boolean)
(defgroup org-latex nil
"Options for embedding LaTeX code into Org mode."
:tag "Org LaTeX"
:group 'org)
(defcustom org-format-latex-options
'(:foreground default :background default :scale 1.0
:html-foreground "Black" :html-background "Transparent"
:html-scale 1.0 :matchers ("begin" "$1" "$" "$$" "\\(" "\\["))
"Options for creating images from LaTeX fragments.
This is a property list with the following properties:
:foreground the foreground color for images embedded in Emacs, e.g. \"Black\".
`default' means use the foreground of the default face.
`auto' means use the foreground from the text face.
:background the background color, or \"Transparent\".
`default' means use the background of the default face.
`auto' means use the background from the text face.
:scale a scaling factor for the size of the images, to get more pixels
:html-foreground, :html-background, :html-scale
the same numbers for HTML export.
:matchers a list indicating which matchers should be used to
find LaTeX fragments. Valid members of this list are:
\"begin\" find environments
\"$1\" find single characters surrounded by $.$
\"$\" find math expressions surrounded by $...$
\"$$\" find math expressions surrounded by $$....$$
\"\\(\" find math expressions surrounded by \\(...\\)
\"\\=\\[\" find math expressions surrounded by \\=\\[...\\]"
:group 'org-latex
:type 'plist)
(defcustom org-format-latex-signal-error t
"Non-nil means signal an error when image creation of LaTeX snippets fails.
When nil, just push out a message."
:group 'org-latex
:version "24.1"
:type 'boolean)
(defcustom org-latex-to-mathml-jar-file nil
"Value of\"%j\" in `org-latex-to-mathml-convert-command'.
Use this to specify additional executable file say a jar file.
When using MathToWeb as the converter, specify the full-path to
your mathtoweb.jar file."
:group 'org-latex
:version "24.1"
:type '(choice
(const :tag "None" nil)
(file :tag "JAR file" :must-match t)))
(defcustom org-latex-to-mathml-convert-command nil
"Command to convert LaTeX fragments to MathML.
Replace format-specifiers in the command as noted below and use
`shell-command' to convert LaTeX to MathML.
%j: Executable file in fully expanded form as specified by
`org-latex-to-mathml-jar-file'.
%I: Input LaTeX file in fully expanded form.
%i: Shell-escaped LaTeX fragment to be converted.
It must not be used inside a quoted argument, the result of %i
expansion inside a quoted argument is undefined.
%o: Output MathML file.
This command is used by `org-create-math-formula'.
When using MathToWeb as the converter, set this option to
\"java -jar %j -unicode -force -df %o %I\".
When using LaTeXML set this option to
\"latexmlmath %i --presentationmathml=%o\"."
:group 'org-latex
:package-version '(Org . "9.7")
:type '(choice
(const :tag "None" nil)
(string :tag "\nShell command")))
(defcustom org-latex-to-html-convert-command nil
"Shell command to convert LaTeX fragments to HTML.
This command is very open-ended: the output of the command will
directly replace the LaTeX fragment in the resulting HTML.
Replace format-specifiers in the command as noted below and use
`shell-command' to convert LaTeX to HTML.
%i: The LaTeX fragment to be converted (shell-escaped).
It must not be used inside a quoted argument, the result of %i
expansion inside a quoted argument is undefined.
For example, this could be used with LaTeXML as
\"latexmlc literal:%i --profile=math --preload=siunitx.sty 2>/dev/null\"."
:group 'org-latex
:package-version '(Org . "9.7")
:type '(choice
(const :tag "None" nil)
(string :tag "Shell command")))
(defcustom org-preview-latex-default-process 'dvipng
"The default process to convert LaTeX fragments to image files.
All available processes and theirs documents can be found in
`org-preview-latex-process-alist', which see."
:group 'org-latex
:version "26.1"
:package-version '(Org . "9.0")
:type 'symbol)
(defcustom org-preview-latex-process-alist
'((dvipng
:programs ("latex" "dvipng")
:description "dvi > png"
:message "you need to install the programs: latex and dvipng."
:image-input-type "dvi"
:image-output-type "png"
:image-size-adjust (1.0 . 1.0)
:latex-compiler ("latex -interaction nonstopmode -output-directory %o %f")
:image-converter ("dvipng -D %D -T tight -o %O %f")
:transparent-image-converter
("dvipng -D %D -T tight -bg Transparent -o %O %f"))
(dvisvgm
:programs ("latex" "dvisvgm")
:description "dvi > svg"
:message "you need to install the programs: latex and dvisvgm."
:image-input-type "dvi"
:image-output-type "svg"
:image-size-adjust (1.7 . 1.5)
:latex-compiler ("latex -interaction nonstopmode -output-directory %o %f")
:image-converter ("dvisvgm %f --no-fonts --exact-bbox --scale=%S --output=%O"))
(imagemagick
:programs ("latex" "convert")
:description "pdf > png"
:message "you need to install the programs: latex and imagemagick."
:image-input-type "pdf"
:image-output-type "png"
:image-size-adjust (1.0 . 1.0)
:latex-compiler ("pdflatex -interaction nonstopmode -output-directory %o %f")
:image-converter
("convert -density %D -trim -antialias %f -quality 100 %O")))
"Definitions of external processes for LaTeX previewing.
Org mode can use some external commands to generate TeX snippet's images for
previewing or inserting into HTML files, e.g., \"dvipng\". This variable tells
`org-create-formula-image' how to call them.
The value is an alist with the pattern (NAME . PROPERTIES). NAME is a symbol.
PROPERTIES accepts the following attributes:
:programs list of strings, required programs.
:description string, describe the process.
:message string, message it when required programs cannot be found.
:image-input-type string, input file type of image converter (e.g., \"dvi\").
:image-output-type string, output file type of image converter (e.g., \"png\").
:image-size-adjust cons of numbers, the car element is used to adjust LaTeX
image size showed in buffer and the cdr element is for
HTML file. This option is only useful for process
developers, users should use variable
`org-format-latex-options' instead.
:post-clean list of strings, files matched are to be cleaned up once
the image is generated. When nil, the files with \".dvi\",
\".xdv\", \".pdf\", \".tex\", \".aux\", \".log\", \".svg\",
\".png\", \".jpg\", \".jpeg\" or \".out\" extension will
be cleaned up.
:latex-header list of strings, the LaTeX header of the snippet file.
When nil, the fallback value is used instead, which is
controlled by `org-format-latex-header',
`org-latex-default-packages-alist' and
`org-latex-packages-alist', which see.
:latex-compiler list of LaTeX commands, as strings. Each of them is given
to the shell. Place-holders \"%t\", \"%b\" and \"%o\" are
replaced with values defined below.
:image-converter list of image converter commands strings. Each of them is
given to the shell and supports any of the following
place-holders defined below.
If set, :transparent-image-converter is used instead of :image-converter to
convert an image when the background color is nil or \"Transparent\".
Place-holders used by `:image-converter' and `:latex-compiler':
%f input file name
%b base name of input file
%o base directory of input file
%O absolute output file name
Place-holders only used by `:image-converter':
%D dpi, which is used to adjust image size by some processing commands.
%S the image size scale ratio, which is used to adjust image size by some
processing commands."
:group 'org-latex
:package-version '(Org . "9.6")
:type '(alist :tag "LaTeX to image backends"
:value-type (plist)))
(defcustom org-preview-latex-image-directory "ltximg/"
"Path to store latex preview images.
A relative path here creates many directories relative to the
processed Org files paths. An absolute path puts all preview
images at the same place."
:group 'org-latex
:version "26.1"
:package-version '(Org . "9.0")
:type 'string)
(defun org-format-latex-mathml-available-p ()
"Return t if `org-latex-to-mathml-convert-command' is usable."
(save-match-data
(when (and (boundp 'org-latex-to-mathml-convert-command)
org-latex-to-mathml-convert-command)
(let ((executable (car (split-string
org-latex-to-mathml-convert-command))))
(when (executable-find executable)
(if (string-match
"%j" org-latex-to-mathml-convert-command)
(file-readable-p org-latex-to-mathml-jar-file)
t))))))
(defcustom org-format-latex-header "\\documentclass{article}
\\usepackage[usenames]{color}
\[DEFAULT-PACKAGES]
\[PACKAGES]
\\pagestyle{empty} % do not remove
% The settings below are copied from fullpage.sty
\\setlength{\\textwidth}{\\paperwidth}
\\addtolength{\\textwidth}{-3cm}
\\setlength{\\oddsidemargin}{1.5cm}
\\addtolength{\\oddsidemargin}{-2.54cm}
\\setlength{\\evensidemargin}{\\oddsidemargin}
\\setlength{\\textheight}{\\paperheight}
\\addtolength{\\textheight}{-\\headheight}
\\addtolength{\\textheight}{-\\headsep}
\\addtolength{\\textheight}{-\\footskip}
\\addtolength{\\textheight}{-3cm}
\\setlength{\\topmargin}{1.5cm}
\\addtolength{\\topmargin}{-2.54cm}"
"The document header used for processing LaTeX fragments.
It is imperative that this header make sure that no page number
appears on the page. The package defined in the variables
`org-latex-default-packages-alist' and `org-latex-packages-alist'
will either replace the placeholder \"[PACKAGES]\" in this
header, or they will be appended."
:group 'org-latex
:type 'string)
(defun org-set-packages-alist (var val)
"Set the packages alist and make sure it has 3 elements per entry."
(set-default-toplevel-value var (mapcar (lambda (x)
(if (and (consp x) (= (length x) 2))
(list (car x) (nth 1 x) t)
x))
val)))
(defun org-get-packages-alist (var)
"Get the packages alist and make sure it has 3 elements per entry."
(mapcar (lambda (x)
(if (and (consp x) (= (length x) 2))
(list (car x) (nth 1 x) t)
x))
(default-value var)))
(defcustom org-latex-default-packages-alist
'(;; amsmath before fontspec for lualatex and xetex
("" "amsmath" t ("lualatex" "xetex"))
;; fontspec ASAP for lualatex and xetex
("" "fontspec" t ("lualatex" "xetex"))
;; inputenc and fontenc are for pdflatex only
("AUTO" "inputenc" t ("pdflatex"))
("T1" "fontenc" t ("pdflatex"))
("" "graphicx" t)
("" "longtable" nil)
("" "wrapfig" nil)
("" "rotating" nil)
("normalem" "ulem" t)
;; amsmath and amssymb after inputenc/fontenc for pdflatex
("" "amsmath" t ("pdflatex"))
("" "amssymb" t ("pdflatex"))
("" "capt-of" nil)
("" "hyperref" nil))
"Alist of default packages to be inserted in the header.
Change this only if one of the packages here causes an
incompatibility with another package you are using.
The packages in this list are needed by one part or another of
Org mode to function properly:
- fontspec: for font and character selection in lualatex and xetex
- inputenc, fontenc: for basic font and character selection
in pdflatex
- graphicx: for including images
- longtable: For multipage tables
- wrapfig: for figure placement
- rotating: for sideways figures and tables
- ulem: for underline and strike-through
- amsmath: for subscript and superscript and math environments
- amssymb: for various symbols used for interpreting the entities
in `org-entities'. You can skip some of this package if you don't
use any of the symbols.
- capt-of: for captions outside of floats
- hyperref: for cross references
Therefore you should not modify this variable unless you know
what you are doing. The one reason to change it anyway is that
you might be loading some other package that conflicts with one
of the default packages. Each element is either a cell or
a string.
A cell is of the format
(\"options\" \"package\" SNIPPET-FLAG COMPILERS)
If SNIPPET-FLAG is non-nil, the package also needs to be included
when compiling LaTeX snippets into images for inclusion into
non-LaTeX output.
COMPILERS is a list of compilers that should include the package,
see `org-latex-compiler'. If the document compiler is not in the
list, and the list is non-nil, the package will not be inserted
in the final document.
A string will be inserted as-is in the header of the document."
:group 'org-latex
:group 'org-export-latex
:set 'org-set-packages-alist
:get 'org-get-packages-alist
:package-version '(Org . "9.7")
:type '(repeat
(choice
(list :tag "options/package pair"
(string :tag "options")
(string :tag "package")
(boolean :tag "Snippet")
(choice
(const :tag "For all compilers" nil)
(repeat :tag "Allowed compiler" string)))
(string :tag "A line of LaTeX"))))
(defcustom org-latex-packages-alist nil
"Alist of packages to be inserted in every LaTeX header.
These will be inserted after `org-latex-default-packages-alist'.
Each element is either a cell or a string.
A cell is of the format:
(\"options\" \"package\" SNIPPET-FLAG COMPILERS)
SNIPPET-FLAG, when non-nil, indicates that this package is also
needed when turning LaTeX snippets into images for inclusion into
non-LaTeX output.
COMPILERS is a list of compilers that should include the package,
see `org-latex-compiler'. If the document compiler is not in the
list, and the list is non-nil, the package will not be inserted
in the final document.
A string will be inserted as-is in the header of the document.
Make sure that you only list packages here which:
- you want in every file;
- do not conflict with the setup in `org-format-latex-header';
- do not conflict with the default packages in
`org-latex-default-packages-alist'."
:group 'org-latex
:group 'org-export-latex
:set 'org-set-packages-alist
:get 'org-get-packages-alist
:type
'(repeat
(choice
(list :tag "options/package pair"
(string :tag "options")
(string :tag "package")
(boolean :tag "snippet")
(choice
(const :tag "All compilers include this package" nil)
(repeat :tag "Only include from these compilers" string)))
(string :tag "A line of LaTeX"))))
(defgroup org-appearance nil
"Settings for Org mode appearance."
:tag "Org Appearance"
:group 'org)
(defcustom org-level-color-stars-only nil
"Non-nil means fontify only the stars in each headline.
When nil, the entire headline is fontified.
Changing it requires restart of `font-lock-mode' to become effective
also in regions already fontified."
:group 'org-appearance
:type 'boolean)
(defcustom org-hide-leading-stars nil
"Non-nil means hide the first N-1 stars in a headline.
This works by using the face `org-hide' for these stars. This
face is white for a light background, and black for a dark
background. You may have to customize the face `org-hide' to
make this work.
Changing it requires restart of `font-lock-mode' to become effective
also in regions already fontified.
You may also set this on a per-file basis by adding one of the following
lines to the buffer:
#+STARTUP: hidestars
#+STARTUP: showstars"
:group 'org-appearance
:type 'boolean)
(defcustom org-hidden-keywords nil
"List of symbols corresponding to keywords to be hidden in the Org buffer.
For example, a value (title) for this list makes the document's title
appear in the buffer without the initial \"#+TITLE:\" part."
:group 'org-appearance
:package-version '(Org . "9.5")
:type '(set (const :tag "#+AUTHOR" author)
(const :tag "#+DATE" date)
(const :tag "#+EMAIL" email)
(const :tag "#+SUBTITLE" subtitle)
(const :tag "#+TITLE" title)))
(defcustom org-custom-properties nil
"List of properties (as strings) with a special meaning.
The default use of these custom properties is to let the user
hide them with `org-toggle-custom-properties-visibility'."
:group 'org-properties
:group 'org-appearance
:version "24.3"
:type '(repeat (string :tag "Property Name")))
(defcustom org-fontify-todo-headline nil
"Non-nil means change the face of a headline if it is marked as TODO.
Normally, only the TODO/DONE keyword indicates the state of a headline.
When this is non-nil, the headline after the keyword is set to the
`org-headline-todo' as an additional indication."
:group 'org-appearance
:package-version '(Org . "9.4")
:type 'boolean
:safe #'booleanp)
(defcustom org-fontify-done-headline t
"Non-nil means change the face of a headline if it is marked DONE.
Normally, only the TODO/DONE keyword indicates the state of a headline.
When this is non-nil, the headline after the keyword is set to the
`org-headline-done' as an additional indication."
:group 'org-appearance
:package-version '(Org . "9.4")
:type 'boolean)
(defcustom org-fontify-emphasized-text t
"Non-nil means fontify *bold*, /italic/ and _underlined_ text.
Changing this variable requires a restart of Emacs to take effect."
:group 'org-appearance
:type 'boolean)
(defcustom org-fontify-whole-heading-line nil
"Non-nil means fontify the whole line for headings.
This is useful when setting a background color for the
org-level-* faces."
:group 'org-appearance
:type 'boolean)
(defcustom org-fontify-whole-block-delimiter-line t
"Non-nil means fontify the whole line for begin/end lines of blocks.
This is useful when setting a background color for the
org-block-begin-line and org-block-end-line faces."
:group 'org-appearance
:type 'boolean)
(defcustom org-highlight-latex-and-related nil
"Non-nil means highlight LaTeX related syntax in the buffer.
When non-nil, the value should be a list containing any of the
following symbols:
`native' Highlight LaTeX snippets and environments natively.
`latex' Highlight LaTeX snippets and environments.
`script' Highlight subscript and superscript.
`entities' Highlight entities."
:group 'org-appearance
:version "24.4"
:package-version '(Org . "8.0")
:type '(choice
(const :tag "No highlighting" nil)
(set :greedy t :tag "Highlight"
(const :tag "LaTeX snippets and environments (native)" native)
(const :tag "LaTeX snippets and environments" latex)
(const :tag "Subscript and superscript" script)
(const :tag "Entities" entities))))
(defcustom org-hide-emphasis-markers nil
"Non-nil means font-lock should hide the emphasis marker characters."
:group 'org-appearance
:type 'boolean
:safe #'booleanp)
(defcustom org-hide-macro-markers nil
"Non-nil means font-lock should hide the brackets marking macro calls."
:group 'org-appearance
:type 'boolean)
(defcustom org-pretty-entities nil
"Non-nil means show entities as UTF8 characters.
When nil, the \\name form remains in the buffer."
:group 'org-appearance
:version "24.1"
:type 'boolean)
(defcustom org-pretty-entities-include-sub-superscripts t
"Non-nil means pretty entity display includes formatting sub/superscripts."
:group 'org-appearance
:version "24.1"
:type 'boolean)
(defvar org-emph-re nil
"Regular expression for matching emphasis.
After a match, the match groups contain these elements:
0 The match of the full regular expression, including the characters
before and after the proper match
1 The character before the proper match, or empty at beginning of line
2 The proper match, including the leading and trailing markers
3 The leading marker like * or /, indicating the type of highlighting
4 The text between the emphasis markers, not including the markers
5 The character after the match, empty at the end of a line")
(defvar org-verbatim-re nil
"Regular expression for matching verbatim text.")
(defvar org-emphasis-regexp-components) ; defined just below
(defvar org-emphasis-alist) ; defined just below
(defun org-set-emph-re (var val)
"Set variable and compute the emphasis regular expression."
(set-default-toplevel-value var val)
(when (and (boundp 'org-emphasis-alist)
(boundp 'org-emphasis-regexp-components)
org-emphasis-alist org-emphasis-regexp-components)
(pcase-let*
((`(,pre ,post ,border ,body ,nl) org-emphasis-regexp-components)
(body (if (<= nl 0) body
(format "%s*?\\(?:\n%s*?\\)\\{0,%d\\}" body body nl)))
(template
(format (concat "\\([%s]\\|^\\)" ;before markers
"\\(\\([%%s]\\)\\([^%s]\\|[^%s]%s[^%s]\\)\\3\\)"
"\\([%s]\\|$\\)") ;after markers
pre border border body border post)))
(setq org-emph-re (format template "*/_+"))
(setq org-verbatim-re (format template "=~")))))
;; This used to be a defcustom (Org <8.0) but allowing the users to
;; set this option proved cumbersome. See this message/thread:
;; https://orgmode.org/list/B72CDC2B-72F6-43A8-AC70-E6E6295766EC@gmail.com
(defvar org-emphasis-regexp-components
'("-[:space:]('\"{" "-[:space:].,:!?;'\")}\\[" "[:space:]" "." 1)
"Components used to build the regular expression for emphasis.
This is a list with five entries. Terminology: In an emphasis string
like \" *strong word* \", we call the initial space PREMATCH, the final
space POSTMATCH, the stars MARKERS, \"s\" and \"d\" are BORDER characters
and \"trong wor\" is the body. The different components in this variable
specify what is allowed/forbidden in each part:
pre Chars allowed as prematch. Beginning of line will be allowed too.
post Chars allowed as postmatch. End of line will be allowed too.
border The chars *forbidden* as border characters.
body-regexp A regexp like \".\" to match a body character. Don't use
non-shy groups here, and don't allow newline here.
newline The maximum number of newlines allowed in an emphasis exp.
You need to reload Org or to restart Emacs after setting this.")
(defcustom org-emphasis-alist
'(("*" bold)
("/" italic)
("_" underline)
("=" org-verbatim verbatim)
("~" org-code verbatim)
("+" (:strike-through t)))
"Alist of characters and faces to emphasize text.
Text starting and ending with a special character will be emphasized,
for example *bold*, _underlined_ and /italic/. This variable sets the
face to be used by font-lock for highlighting in Org buffers.
Marker characters must be one of */_=~+.
You need to reload Org or to restart Emacs after customizing this."
:group 'org-appearance
:set 'org-set-emph-re
:version "24.4"
:package-version '(Org . "8.0")
:type '(repeat
(list
(choice
(const :tag "Bold" "*")
(const :tag "Italic" "/")
(const :tag "Underline" "_")
(const :tag "Verbatim" "=")
(const :tag "Code" "~")
(const :tag "Strike through" "+"))
(choice
(face :tag "Font-lock-face")
(plist :tag "Face property list"))
(option (const verbatim)))))
(defvar org-protecting-blocks '("src" "example" "export")
"Blocks that contain text that is quoted, i.e. not processed as Org syntax.
This is needed for font-lock setup.")
;;; Functions and variables from their packages
;; Declared here to avoid compiler warnings
(defvar mark-active)
;; Various packages
(declare-function calc-eval "calc" (str &optional separator &rest args))
(declare-function calendar-forward-day "cal-move" (arg))
(declare-function calendar-goto-date "cal-move" (date))
(declare-function calendar-goto-today "cal-move" ())
(declare-function calendar-iso-from-absolute "cal-iso" (date))
(declare-function calendar-iso-to-absolute "cal-iso" (date))
(declare-function cdlatex-compute-tables "ext:cdlatex" ())
(declare-function cdlatex-tab "ext:cdlatex" ())
(declare-function dired-get-filename
"dired"
(&optional localp no-error-if-not-filep))
(declare-function org-agenda-change-all-lines
"org-agenda"
(newhead hdmarker &optional fixface just-this))
(declare-function org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item
"org-agenda"
(&optional end))
(declare-function org-agenda-copy-local-variable "org-agenda" (var))
(declare-function org-agenda-format-item
"org-agenda"
(extra txt &optional level category tags dotime
remove-re habitp))
(declare-function org-agenda-new-marker "org-agenda" (&optional pos))
(declare-function org-agenda-save-markers-for-cut-and-paste
"org-agenda"
(beg end))
(declare-function org-agenda-set-restriction-lock "org-agenda" (&optional type))
(declare-function org-agenda-skip "org-agenda" (&optional element))
(declare-function org-attach-expand "org-attach" (file))
(declare-function org-attach-reveal "org-attach" ())
(declare-function org-attach-reveal-in-emacs "org-attach" ())
(declare-function org-gnus-follow-link "org-gnus" (&optional group article))
(declare-function org-indent-mode "org-indent" (&optional arg))
(declare-function org-inlinetask-goto-beginning "org-inlinetask" ())
(declare-function org-inlinetask-goto-end "org-inlinetask" ())
(declare-function org-inlinetask-in-task-p "org-inlinetask" ())
(declare-function org-inlinetask-remove-END-maybe "org-inlinetask" ())
(declare-function parse-time-string "parse-time" (string))
(defvar align-mode-rules-list)
(defvar calc-embedded-close-formula)
(defvar calc-embedded-open-formula)
(defvar calc-embedded-open-mode)
(defvar org-agenda-tags-todo-honor-ignore-options)
(defvar remember-data-file)
(defvar texmathp-why)
(declare-function org-clock-save-markers-for-cut-and-paste "org-clock" (beg end))
(declare-function org-clock-update-mode-line "org-clock" (&optional refresh))
(declare-function org-resolve-clocks "org-clock"
(&optional also-non-dangling-p prompt last-valid))
(defvar org-clock-start-time)
(defvar org-clock-marker (make-marker)
"Marker recording the last clock-in.")
(defvar org-clock-hd-marker (make-marker)
"Marker recording the last clock-in, but the headline position.")
(defvar org-clock-heading ""
"The heading of the current clock entry.")
(defun org-clocking-buffer ()
"Return the buffer where the clock is currently running.
Return nil if no clock is running."
(marker-buffer org-clock-marker))
(defalias 'org-clock-is-active #'org-clocking-buffer)
(defun org-check-running-clock ()
"Check if the current buffer contains the running clock.
If yes, offer to stop it and to save the buffer with the changes."
(when (and (equal (marker-buffer org-clock-marker) (current-buffer))
(y-or-n-p (format "Clock-out in buffer %s before killing it? "
(buffer-name))))
(org-clock-out)
(when (y-or-n-p "Save changed buffer?")
(save-buffer))))
(defun org-clocktable-try-shift (dir n)
"Check if this line starts a clock table, if yes, shift the time block."
(when (org-match-line "^[ \t]*#\\+BEGIN:[ \t]+clocktable\\>")
(org-clocktable-shift dir n)))
;;;###autoload
(defun org-clock-persistence-insinuate ()
"Set up hooks for clock persistence."
(require 'org-clock)
(add-hook 'org-mode-hook 'org-clock-load)
(add-hook 'kill-emacs-hook 'org-clock-save))
(defun org-clock-auto-clockout-insinuate ()
"Set up hook for auto clocking out when Emacs is idle.
See `org-clock-auto-clockout-timer'.
This function is meant to be added to the user configuration."
(require 'org-clock)
(add-hook 'org-clock-in-hook #'org-clock-auto-clockout t))
(defgroup org-archive nil
"Options concerning archiving in Org mode."
:tag "Org Archive"
:group 'org-structure)
(defcustom org-archive-location "%s_archive::"
"The location where subtrees should be archived.
The value of this variable is a string, consisting of two parts,
separated by a double-colon. The first part is a filename and
the second part is a headline.
When the filename is omitted, archiving happens in the same file.
%s in the filename will be replaced by the current file
name (without the directory part). Archiving to a different file
is useful to keep archived entries from contributing to the
Org Agenda.
The archived entries will be filed as subtrees of the specified
headline. When the headline is omitted, the subtrees are simply
filed away at the end of the file, as top-level entries. Also in
the heading you can use %s to represent the file name, this can be
useful when using the same archive for a number of different files.
Here are a few examples:
\"%s_archive::\"
If the current file is Projects.org, archive in file
Projects.org_archive, as top-level trees. This is the default.
\"::* Archived Tasks\"
Archive in the current file, under the top-level headline
\"* Archived Tasks\".
\"~/org/archive.org::\"
Archive in file ~/org/archive.org (absolute path), as top-level trees.
\"~/org/archive.org::* From %s\"
Archive in file ~/org/archive.org (absolute path), under headlines
\"From FILENAME\" where file name is the current file name.
\"~/org/datetree.org::datetree/* Finished Tasks\"
The \"datetree/\" string is special, signifying to archive
items to the datetree. Items are placed in either the CLOSED
date of the item, or the current date if there is no CLOSED date.
The heading will be a subentry to the current date. There doesn't
need to be a heading, but there always needs to be a slash after
datetree. For example, to store archived items directly in the
datetree, use \"~/org/datetree.org::datetree/\".
\"basement::** Finished Tasks\"
Archive in file ./basement (relative path), as level 3 trees
below the level 2 heading \"** Finished Tasks\".
You may define it locally by setting an ARCHIVE property. If
such a property is found in the file or in an entry, and anywhere
up the hierarchy, it will be used.
You can also set it for the whole file using the keyword-syntax:
#+ARCHIVE: basement::** Finished Tasks"
:group 'org-archive
:type 'string)
(defcustom org-agenda-skip-archived-trees t
"Non-nil means the agenda will skip any items located in archived trees.
An archived tree is a tree marked with the tag ARCHIVE. The use of this
variable is no longer recommended, you should leave it at the value t.
Instead, use the key `v' to cycle the archives-mode in the agenda."
:group 'org-archive
:group 'org-agenda-skip
:type 'boolean)
(defcustom org-columns-skip-archived-trees t
"Non-nil means ignore archived trees when creating column view."
:group 'org-archive
:group 'org-properties
:type 'boolean)
(defcustom org-sparse-tree-open-archived-trees nil
"Non-nil means sparse tree construction shows matches in archived trees.
When nil, matches in these trees are highlighted, but the trees are kept in
collapsed state."
:group 'org-archive
:group 'org-sparse-trees
:type 'boolean)
(defcustom org-sparse-tree-default-date-type nil
"The default date type when building a sparse tree.
When this is nil, a date is a scheduled or a deadline timestamp.
Otherwise, these types are allowed:
all: all timestamps
active: only active timestamps (<...>)
inactive: only inactive timestamps ([...])
scheduled: only scheduled timestamps
deadline: only deadline timestamps"
:type '(choice (const :tag "Scheduled or deadline" nil)
(const :tag "All timestamps" all)
(const :tag "Only active timestamps" active)
(const :tag "Only inactive timestamps" inactive)
(const :tag "Only scheduled timestamps" scheduled)
(const :tag "Only deadline timestamps" deadline)
(const :tag "Only closed timestamps" closed))
:version "26.1"
:package-version '(Org . "8.3")
:group 'org-sparse-trees)
(defalias 'org-advertized-archive-subtree 'org-archive-subtree)
;; Declare Column View Code
(declare-function org-columns-get-format-and-top-level "org-colview" ())
(declare-function org-columns-compute "org-colview" (property))
;; Declare ID code
(declare-function org-id-store-link "org-id")
(declare-function org-id-locations-load "org-id")
(declare-function org-id-locations-save "org-id")
(defvar org-id-track-globally)
;;; Variables for pre-computed regular expressions, all buffer local
(defvar-local org-todo-regexp nil
"Matches any of the TODO state keywords.
Since TODO keywords are case-sensitive, `case-fold-search' is
expected to be bound to nil when matching against this regexp.")
(defvar-local org-not-done-regexp nil
"Matches any of the TODO state keywords except the last one.
Since TODO keywords are case-sensitive, `case-fold-search' is
expected to be bound to nil when matching against this regexp.")
(defvar-local org-not-done-heading-regexp nil
"Matches a TODO headline that is not done.
Since TODO keywords are case-sensitive, `case-fold-search' is
expected to be bound to nil when matching against this regexp.")
(defvar-local org-todo-line-regexp nil
"Matches a headline and puts TODO state into group 2 if present.
Since TODO keywords are case-sensitive, `case-fold-search' is
expected to be bound to nil when matching against this regexp.")
(defvar-local org-complex-heading-regexp nil
"Matches a headline and puts everything into groups:
group 1: Stars
group 2: The TODO keyword, maybe
group 3: Priority cookie
group 4: True headline
group 5: Tags
Since TODO keywords are case-sensitive, `case-fold-search' is
expected to be bound to nil when matching against this regexp.")
(defvar-local org-complex-heading-regexp-format nil
"Printf format to make regexp to match an exact headline.
This regexp will match the headline of any node which has the
exact headline text that is put into the format, but may have any
TODO state, priority, tags, statistics cookies (at the beginning
or end of the headline title), or COMMENT keyword.")
(defvar-local org-todo-line-tags-regexp nil
"Matches a headline and puts TODO state into group 2 if present.
Also put tags into group 4 if tags are present.")
(defconst org-plain-time-of-day-regexp
(concat
"\\(\\<[012]?[0-9]"
"\\(\\(:\\([0-5][0-9]\\([AaPp][Mm]\\)?\\)\\)\\|\\([AaPp][Mm]\\)\\)\\>\\)"
"\\(--?"
"\\(\\<[012]?[0-9]"
"\\(\\(:\\([0-5][0-9]\\([AaPp][Mm]\\)?\\)\\)\\|\\([AaPp][Mm]\\)\\)\\>\\)"
"\\)?")
"Regular expression to match a plain time or time range.
Examples: 11:45 or 8am-13:15 or 2:45-2:45pm. After a match, the following
groups carry important information:
0 the full match
1 the first time, range or not
8 the second time, if it is a range.")
(defconst org-plain-time-extension-regexp
(concat
"\\(\\<[012]?[0-9]"
"\\(\\(:\\([0-5][0-9]\\([AaPp][Mm]\\)?\\)\\)\\|\\([AaPp][Mm]\\)\\)\\>\\)"
"\\+\\([0-9]+\\)\\(:\\([0-5][0-9]\\)\\)?")
"Regular expression to match a time range like 13:30+2:10 = 13:30-15:40.
Examples: 11:45 or 8am-13:15 or 2:45-2:45pm. After a match, the following
groups carry important information:
0 the full match
7 hours of duration
9 minutes of duration")
(defconst org-stamp-time-of-day-regexp
(concat
"<\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} +\\sw+ +\\)"
"\\([012][0-9]:[0-5][0-9]\\)\\(-\\([012][0-9]:[0-5][0-9]\\)\\)?[^\n\r>]*?>"
"\\(--?"
"<\\1\\([012][0-9]:[0-5][0-9]\\)>\\)?")
"Regular expression to match a timestamp time or time range.
After a match, the following groups carry important information:
0 the full match
1 date plus weekday, for back referencing to make sure
both times are on the same day
2 the first time, range or not
4 the second time, if it is a range.")
(defconst org-startup-options
'(("fold" org-startup-folded fold)
("overview" org-startup-folded overview)
("nofold" org-startup-folded nofold)
("showall" org-startup-folded showall)
("show2levels" org-startup-folded show2levels)
("show3levels" org-startup-folded show3levels)
("show4levels" org-startup-folded show4levels)
("show5levels" org-startup-folded show5levels)
("showeverything" org-startup-folded showeverything)
("content" org-startup-folded content)
("indent" org-startup-indented t)
("noindent" org-startup-indented nil)
("num" org-startup-numerated t)
("nonum" org-startup-numerated nil)
("hidestars" org-hide-leading-stars t)
("showstars" org-hide-leading-stars nil)
("odd" org-odd-levels-only t)
("oddeven" org-odd-levels-only nil)
("align" org-startup-align-all-tables t)
("noalign" org-startup-align-all-tables nil)
("shrink" org-startup-shrink-all-tables t)
("descriptivelinks" org-link-descriptive t)
("literallinks" org-link-descriptive nil)
("inlineimages" org-startup-with-inline-images t)
("noinlineimages" org-startup-with-inline-images nil)
("latexpreview" org-startup-with-latex-preview t)
("nolatexpreview" org-startup-with-latex-preview nil)
("customtime" org-display-custom-times t)
("logdone" org-log-done time)
("lognotedone" org-log-done note)
("nologdone" org-log-done nil)
("lognoteclock-out" org-log-note-clock-out t)
("nolognoteclock-out" org-log-note-clock-out nil)
("logrepeat" org-log-repeat state)
("lognoterepeat" org-log-repeat note)
("logdrawer" org-log-into-drawer t)
("nologdrawer" org-log-into-drawer nil)
("logstatesreversed" org-log-states-order-reversed t)
("nologstatesreversed" org-log-states-order-reversed nil)
("nologrepeat" org-log-repeat nil)
("logreschedule" org-log-reschedule time)
("lognotereschedule" org-log-reschedule note)
("nologreschedule" org-log-reschedule nil)
("logredeadline" org-log-redeadline time)
("lognoteredeadline" org-log-redeadline note)
("nologredeadline" org-log-redeadline nil)
("logrefile" org-log-refile time)
("lognoterefile" org-log-refile note)
("nologrefile" org-log-refile nil)
("fninline" org-footnote-define-inline t)
("nofninline" org-footnote-define-inline nil)
("fnlocal" org-footnote-section nil)
("fnauto" org-footnote-auto-label t)
("fnprompt" org-footnote-auto-label nil)
("fnconfirm" org-footnote-auto-label confirm)
("fnplain" org-footnote-auto-label plain)
("fnadjust" org-footnote-auto-adjust t)
("nofnadjust" org-footnote-auto-adjust nil)
("fnanon" org-footnote-auto-label anonymous)
("constcgs" constants-unit-system cgs)
("constSI" constants-unit-system SI)
("noptag" org-tag-persistent-alist nil)
("hideblocks" org-hide-block-startup t)
("nohideblocks" org-hide-block-startup nil)
("hidedrawers" org-hide-drawer-startup t)
("nohidedrawers" org-hide-drawer-startup nil)
("beamer" org-startup-with-beamer-mode t)
("entitiespretty" org-pretty-entities t)
("entitiesplain" org-pretty-entities nil))
"Variable associated with STARTUP options for Org.
Each element is a list of three items: the startup options (as written
in the #+STARTUP line), the corresponding variable, and the value to set
this variable to if the option is found. An optional fourth element PUSH
means to push this value onto the list in the variable.")
(defcustom org-group-tags t
"When non-nil (the default), use group tags.
This can be turned on/off through `org-toggle-tags-groups'."
:group 'org-tags
:group 'org-startup
:type 'boolean)
(defvar org-inhibit-startup nil) ; Dynamically-scoped param.
(defun org-toggle-tags-groups ()
"Toggle support for group tags.
Support for group tags is controlled by the option
`org-group-tags', which is non-nil by default."
(interactive)
(setq org-group-tags (not org-group-tags))
(cond ((and (derived-mode-p 'org-agenda-mode)
org-group-tags)
(org-agenda-redo))
((derived-mode-p 'org-mode)
(let ((org-inhibit-startup t)) (org-mode))))
(message "Groups tags support has been turned %s"
(if org-group-tags "on" "off")))
(defun org--tag-add-to-alist (alist1 alist2)
"Merge tags from ALIST1 into ALIST2.
Duplicates tags outside a group are removed. Keywords and order
are preserved.
The function assumes ALIST1 and ALIST2 are proper tag alists.
See `org-tag-alist' for their structure."
(cond
((null alist2) alist1)
((null alist1) alist2)
(t
(let ((to-add nil)
(group-flag nil))
(dolist (tag-pair alist1)
(pcase tag-pair
(`(,(or :startgrouptag :startgroup))
(setq group-flag t)
(push tag-pair to-add))
(`(,(or :endgrouptag :endgroup))
(setq group-flag nil)
(push tag-pair to-add))
(`(,(or :grouptags :newline))
(push tag-pair to-add))
(`(,tag . ,_)
;; Remove duplicates from ALIST1, unless they are in
;; a group. Indeed, it makes sense to have a tag appear in
;; multiple groups.
(when (or group-flag (not (assoc tag alist2)))
(push tag-pair to-add)))
(_ (error "Invalid association in tag alist: %S" tag-pair))))
;; Preserve order of ALIST1.
(append (nreverse to-add) alist2)))))
(defun org-priority-to-value (s)
"Convert priority string S to its numeric value."
(or (save-match-data
(and (string-match "\\([0-9]+\\)" s)
(string-to-number (match-string 1 s))))
(string-to-char s)))
(defun org-set-regexps-and-options (&optional tags-only)
"Precompute regular expressions used in the current buffer.
When optional argument TAGS-ONLY is non-nil, only compute tags
related expressions."
(when (derived-mode-p 'org-mode)
(let ((alist (org-collect-keywords
(append '("FILETAGS" "TAGS")
(and (not tags-only)
'("ARCHIVE" "CATEGORY" "COLUMNS" "CONSTANTS"
"LINK" "OPTIONS" "PRIORITIES" "PROPERTY"
"SEQ_TODO" "STARTUP" "TODO" "TYP_TODO")))
'("ARCHIVE" "CATEGORY" "COLUMNS" "PRIORITIES"))))
;; Startup options. Get this early since it does change
;; behavior for other options (e.g., tags).
(let ((startup (cl-mapcan (lambda (value) (split-string value))
(cdr (assoc "STARTUP" alist)))))
(dolist (option startup)
(pcase (assoc-string option org-startup-options t)
(`(,_ ,variable ,value t)
(unless (listp (symbol-value variable))
(set (make-local-variable variable) nil))
(add-to-list variable value))
(`(,_ ,variable ,value . ,_)
(set (make-local-variable variable) value))
(_ nil))))
(setq-local org-file-tags
(mapcar #'org-add-prop-inherited
(cl-mapcan (lambda (value)
(cl-mapcan
(lambda (k) (org-split-string k ":"))
(split-string value)))
(cdr (assoc "FILETAGS" alist)))))
(setq org-current-tag-alist
(org--tag-add-to-alist
org-tag-persistent-alist
(let ((tags (cdr (assoc "TAGS" alist))))
(if tags
(org-tag-string-to-alist
(mapconcat #'identity tags "\n"))
org-tag-alist))))
(setq org-tag-groups-alist
(org-tag-alist-to-groups org-current-tag-alist))
(unless tags-only
;; Properties.
(let ((properties nil))
(dolist (value (cdr (assoc "PROPERTY" alist)))
(when (string-match "\\(\\S-+\\)[ \t]+\\(.*\\)" value)
(setq properties (org--update-property-plist
(match-string-no-properties 1 value)
(match-string-no-properties 2 value)
properties))))
(setq-local org-keyword-properties properties))
;; Archive location.
(let ((archive (cdr (assoc "ARCHIVE" alist))))
(when archive (setq-local org-archive-location archive)))
;; Category.
(let ((category (cdr (assoc "CATEGORY" alist))))
(when category
(setq-local org-category (intern category))
(setq-local org-keyword-properties
(org--update-property-plist
"CATEGORY" category org-keyword-properties))))
;; Columns.
(let ((column (cdr (assoc "COLUMNS" alist))))
(when column (setq-local org-columns-default-format column)))
;; Constants.
(let ((store nil))
(dolist (pair (cl-mapcan #'split-string
(cdr (assoc "CONSTANTS" alist))))
(when (string-match "^\\([a-zA-Z0][_a-zA-Z0-9]*\\)=\\(.*\\)" pair)
(let* ((name (match-string 1 pair))
(value (match-string 2 pair))
(old (assoc name store)))
(if old (setcdr old value)
(push (cons name value) store)))))
(setq org-table-formula-constants-local store))
;; Link abbreviations.
(let ((links
(delq nil
(mapcar
(lambda (value)
(and (or
;; "abbrev with spaces" spec
(string-match "\\`\"\\(.+[^\\]\\)\"[ \t]+\\(.+\\)" value)
;; abbrev spec
(string-match "\\`\\(\\S-+\\)[ \t]+\\(.+\\)" value))
(cons (match-string-no-properties 1 value)
(match-string-no-properties 2 value))))
(cdr (assoc "LINK" alist))))))
(when links (setq org-link-abbrev-alist-local (nreverse links))))
;; Priorities.
(let ((value (cdr (assoc "PRIORITIES" alist))))
(pcase (and value (split-string value))
(`(,high ,low ,default . ,_)
(setq-local org-priority-highest (org-priority-to-value high))
(setq-local org-priority-lowest (org-priority-to-value low))
(setq-local org-priority-default (org-priority-to-value default)))))
;; Scripts.
(let ((value (cdr (assoc "OPTIONS" alist))))
(dolist (option value)
(when (string-match "\\^:\\(t\\|nil\\|{}\\)" option)
(setq-local org-use-sub-superscripts
(read (match-string 1 option))))))
;; TODO keywords.
(setq-local org-todo-kwd-alist nil)
(setq-local org-todo-key-alist nil)
(setq-local org-todo-key-trigger nil)
(setq-local org-todo-keywords-1 nil)
(setq-local org-done-keywords nil)
(setq-local org-todo-heads nil)
(setq-local org-todo-sets nil)
(setq-local org-todo-log-states nil)
(let ((todo-sequences
(or (append (mapcar (lambda (value)
(cons 'type (split-string value)))
(cdr (assoc "TYP_TODO" alist)))
(mapcar (lambda (value)
(cons 'sequence (split-string value)))
(append (cdr (assoc "TODO" alist))
(cdr (assoc "SEQ_TODO" alist)))))
(let ((d (default-value 'org-todo-keywords)))
(if (not (stringp (car d))) d
;; XXX: Backward compatibility code.
(list (cons org-todo-interpretation d)))))))
(dolist (sequence todo-sequences)
(let* ((sequence (or (run-hook-with-args-until-success
'org-todo-setup-filter-hook sequence)
sequence))
(sequence-type (car sequence))
(keywords (cdr sequence))
(sep (member "|" keywords))
names alist)
(dolist (k (remove "|" keywords))
(unless (string-match "^\\(.*?\\)\\(?:(\\([^!@/]\\)?.*?)\\)?$"
k)
(error "Invalid TODO keyword %s" k))
(let ((name (match-string 1 k))
(key (match-string 2 k))
(log (org-extract-log-state-settings k)))
(push name names)
(push (cons name (and key (string-to-char key))) alist)
(when log (push log org-todo-log-states))))
(let* ((names (nreverse names))
(done (if sep (org-remove-keyword-keys (cdr sep))
(last names)))
(head (car names))
(tail (list sequence-type head (car done) (org-last done))))
(add-to-list 'org-todo-heads head 'append)
(push names org-todo-sets)
(setq org-done-keywords (append org-done-keywords done nil))
(setq org-todo-keywords-1 (append org-todo-keywords-1 names nil))
(setq org-todo-key-alist
(append org-todo-key-alist
(and alist
(append '((:startgroup))
(nreverse alist)
'((:endgroup))))))
(dolist (k names) (push (cons k tail) org-todo-kwd-alist))))))
(setq org-todo-sets (nreverse org-todo-sets)
org-todo-kwd-alist (nreverse org-todo-kwd-alist)
org-todo-key-trigger (delq nil (mapcar #'cdr org-todo-key-alist))
org-todo-key-alist (org-assign-fast-keys org-todo-key-alist))
;; Compute the regular expressions and other local variables.
;; Using `org-outline-regexp-bol' would complicate them much,
;; because of the fixed white space at the end of that string.
(unless org-done-keywords
(setq org-done-keywords
(and org-todo-keywords-1 (last org-todo-keywords-1))))
(setq org-not-done-keywords
(org-delete-all org-done-keywords
(copy-sequence org-todo-keywords-1))
org-todo-regexp (regexp-opt org-todo-keywords-1 t)
org-not-done-regexp (regexp-opt org-not-done-keywords t)
org-not-done-heading-regexp
(format org-heading-keyword-regexp-format org-not-done-regexp)
org-todo-line-regexp
(format org-heading-keyword-maybe-regexp-format org-todo-regexp)
org-complex-heading-regexp
(concat "^\\(\\*+\\)"
"\\(?: +" org-todo-regexp "\\)?"
"\\(?: +\\(\\[#.\\]\\)\\)?"
"\\(?: +\\(.*?\\)\\)??"
"\\(?:[ \t]+\\(:[[:alnum:]_@#%:]+:\\)\\)?"
"[ \t]*$")
org-complex-heading-regexp-format
(concat "^\\(\\*+\\)"
"\\(?: +" org-todo-regexp "\\)?"
"\\(?: +\\(\\[#.\\]\\)\\)?"
"\\(?: +"
;; Headline might be commented
"\\(?:" org-comment-string " +\\)?"
;; Stats cookies can be stuck to body.
"\\(?:\\[[0-9%%/]+\\] *\\)*"
"\\(%s\\)"
"\\(?: *\\[[0-9%%/]+\\]\\)*"
"\\)"
"\\(?:[ \t]+\\(:[[:alnum:]_@#%%:]+:\\)\\)?"
"[ \t]*$")
org-todo-line-tags-regexp
(concat "^\\(\\*+\\)"
"\\(?: +" org-todo-regexp "\\)?"
"\\(?: +\\(.*?\\)\\)??"
"\\(?:[ \t]+\\(:[[:alnum:]:_@#%]+:\\)\\)?"
"[ \t]*$"))
(org-compute-latex-and-related-regexp)))))
(defun org-collect-keywords (keywords &optional unique directory)
"Return values for KEYWORDS in current buffer, as an alist.
KEYWORDS is a list of strings. Return value is a list of
elements with the pattern:
(NAME . LIST-OF-VALUES)
where NAME is the upcase name of the keyword, and LIST-OF-VALUES
is a list of non-empty values, as strings, in order of appearance
in the buffer.
When KEYWORD appears in UNIQUE list, LIST-OF-VALUE is its first
value, empty or not, appearing in the buffer, as a string.
When KEYWORD appears in DIRECTORIES, each value is a cons cell:
(VALUE . DIRECTORY)
where VALUE is the regular value, and DIRECTORY is the variable
`default-directory' for the buffer containing the keyword. This
is important for values containing relative file names, since the
function follows SETUPFILE keywords, and may change its working
directory."
(let* ((keywords (cons "SETUPFILE" (mapcar #'upcase keywords)))
(unique (mapcar #'upcase unique))
(alist (org--collect-keywords-1
keywords unique directory
(and buffer-file-name (list buffer-file-name))
nil)))
;; Re-order results.
(dolist (entry alist)
(pcase entry
(`(,_ . ,(and value (pred consp)))
(setcdr entry (nreverse value)))))
(nreverse alist)))
(defun org--collect-keywords-1 (keywords unique directory files alist)
(org-with-point-at 1
(let ((case-fold-search t)
(regexp (org-make-options-regexp keywords)))
(while (and keywords (re-search-forward regexp nil t))
(let ((element (org-element-at-point)))
(when (org-element-type-p element 'keyword)
(let ((value (org-element-property :value element)))
(pcase (org-element-property :key element)
("SETUPFILE"
(when (org-string-nw-p value)
(let* ((uri (org-strip-quotes value))
(uri-is-url (org-url-p uri))
(uri (if uri-is-url
uri
;; In case of error, be safe.
;; See bug#68976.
(ignore-errors ; return nil when expansion fails.
(expand-file-name uri)))))
(unless (or (not uri) (member uri files))
(with-temp-buffer
(unless uri-is-url
(setq default-directory (file-name-directory uri)))
(let ((contents (org-file-contents uri :noerror)))
(when contents
(insert contents)
;; Fake Org mode: `org-element-at-point'
;; doesn't need full set-up.
(let ((major-mode 'org-mode))
(setq-local tab-width 8)
(setq alist
(org--collect-keywords-1
keywords unique directory
(cons uri files)
alist))))))))))
(keyword
(let ((entry (assoc keyword alist))
(final
(cond ((not (member keyword directory)) value)
(buffer-file-name
(cons value
(file-name-directory buffer-file-name)))
(t (cons value default-directory)))))
(cond ((member keyword unique)
(push (cons keyword final) alist)
(setq keywords (remove keyword keywords))
(setq regexp (org-make-options-regexp keywords)))
((null entry) (push (list keyword final) alist))
(t (push final (cdr entry)))))))))))
alist)))
(defun org-tag-string-to-alist (s)
"Return tag alist associated to string S.
S is a value for TAGS keyword or produced with
`org-tag-alist-to-string'. Return value is an alist suitable for
`org-tag-alist' or `org-tag-persistent-alist'."
(let ((lines (mapcar #'split-string (split-string s "\n" t)))
(tag-re (concat "\\`\\(" org-tag-re "\\|{.+?}\\)" ; regular expression
"\\(?:(\\(.\\))\\)?\\'"))
alist group-flag)
(dolist (tokens lines (cdr (nreverse alist)))
(push '(:newline) alist)
(while tokens
(let ((token (pop tokens)))
(pcase token
("{"
(push '(:startgroup) alist)
(when (equal (nth 1 tokens) ":") (setq group-flag t)))
("}"
(push '(:endgroup) alist)
(setq group-flag nil))
("["
(push '(:startgrouptag) alist)
(when (equal (nth 1 tokens) ":") (setq group-flag t)))
("]"
(push '(:endgrouptag) alist)
(setq group-flag nil))
(":"
(push '(:grouptags) alist))
((guard (string-match tag-re token))
(let ((tag (match-string 1 token))
(key (and (match-beginning 2)
(string-to-char (match-string 2 token)))))
;; Push all tags in groups, no matter if they already
;; appear somewhere else in the list.
(when (or group-flag (not (assoc tag alist)))
(push (cons tag key) alist))))))))))
(defun org-tag-alist-to-string (alist &optional skip-key)
"Return tag string associated to ALIST.
ALIST is an alist, as defined in `org-tag-alist' or
`org-tag-persistent-alist', or produced with
`org-tag-string-to-alist'.
Return value is a string suitable as a value for \"TAGS\"
keyword.
When optional argument SKIP-KEY is non-nil, skip selection keys
next to tags."
(mapconcat (lambda (token)
(pcase token
(`(:startgroup) "{")
(`(:endgroup) "}")
(`(:startgrouptag) "[")
(`(:endgrouptag) "]")
(`(:grouptags) ":")
(`(:newline) "\\n")
((and
(guard (not skip-key))
`(,(and tag (pred stringp)) . ,(and key (pred characterp))))
(format "%s(%c)" tag key))
(`(,(and tag (pred stringp)) . ,_) tag)
(_ (user-error "Invalid tag token: %S" token))))
alist
" "))
(defun org-tag-alist-to-groups (alist)
"Return group alist from tag ALIST.
ALIST is an alist, as defined in `org-tag-alist' or
`org-tag-persistent-alist', or produced with
`org-tag-string-to-alist'. Return value is an alist following
the pattern (GROUP-TAG TAGS) where GROUP-TAG is the tag, as
a string, summarizing TAGS, as a list of strings."
(let (groups group-status current-group)
(dolist (token alist (nreverse groups))
(pcase token
(`(,(or :startgroup :startgrouptag)) (setq group-status t))
(`(,(or :endgroup :endgrouptag))
(when (eq group-status 'append)
(push (nreverse current-group) groups))
(setq group-status nil current-group nil))
(`(:grouptags) (setq group-status 'append))
((and `(,tag . ,_) (guard group-status))
(if (eq group-status 'append) (push tag current-group)
(setq current-group (list tag))))
(_ nil)))))
(defvar org--file-cache (make-hash-table :test #'equal)
"Hash table to store contents of files referenced via a URL.
This is the cache of file URLs read using `org-file-contents'.")
(defun org-reset-file-cache ()
"Reset the cache of files downloaded by `org-file-contents'."
(clrhash org--file-cache))
(defun org-file-contents (file &optional noerror nocache)
"Return the contents of FILE, as a string.
FILE can be a file name or URL.
If FILE is a URL, download the contents. If the URL contents are
already cached in the `org--file-cache' hash table, the download step
is skipped.
If NOERROR is non-nil, ignore the error when unable to read the FILE
from file or URL, and return nil.
If NOCACHE is non-nil, do a fresh fetch of FILE even if cached version
is available. This option applies only if FILE is a URL."
(let* ((is-url (org-url-p file))
(is-remote (condition-case nil
(file-remote-p file)
;; In case of error, be safe.
;; See bug#68976.
(t t)))
(cache (and is-url
(not nocache)
(gethash file org--file-cache))))
(cond
(cache)
((or is-url is-remote)
(if (org--should-fetch-remote-resource-p file)
(condition-case error
(with-current-buffer (url-retrieve-synchronously file)
(goto-char (point-min))
;; Move point to after the url-retrieve header.
(search-forward "\n\n" nil :move)
;; Search for the success code only in the url-retrieve header.
(if (save-excursion
(re-search-backward "HTTP.*\\s-+200\\s-OK" nil :noerror))
;; Update the cache `org--file-cache' and return contents.
(puthash file
(buffer-substring-no-properties (point) (point-max))
org--file-cache)
(funcall (if noerror #'message #'user-error)
"Unable to fetch file from %S"
file)
nil))
(error (if noerror
(message "Org couldn't download \"%s\": %s %S" file (car error) (cdr error))
(signal (car error) (cdr error)))))
(funcall (if noerror #'message #'user-error)
"The remote resource %S is considered unsafe, and will not be downloaded."
file)))
(t
(with-temp-buffer
(condition-case nil
(progn
(insert-file-contents file)
(buffer-string))
(file-error
(funcall (if noerror #'message #'user-error)
"Unable to read file %S"
file)
nil)))))))
(defun org--should-fetch-remote-resource-p (uri)
"Return non-nil if the URI should be fetched."
(or (eq org-resource-download-policy t)
(org--safe-remote-resource-p uri)
(and (eq org-resource-download-policy 'prompt)
(org--confirm-resource-safe uri))))
(defun org--safe-remote-resource-p (uri)
"Return non-nil if URI is considered safe.
This checks every pattern in `org-safe-remote-resources', and
returns non-nil if any of them match."
(let ((uri-patterns org-safe-remote-resources)
(file-uri (and (buffer-file-name (buffer-base-buffer))
(concat "file://" (file-truename (buffer-file-name (buffer-base-buffer))))))
match-p)
(while (and (not match-p) uri-patterns)
(setq match-p (or (string-match-p (car uri-patterns) uri)
(and file-uri (string-match-p (car uri-patterns) file-uri)))
uri-patterns (cdr uri-patterns)))
match-p))
(defun org--confirm-resource-safe (uri)
"Ask the user if URI should be considered safe, returning non-nil if so."
(unless noninteractive
(let ((current-file (and (buffer-file-name (buffer-base-buffer))
(file-truename (buffer-file-name (buffer-base-buffer)))))
(domain (and (string-match
(rx (seq "http" (? "s") "://")
(optional (+ (not (any "@/\n"))) "@")
(optional "www.")
(one-or-more (not (any ":/?\n"))))
uri)
(match-string 0 uri)))
(buf (get-buffer-create "*Org Remote Resource*")))
;; Set up the contents of the *Org Remote Resource* buffer.
(with-current-buffer buf
(erase-buffer)
(insert "An org-mode document would like to download "
(propertize uri 'face '(:inherit org-link :weight normal))
", which is not considered safe.\n\n"
"Do you want to download this? You can type\n "
(propertize "!" 'face 'success)
" to download this resource, and permanently mark it as safe.\n "
(if domain
(concat
(propertize "d" 'face 'success)
" to download this resource, and mark the domain ("
(propertize domain 'face '(:inherit org-link :weight normal))
") as safe.\n ")
"")
(if current-file
(concat
(propertize "f" 'face 'success)
" to download this resource, and permanently mark all resources in "
(propertize current-file 'face 'underline)
" as safe.\n ")
"")
(propertize "y" 'face 'warning)
" to download this resource, just this once.\n "
(propertize "n" 'face 'error)
" to skip this resource.\n")
(setq-local cursor-type nil)
(set-buffer-modified-p nil)
(goto-char (point-min)))
;; Display the buffer and read a choice.
(save-window-excursion
(pop-to-buffer buf)
(let* ((exit-chars (append '(?y ?n ?! ?d ?\s) (and current-file '(?f))))
(prompt (format "Please type y, n%s, d, or !%s: "
(if current-file ", f" "")
(if (< (line-number-at-pos (point-max))
(window-body-height))
""
", or C-v/M-v to scroll")))
char)
(setq char (read-char-choice prompt exit-chars))
(when (memq char '(?! ?f ?d))
(customize-push-and-save
'org-safe-remote-resources
(list (if (eq char ?d)
(concat "\\`" (regexp-quote domain) "\\(?:/\\|\\'\\)")
(concat "\\`"
(regexp-quote
(if (and (= char ?f) current-file)
(concat "file://" current-file) uri))
"\\'")))))
(prog1 (memq char '(?y ?! ?d ?\s ?f))
(quit-window t)))))))
(defun org-extract-log-state-settings (x)
"Extract the log state setting from a TODO keyword string.
This will extract info from a string like \"WAIT(w@/!)\"."
(when (string-match "^\\(.*?\\)\\(?:(\\([^!@/]\\)?\\([!@]\\)?\\(?:/\\([!@]\\)\\)?)\\)?$" x)
(let ((kw (match-string 1 x))
(log1 (and (match-end 3) (match-string 3 x)))
(log2 (and (match-end 4) (match-string 4 x))))
(and (or log1 log2)
(list kw
(and log1 (if (equal log1 "!") 'time 'note))
(and log2 (if (equal log2 "!") 'time 'note)))))))
(defun org-remove-keyword-keys (list)
"Remove a pair of parenthesis at the end of each string in LIST."
(mapcar (lambda (x)
(if (string-match "(.*)$" x)
(substring x 0 (match-beginning 0))
x))
list))
(defun org-assign-fast-keys (alist)
"Assign fast keys to a keyword-key alist.
Respect keys that are already there."
(let (new e (alt ?0))
(while (setq e (pop alist))
(if (or (memq (car e) '(:newline :grouptags :endgroup :startgroup))
(cdr e)) ;; Key already assigned.
(push e new)
(let ((clist (string-to-list (downcase (car e))))
(used (append new alist)))
(when (= (car clist) ?@)
(pop clist))
(while (and clist (rassoc (car clist) used))
(pop clist))
(unless clist
(while (rassoc alt used)
(cl-incf alt)))
(push (cons (car e) (or (car clist) alt)) new))))
(nreverse new)))
;;; Some variables used in various places
(defvar org-window-configuration nil
"Used in various places to store a window configuration.")
(defvar org-selected-window nil
"Used in various places to store a window configuration.")
(defvar org-finish-function nil
"Function to be called when \\`C-c C-c' is used.
This is for getting out of special buffers like capture.")
(defvar org-last-state)
;; Defined somewhere in this file, but used before definition.
(defvar org-entities) ;; defined in org-entities.el
(defvar org-struct-menu)
(defvar org-org-menu)
(defvar org-tbl-menu)
;;;; Define the Org mode
(defun org-before-change-function (_beg _end)
"Every change indicates that a table might need an update."
(setq org-table-may-need-update t))
(defvar org-mode-map)
(defvar org-inhibit-startup-visibility-stuff nil) ; Dynamically-scoped param.
(defvar org-agenda-keep-modes nil) ; Dynamically-scoped param.
(defvar org-inhibit-logging nil) ; Dynamically-scoped param.
(defvar org-inhibit-blocking nil) ; Dynamically-scoped param.
(defvar bidi-paragraph-direction)
(defvar buffer-face-mode-face)
(require 'outline)
;; Other stuff we need.
(require 'time-date)
(when (< emacs-major-version 28) ; preloaded in Emacs 28
(require 'easymenu))
(require 'org-entities)
(require 'org-faces)
(require 'org-list)
(require 'org-pcomplete)
(require 'org-src)
(require 'org-footnote)
(require 'org-macro)
;; babel
(require 'ob)
(defvar org-element-cache-version); Defined in org-element.el
(defvar org-element-cache-persistent); Defined in org-element.el
(defvar org-element-use-cache); Defined in org-element.el
(defvar org-mode-loading nil
"Non-nil during Org mode initialization.")
(defvar org-agenda-file-menu-enabled t
"When non-nil, refresh Agenda files in Org menu when loading Org.")
(defvar org-mode-syntax-table
(let ((st (make-syntax-table outline-mode-syntax-table)))
(modify-syntax-entry ?\" "\"" st)
(modify-syntax-entry ?\\ "_" st)
(modify-syntax-entry ?~ "_" st)
(modify-syntax-entry ?< "(>" st)
(modify-syntax-entry ?> ")<" st)
st)
"Standard syntax table for Org mode buffers.")
(defvar org-mode-tags-syntax-table
(let ((st (make-syntax-table org-mode-syntax-table)))
(modify-syntax-entry ?@ "w" st)
(modify-syntax-entry ?_ "w" st)
st)
"Syntax table including \"@\" and \"_\" as word constituents.")
(defun org--set-tab-width (&rest _)
"Set `tab-width' to be 8."
(setq-local tab-width 8))
;;;###autoload
(define-derived-mode org-mode outline-mode "Org"
"Outline-based notes management and organizer, alias
\"Carsten's outline-mode for keeping track of everything.\"
Org mode develops organizational tasks around a NOTES file which
contains information about projects as plain text. Org mode is
implemented on top of Outline mode, which is ideal to keep the content
of large files well structured. It supports ToDo items, deadlines and
time stamps, which magically appear in the diary listing of the Emacs
calendar. Tables are easily created with a built-in table editor.
Plain text URL-like links connect to websites, emails (VM), Usenet
messages (Gnus), BBDB entries, and any files related to the project.
For printing and sharing of notes, an Org file (or a part of it)
can be exported as a structured ASCII or HTML file.
The following commands are available:
\\{org-mode-map}"
(setq-local org-mode-loading t)
;; Force tab width - indentation is significant in lists, so we need
;; to make sure that it is consistent across configurations.
(org--set-tab-width)
;; Really force it, even if dir-locals or file-locals set it - we
;; need tab-width = 8 as a part of Org syntax.
(add-hook 'hack-local-variables-hook
#'org--set-tab-width 90 'local)
;; In Emacs <30, editorconfig-mode uses advices, so we cannot rely
;; upon `hack-local-variables-hook' to run after editorconfig
;; tab-width settings are applied.
(add-hook 'editorconfig-after-apply-functions
#'org--set-tab-width 90 'local)
(org-load-modules-maybe)
(when org-agenda-file-menu-enabled
(org-install-agenda-files-menu))
(setq-local outline-regexp org-outline-regexp)
(setq-local outline-level 'org-outline-level)
;; Initialize cache.
(org-element-cache-reset)
(when (and org-element-cache-persistent
org-element-use-cache)
(org-persist-load
`((elisp org-element--cache) (version ,org-element-cache-version))
(current-buffer)
'match-hash :read-related t))
(org-set-regexps-and-options)
(add-to-invisibility-spec '(org-link))
(org-fold-initialize (or (and (stringp org-ellipsis) (not (equal "" org-ellipsis)) org-ellipsis)
"..."))
(make-local-variable 'org-link-descriptive)
(when (eq org-fold-core-style 'overlays) (add-to-invisibility-spec '(org-hide-block . t)))
(when (and (stringp org-ellipsis) (not (equal "" org-ellipsis)))
(unless org-display-table
(setq org-display-table (make-display-table)))
(set-display-table-slot
org-display-table 4
(vconcat (mapcar (lambda (c) (make-glyph-code c 'org-ellipsis))
org-ellipsis)))
(setq buffer-display-table org-display-table))
(org-set-font-lock-defaults)
(when (and org-tag-faces (not org-tags-special-faces-re))
;; tag faces set outside customize.... force initialization.
(org-set-tag-faces 'org-tag-faces org-tag-faces))
;; Calc embedded
(setq-local calc-embedded-open-mode "# ")
;; Set syntax table. Ensure that buffer-local changes to the syntax
;; table do not affect other Org buffers.
(set-syntax-table (make-syntax-table org-mode-syntax-table))
(setq-local font-lock-unfontify-region-function 'org-unfontify-region)
;; Activate before-change-function
(setq-local org-table-may-need-update t)
(add-hook 'before-change-functions 'org-before-change-function nil 'local)
;; Check for running clock before killing a buffer
(add-hook 'kill-buffer-hook 'org-check-running-clock nil 'local)
;; Check for invisible edits.
(org-fold--advice-edit-commands)
;; Initialize macros templates.
(org-macro-initialize-templates)
;; Initialize radio targets.
(org-update-radio-target-regexp)
;; Indentation.
(setq-local indent-line-function 'org-indent-line)
(setq-local indent-region-function 'org-indent-region)
;; Filling and auto-filling.
(org-setup-filling)
;; Comments.
(org-setup-comments-handling)
;; Beginning/end of defun
(setq-local beginning-of-defun-function 'org-backward-element)
(setq-local end-of-defun-function
(lambda ()
(if (not (org-at-heading-p))
(org-forward-element)
(org-forward-element)
(forward-char -1))))
;; Next error for sparse trees
(setq-local next-error-function 'org-occur-next-match)
;; Make commit log messages from Org documents easier.
(setq-local add-log-current-defun-function #'org-add-log-current-headline)
;; Make sure dependence stuff works reliably, even for users who set it
;; too late :-(
(if org-enforce-todo-dependencies
(add-hook 'org-blocker-hook
'org-block-todo-from-children-or-siblings-or-parent)
(remove-hook 'org-blocker-hook
'org-block-todo-from-children-or-siblings-or-parent))
(if org-enforce-todo-checkbox-dependencies
(add-hook 'org-blocker-hook
'org-block-todo-from-checkboxes)
(remove-hook 'org-blocker-hook
'org-block-todo-from-checkboxes))
;; Align options lines
(setq-local
align-mode-rules-list
'((org-in-buffer-settings
(regexp . "^[ \t]*#\\+[A-Z_]+:\\(\\s-*\\)\\S-+")
(modes . '(org-mode)))))
;; Setup the pcomplete hooks
(setq-local pcomplete-command-completion-function #'org-pcomplete-initial)
(setq-local pcomplete-command-name-function #'org-command-at-point)
(setq-local pcomplete-default-completion-function #'ignore)
(setq-local pcomplete-parse-arguments-function #'org-parse-arguments)
(setq-local pcomplete-termination-string "")
(add-hook 'completion-at-point-functions
#'pcomplete-completions-at-point nil t)
(setq-local buffer-face-mode-face 'org-default)
;; `thing-at-point' support
(when (boundp 'thing-at-point-provider-alist)
(setq-local thing-at-point-provider-alist
(cons '(url . org--link-at-point)
thing-at-point-provider-alist)))
(when (boundp 'forward-thing-provider-alist)
(setq-local forward-thing-provider-alist
(cons '(url . org-next-link)
forward-thing-provider-alist)))
(when (boundp 'bounds-of-thing-at-point-provider-alist)
(setq-local bounds-of-thing-at-point-provider-alist
(cons '(url . org--bounds-of-link-at-point)
bounds-of-thing-at-point-provider-alist)))
;; If empty file that did not turn on Org mode automatically, make
;; it to.
(when (and org-insert-mode-line-in-empty-file
(called-interactively-p 'any)
(= (point-min) (point-max)))
(insert "# -*- mode: org -*-\n\n"))
(unless org-inhibit-startup
(when (or org-startup-align-all-tables org-startup-shrink-all-tables)
(org-table-map-tables
(cond ((and org-startup-align-all-tables
org-startup-shrink-all-tables)
(lambda () (org-table-align) (org-table-shrink)))
(org-startup-align-all-tables #'org-table-align)
(t #'org-table-shrink))
t))
;; Suppress modification hooks to speed up the startup.
;; However, do it only when text properties/overlays, but not
;; buffer text are actually modified. We still need to track text
;; modifications to make cache updates work reliably.
(org-unmodified
(when org-startup-with-beamer-mode (org-beamer-mode))
(when org-startup-with-inline-images (org-display-inline-images))
(when org-startup-with-latex-preview (org-latex-preview '(16)))
(unless org-inhibit-startup-visibility-stuff (org-cycle-set-startup-visibility))
(when org-startup-truncated (setq truncate-lines t))
(when org-startup-numerated (require 'org-num) (org-num-mode 1))
(when org-startup-indented (require 'org-indent) (org-indent-mode 1))))
;; Add a custom keymap for `visual-line-mode' so that activating
;; this minor mode does not override Org's keybindings.
;; FIXME: Probably `visual-line-mode' should take care of this.
(let ((oldmap (cdr (assoc 'visual-line-mode minor-mode-map-alist)))
(newmap (make-sparse-keymap)))
(set-keymap-parent newmap oldmap)
(define-key newmap [remap move-beginning-of-line] nil)
(define-key newmap [remap move-end-of-line] nil)
(define-key newmap [remap kill-line] nil)
(make-local-variable 'minor-mode-overriding-map-alist)
(push `(visual-line-mode . ,newmap) minor-mode-overriding-map-alist))
;; Activate `org-table-header-line-mode'
(when org-table-header-line-p
(org-table-header-line-mode 1))
;; Try to set `org-hide' face correctly.
(let ((foreground (org-find-invisible-foreground)))
(when foreground
(set-face-foreground 'org-hide foreground)))
;; Set face extension as requested.
(org--set-faces-extend '(org-block-begin-line org-block-end-line)
org-fontify-whole-block-delimiter-line)
(org--set-faces-extend org-level-faces org-fontify-whole-heading-line)
(setq-local org-mode-loading nil)
;; `yank-media' handler and DND support.
(org-setup-yank-dnd-handlers))
;; Update `customize-package-emacs-version-alist'
(add-to-list 'customize-package-emacs-version-alist
'(Org ("8.0" . "24.4")
("8.1" . "24.4")
("8.2" . "24.4")
("8.2.7" . "24.4")
("8.3" . "26.1")
("9.0" . "26.1")
("9.1" . "26.1")
("9.2" . "27.1")
("9.3" . "27.1")
("9.4" . "27.2")
("9.5" . "28.1")
("9.6" . "29.1")
("9.7" . "30.1")))
(defvar org-mode-transpose-word-syntax-table
(let ((st (make-syntax-table text-mode-syntax-table)))
(dolist (c org-emphasis-alist st)
(modify-syntax-entry (string-to-char (car c)) "w p" st))))
(when (fboundp 'abbrev-table-put)
(abbrev-table-put org-mode-abbrev-table
:parents (list text-mode-abbrev-table)))
(defun org-find-invisible-foreground ()
(let ((candidates (remove
"unspecified-bg"
(nconc
(list (face-background 'default)
(face-background 'org-default))
(mapcar
(lambda (alist)
(when (boundp alist)
(cdr (assq 'background-color (symbol-value alist)))))
'(default-frame-alist initial-frame-alist window-system-default-frame-alist))
(list (face-foreground 'org-hide))))))
(car (remove nil candidates))))
(defun org-current-time (&optional rounding-minutes past)
"Current time, possibly rounded to ROUNDING-MINUTES.
When ROUNDING-MINUTES is not an integer, fall back on the car of
`org-timestamp-rounding-minutes'. When PAST is non-nil, ensure
the rounding returns a past time."
(let ((r (or (and (integerp rounding-minutes) rounding-minutes)
(car org-timestamp-rounding-minutes)))
(now (current-time)))
(if (< r 1)
now
(let* ((time (decode-time now))
(res (org-encode-time
(apply #'list
0 (* r (round (nth 1 time) r))
(nthcdr 2 time)))))
(if (or (not past) (time-less-p res now))
res
(time-subtract res (* r 60)))))))
(defun org-today ()
"Return today date, considering `org-extend-today-until'."
(time-to-days
(time-since (* 3600 org-extend-today-until))))
;;;; Font-Lock stuff, including the activators
(defconst org-match-sexp-depth 3
"Number of stacked braces for sub/superscript matching.")
(defun org-create-multibrace-regexp (left right n)
"Create a regular expression which will match a balanced sexp.
Opening delimiter is LEFT, and closing delimiter is RIGHT, both given
as single character strings.
The regexp returned will match the entire expression including the
delimiters. It will also define a single group which contains the
match except for the outermost delimiters. The maximum depth of
stacked delimiters is N. Escaping delimiters is not possible."
(let* ((nothing (concat "[^" left right "]*?"))
(or "\\|")
(re nothing)
(next (concat "\\(?:" nothing left nothing right "\\)+" nothing)))
(while (> n 1)
(setq n (1- n)
re (concat re or next)
next (concat "\\(?:" nothing left next right "\\)+" nothing)))
(concat left "\\(" re "\\)" right)))
(defconst org-match-substring-regexp
(concat
"\\(\\S-\\)\\([_^]\\)\\("
"\\(?:" (org-create-multibrace-regexp "{" "}" org-match-sexp-depth) "\\)"
"\\|"
"\\(?:" (org-create-multibrace-regexp "(" ")" org-match-sexp-depth) "\\)"
"\\|"
"\\(?:\\*\\|[+-]?[[:alnum:].,\\]*[[:alnum:]]\\)\\)")
"The regular expression matching a sub- or superscript.")
(defconst org-match-substring-with-braces-regexp
(concat
"\\(\\S-\\)\\([_^]\\)"
"\\(" (org-create-multibrace-regexp "{" "}" org-match-sexp-depth) "\\)")
"The regular expression matching a sub- or superscript, forcing braces.")
(defvar org-emph-face nil)
(defconst org-nonsticky-props
'(mouse-face highlight keymap invisible intangible help-echo org-linked-text htmlize-link))
(defsubst org-rear-nonsticky-at (pos)
(add-text-properties (1- pos) pos (list 'rear-nonsticky org-nonsticky-props)))
(defun org-do-emphasis-faces (limit)
"Run through the buffer and emphasize strings."
(let ((quick-re (format "\\([%s]\\|^\\)\\([~=*/_+]\\)"
(car org-emphasis-regexp-components))))
(catch :exit
(while (re-search-forward quick-re limit t)
(let* ((marker (match-string 2))
(verbatim? (member marker '("~" "="))))
(when (save-excursion
(goto-char (match-beginning 0))
(and
;; Do not match table hlines.
(not (and (equal marker "+")
(org-match-line
"[ \t]*\\(|[-+]+|?\\|\\+[-+]+\\+\\)[ \t]*$")))
;; Do not match headline stars. Do not consider
;; stars of a headline as closing marker for bold
;; markup either.
(not (and (equal marker "*")
(save-excursion
(forward-char)
(skip-chars-backward "*")
(looking-at-p org-outline-regexp-bol))))
;; Match full emphasis markup regexp.
(looking-at (if verbatim? org-verbatim-re org-emph-re))
;; Do not span over paragraph boundaries.
(not (string-match-p org-element-paragraph-separate
(match-string 2)))
;; Do not span over cells in table rows.
(not (and (save-match-data (org-match-line "[ \t]*|"))
(string-match-p "|" (match-string 4))))))
(pcase-let ((`(,_ ,face ,_) (assoc marker org-emphasis-alist))
(m (if org-hide-emphasis-markers 4 2)))
(font-lock-prepend-text-property
(match-beginning m) (match-end m) 'face face)
(when verbatim?
(org-remove-flyspell-overlays-in
(match-beginning 0) (match-end 0))
(remove-text-properties (match-beginning 2) (match-end 2)
'(display t invisible t intangible t)))
(add-text-properties (match-beginning 2) (match-end 2)
'(font-lock-multiline t org-emphasis t))
(when (and org-hide-emphasis-markers
(not (org-at-comment-p)))
(add-text-properties (match-end 4) (match-beginning 5)
'(invisible t))
;; https://orgmode.org/list/8b691a7f-6b62-d573-e5a8-80fac3dc9bc6@vodafonemail.de
(org-rear-nonsticky-at (match-beginning 5))
(add-text-properties (match-beginning 3) (match-end 3)
'(invisible t))
;; FIXME: This would break current behavior with point
;; being adjusted before hidden emphasis marker when
;; using M-b. A proper fix would require custom
;; syntax function that will mark emphasis markers as
;; word constituents where appropriate.
;; https://orgmode.org/list/87edl41jf0.fsf@localhost
;; (org-rear-nonsticky-at (match-end 3))
)
(throw :exit t))))))))
(defun org-emphasize (&optional char)
"Insert or change an emphasis, i.e. a font like bold or italic.
If there is an active region, change that region to a new emphasis.
If there is no region, just insert the marker characters and position
the cursor between them.
CHAR should be the marker character. If it is a space, it means to
remove the emphasis of the selected region.
If CHAR is not given (for example in an interactive call) it will be
prompted for."
(interactive)
(let ((erc org-emphasis-regexp-components)
(string "") beg end move s)
(if (org-region-active-p)
(setq beg (region-beginning)
end (region-end)
string (buffer-substring beg end))
(setq move t))
(unless char
(message "Emphasis marker or tag: [%s]"
(mapconcat #'car org-emphasis-alist ""))
(setq char (read-char-exclusive)))
(if (equal char ?\s)
(setq s ""
move nil)
(unless (assoc (char-to-string char) org-emphasis-alist)
(user-error "No such emphasis marker: \"%c\"" char))
(setq s (char-to-string char)))
(while (and (> (length string) 1)
(equal (substring string 0 1) (substring string -1))
(assoc (substring string 0 1) org-emphasis-alist))
(setq string (substring string 1 -1)))
(setq string (concat s string s))
(when beg (delete-region beg end))
(unless (or (bolp)
(string-match (concat "[" (nth 0 erc) "\n]")
(char-to-string (char-before (point)))))
(insert " "))
(unless (or (eobp)
(string-match (concat "[" (nth 1 erc) "\n]")
(char-to-string (char-after (point)))))
(insert " ") (backward-char 1))
(insert string)
(and move (backward-char 1))))
(defun org-activate-links (limit)
"Add link properties to links.
This includes angle, plain, and bracket links."
(catch :exit
(while (re-search-forward org-link-any-re limit t)
(let* ((start (match-beginning 0))
(end (match-end 0))
(visible-start (or (match-beginning 3) (match-beginning 2)))
(visible-end (or (match-end 3) (match-end 2)))
(style (cond ((eq ?< (char-after start)) 'angle)
((eq ?\[ (char-after (1+ start))) 'bracket)
(t 'plain))))
(when (and (memq style org-highlight-links)
;; Do not span over paragraph boundaries.
(not (string-match-p org-element-paragraph-separate
(match-string 0)))
;; Do not confuse plain links with tags.
(not (and (eq style 'plain)
(let ((face (get-text-property
(max (1- start) (point-min)) 'face)))
(if (consp face) (memq 'org-tag face)
(eq 'org-tag face))))))
(let* ((link-object (save-excursion
(goto-char start)
(save-match-data (org-element-link-parser))))
(link (org-element-property :raw-link link-object))
(type (org-element-property :type link-object))
(path (org-element-property :path link-object))
(face-property (pcase (org-link-get-parameter type :face)
((and (pred functionp) face) (funcall face path))
((and (pred facep) face) face)
((and (pred consp) face) face) ;anonymous
(_ 'org-link)))
(properties ;for link's visible part
(list 'mouse-face (or (org-link-get-parameter type :mouse-face)
'highlight)
'keymap (or (org-link-get-parameter type :keymap)
org-mouse-map)
'help-echo (pcase (org-link-get-parameter type :help-echo)
((and (pred stringp) echo) echo)
((and (pred functionp) echo) echo)
(_ (concat "LINK: " link)))
'htmlize-link (pcase (org-link-get-parameter type
:htmlize-link)
((and (pred functionp) f) (funcall f))
(_ `(:uri ,link)))
'font-lock-multiline t)))
(org-remove-flyspell-overlays-in start end)
(org-rear-nonsticky-at end)
(if (not (eq 'bracket style))
(progn
(add-face-text-property start end face-property)
(add-text-properties start end properties))
;; Handle invisible parts in bracket links.
(remove-text-properties start end '(invisible nil))
(let ((hidden
(if org-link-descriptive
(append `(invisible
,(or (org-link-get-parameter type :display)
'org-link))
properties)
properties)))
(add-text-properties start visible-start hidden)
(add-face-text-property start end face-property)
(add-text-properties visible-start visible-end properties)
(add-text-properties visible-end end hidden)
(org-rear-nonsticky-at visible-start)
(org-rear-nonsticky-at visible-end)))
(let ((f (org-link-get-parameter type :activate-func)))
(when (functionp f)
(funcall f start end path (eq style 'bracket))))
(throw :exit t))))) ;signal success
nil))
(defun org-activate-code (limit)
(when (re-search-forward "^[ \t]*\\(:\\(?: .*\\|$\\)\n?\\)" limit t)
(org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0))
(remove-text-properties (match-beginning 0) (match-end 0)
'(display t invisible t intangible t))
t))
(defcustom org-src-fontify-natively t
"When non-nil, fontify code in code blocks.
See also the `org-block' face."
:type 'boolean
:version "26.1"
:package-version '(Org . "8.3")
:group 'org-appearance
:group 'org-babel)
(defcustom org-allow-promoting-top-level-subtree nil
"When non-nil, allow promoting a top level subtree.
The leading star of the top level headline will be replaced
by a #."
:type 'boolean
:version "24.1"
:group 'org-appearance)
(defun org-fontify-meta-lines-and-blocks (limit)
(condition-case-unless-debug nil
(org-fontify-meta-lines-and-blocks-1 limit)
(error (message "Org mode fontification error in %S at %d"
(current-buffer)
(line-number-at-pos)))))
(defun org-fontify-meta-lines-and-blocks-1 (limit)
"Fontify #+ lines and blocks."
(let ((case-fold-search t))
(when (re-search-forward
(rx bol (group (zero-or-more (any " \t")) "#"
(group (group (or (seq "+" (one-or-more (any "a-zA-Z")) (optional ":"))
(any " \t")
eol))
(optional (group "_" (group (one-or-more (any "a-zA-Z"))))))
(zero-or-more (any " \t"))
(group (group (zero-or-more (not (any " \t\n"))))
(zero-or-more (any " \t"))
(group (zero-or-more nonl)))))
limit t)
(let ((beg (match-beginning 0))
(end-of-beginline (match-end 0))
;; Including \n at end of #+begin line will include \n
;; after the end of block content.
(block-start (match-end 0))
(block-end nil)
(lang (match-string 7)) ; The language, if it is a source block.
(bol-after-beginline (line-beginning-position 2))
(dc1 (downcase (match-string 2)))
(dc3 (downcase (match-string 3)))
(whole-blockline org-fontify-whole-block-delimiter-line)
beg-of-endline end-of-endline nl-before-endline quoting block-type)
(cond
((and (match-end 4) (equal dc3 "+begin"))
;; Truly a block
(setq block-type (downcase (match-string 5))
;; Src, example, export, maybe more.
quoting (member block-type org-protecting-blocks))
(when (re-search-forward
(rx-to-string `(group bol (or (seq (one-or-more "*") space)
(seq (zero-or-more (any " \t"))
"#+end"
,(match-string 4)
word-end
(zero-or-more nonl)))))
;; We look further than LIMIT on purpose.
nil t)
;; We do have a matching #+end line.
(setq beg-of-endline (match-beginning 0)
end-of-endline (match-end 0)
nl-before-endline (1- (match-beginning 0)))
(setq block-end (match-beginning 0)) ; Include the final newline.
(when quoting
(org-remove-flyspell-overlays-in bol-after-beginline nl-before-endline)
(remove-text-properties beg end-of-endline
'(display t invisible t intangible t)))
(add-text-properties
beg end-of-endline '(font-lock-fontified t font-lock-multiline t))
(org-remove-flyspell-overlays-in beg bol-after-beginline)
(org-remove-flyspell-overlays-in nl-before-endline end-of-endline)
(cond
((and org-src-fontify-natively
;; Technically, according to the
;; `org-src-fontify-natively' docstring, we should
;; only fontify src blocks. However, it is common
;; to use undocumented fontification of export and
;; example blocks. (The latter which do not support a
;; language specifier.) Keep this undocumented feature
;; for user convenience.
(member block-type '("src" "export" "example")))
(save-match-data
(org-src-font-lock-fontify-block (or lang "") block-start block-end))
(add-text-properties bol-after-beginline block-end '(src-block t)))
(quoting
(add-text-properties
bol-after-beginline beg-of-endline
(list 'face
(list :inherit
(let ((face-name
(intern (format "org-block-%s" lang))))
(append (and (facep face-name) (list face-name))
'(org-block)))))))
((not org-fontify-quote-and-verse-blocks))
((string= block-type "quote")
(add-face-text-property
bol-after-beginline beg-of-endline 'org-quote t))
((string= block-type "verse")
(add-face-text-property
bol-after-beginline beg-of-endline 'org-verse t)))
;; Fontify the #+begin and #+end lines of the blocks
(add-text-properties
beg (if whole-blockline bol-after-beginline end-of-beginline)
'(face org-block-begin-line))
(unless (eq (char-after beg-of-endline) ?*)
(add-text-properties
beg-of-endline
(if whole-blockline
(let ((beg-of-next-line (1+ end-of-endline)))
(min (point-max) beg-of-next-line))
(min (point-max) end-of-endline))
'(face org-block-end-line)))
t))
((member dc1 '("+title:" "+subtitle:" "+author:" "+email:" "+date:"))
(org-remove-flyspell-overlays-in
(match-beginning 0)
(if (equal "+title:" dc1) (match-end 2) (match-end 0)))
(add-text-properties
beg (match-end 3)
(if (member (intern (substring dc1 1 -1)) org-hidden-keywords)
'(font-lock-fontified t invisible t)
'(font-lock-fontified t face org-document-info-keyword)))
(add-text-properties
(match-beginning 6) (min (point-max) (1+ (match-end 6)))
(if (string-equal dc1 "+title:")
'(font-lock-fontified t face org-document-title)
'(font-lock-fontified t face org-document-info))))
((string-prefix-p "+caption" dc1)
(org-remove-flyspell-overlays-in (match-end 2) (match-end 0))
(remove-text-properties (match-beginning 0) (match-end 0)
'(display t invisible t intangible t))
;; Handle short captions
(save-excursion
(forward-line 0)
(looking-at (rx (group (zero-or-more (any " \t"))
"#+caption"
(optional "[" (zero-or-more nonl) "]")
":")
(zero-or-more (any " \t")))))
(add-text-properties (line-beginning-position) (match-end 1)
'(font-lock-fontified t face org-meta-line))
(add-text-properties (match-end 0) (line-end-position)
'(font-lock-fontified t face org-block))
t)
((member dc3 '(" " ""))
;; Just a comment, the plus was not there
(org-remove-flyspell-overlays-in beg (match-end 0))
(add-text-properties
beg (match-end 0)
'(font-lock-fontified t face font-lock-comment-face)))
(t ;; Just any other in-buffer setting, but not indented
(org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0))
(remove-text-properties (match-beginning 0) (match-end 0)
'(display t invisible t intangible t))
(add-text-properties beg (match-end 0)
'(font-lock-fontified t face org-meta-line))
t))))))
(defun org-fontify-drawers (limit)
"Fontify drawers."
(when (re-search-forward org-drawer-regexp limit t)
(add-text-properties (1- (match-beginning 1)) (1+ (match-end 1))
'(font-lock-fontified t face org-drawer))
(org-remove-flyspell-overlays-in
(line-beginning-position) (line-beginning-position 2))
t))
(defun org-fontify-macros (limit)
"Fontify macros."
(when (re-search-forward "{{{\\([a-zA-Z][-a-zA-Z0-9_]*\\)" limit t)
(let ((begin (match-beginning 0))
(opening-end (match-beginning 1)))
(when (and (re-search-forward "\n[ \t]*\n\\|\\(}}}\\)" limit t)
(match-string 1))
(let ((end (match-end 1))
(closing-start (match-beginning 1)))
(add-face-text-property begin end 'org-macro)
(add-text-properties
begin end
'(font-lock-multiline t font-lock-fontified t))
(org-remove-flyspell-overlays-in begin end)
(when org-hide-macro-markers
(add-text-properties begin opening-end '(invisible t))
(add-text-properties closing-start end '(invisible t)))
t)))))
(defun org-fontify-extend-region (beg end _old-len)
(let ((end (if (progn (goto-char end) (looking-at-p "^[*#]"))
(min (point-max) (1+ end))
;; See `font-lock-extend-jit-lock-region-after-change' and bug#68849.
(min (point-max) (1+ end))))
(begin-re "\\(\\\\\\[\\|\\(#\\+begin_\\|\\\\begin{\\)\\S-+\\)")
(end-re "\\(\\\\\\]\\|\\(#\\+end_\\|\\\\end{\\)\\S-+\\)")
(extend
(lambda (r1 r2 dir)
(let ((re (replace-regexp-in-string
"\\(begin\\|end\\)" r1
(replace-regexp-in-string
"[][]" r2
(match-string-no-properties 0)))))
(re-search-forward (regexp-quote re) nil t dir)))))
(goto-char beg)
(back-to-indentation)
(save-match-data
(cond ((looking-at end-re)
(cons (or (funcall extend "begin" "[" -1) beg) end))
((looking-at begin-re)
(cons beg (or (funcall extend "end" "]" 1) end)))
(t (cons beg end))))))
(defun org-activate-footnote-links (limit)
"Add text properties for footnotes."
(let ((fn (org-footnote-next-reference-or-definition limit)))
(when fn
(let* ((beg (nth 1 fn))
(end (nth 2 fn))
(label (car fn))
(referencep (/= (line-beginning-position) beg)))
(when (and referencep (nth 3 fn))
(save-excursion
(goto-char beg)
(search-forward (or label "fn:"))
(org-remove-flyspell-overlays-in beg (match-end 0))))
(add-face-text-property beg end 'org-footnote)
(add-text-properties beg end
(list 'mouse-face 'highlight
'keymap org-mouse-map
'help-echo
(if referencep "Footnote reference"
"Footnote definition")
'font-lock-fontified t
'font-lock-multiline t))))))
(defun org-activate-dates (limit)
"Add text properties for dates."
(when (and (re-search-forward org-tsr-regexp-both limit t)
(not (equal (char-before (match-beginning 0)) 91)))
(org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0))
(add-text-properties (match-beginning 0) (match-end 0)
(list 'mouse-face 'highlight
'keymap org-mouse-map))
(org-rear-nonsticky-at (match-end 0))
(when org-display-custom-times
;; If it's a date range, activate custom time for second date.
(when (match-end 3)
(org-display-custom-time (match-beginning 3) (match-end 3)))
(org-display-custom-time (match-beginning 1) (match-end 1)))
t))
(defun org-activate-target-links (limit)
"Add text properties for target matches."
(when org-target-link-regexp
(let ((case-fold-search t))
;; `org-target-link-regexp' matches one character before the
;; actual target.
(unless (bolp) (forward-char -1))
(when (if org-target-link-regexps
(org--re-list-search-forward org-target-link-regexps limit t)
(re-search-forward org-target-link-regexp limit t))
(org-remove-flyspell-overlays-in (match-beginning 1) (match-end 1))
(add-text-properties (match-beginning 1) (match-end 1)
(list 'mouse-face 'highlight
'keymap org-mouse-map
'help-echo "Radio target link"
'org-linked-text t))
(org-rear-nonsticky-at (match-end 1))
t))))
(defvar org-latex-and-related-regexp nil
"Regular expression for highlighting LaTeX, entities and sub/superscript.")
(defun org-compute-latex-and-related-regexp ()
"Compute regular expression for LaTeX, entities and sub/superscript.
Result depends on variable `org-highlight-latex-and-related'."
(let ((re-sub
(cond ((not (memq 'script org-highlight-latex-and-related)) nil)
((eq org-use-sub-superscripts '{})
(list org-match-substring-with-braces-regexp))
(org-use-sub-superscripts (list org-match-substring-regexp))))
(re-latex
(when (or (memq 'latex org-highlight-latex-and-related)
(memq 'native org-highlight-latex-and-related))
(let ((matchers (plist-get org-format-latex-options :matchers)))
(delq nil
(mapcar (lambda (x)
(and (member (car x) matchers) (nth 1 x)))
org-latex-regexps)))))
(re-entities
(when (memq 'entities org-highlight-latex-and-related)
(list "\\\\\\(there4\\|sup[123]\\|frac[13][24]\\|[a-zA-Z]+\\)\
\\($\\|{}\\|[^[:alpha:]]\\)"))))
(setq-local org-latex-and-related-regexp
(mapconcat #'identity
(append re-latex re-entities re-sub)
"\\|"))))
(defun org-do-latex-and-related (limit)
"Highlight LaTeX snippets and environments, entities and sub/superscript.
Stop at first highlighted object, if any. Return t if some
highlighting was done, nil otherwise."
(when (org-string-nw-p org-latex-and-related-regexp)
(let ((latex-prefix-re (rx (or "$" "\\(" "\\[")))
(blank-line-re (rx (and "\n" (zero-or-more (or " " "\t")) "\n"))))
(catch 'found
(while (and (< (point) limit)
(re-search-forward org-latex-and-related-regexp nil t))
(cond
((>= (match-beginning 0) limit)
(throw 'found nil))
((cl-some (lambda (f)
(memq f '(org-code org-verbatim underline
org-special-keyword)))
(save-excursion
(goto-char (1+ (match-beginning 0)))
(face-at-point nil t))))
;; Try to limit false positives. In this case, ignore
;; $$...$$, \(...\), and \[...\] LaTeX constructs if they
;; contain an empty line.
((save-excursion
(goto-char (match-beginning 0))
(and (looking-at-p latex-prefix-re)
(save-match-data
(re-search-forward blank-line-re (1- (match-end 0)) t)))))
(t
(let* ((offset (if (memq (char-after (1+ (match-beginning 0)))
'(?_ ?^))
1
0))
(start (+ offset (match-beginning 0)))
(end (match-end 0)))
(if (memq 'native org-highlight-latex-and-related)
(org-src-font-lock-fontify-block "latex" start end)
(font-lock-prepend-text-property start end
'face 'org-latex-and-related))
(add-text-properties (+ offset (match-beginning 0)) (match-end 0)
'(font-lock-multiline t))
(throw 'found t)))))
nil))))
(defun org-restart-font-lock ()
"Restart `font-lock-mode', to force refontification."
(when font-lock-mode
(font-lock-mode -1)
(font-lock-mode 1)))
(defun org-activate-tags (limit)
(when (re-search-forward org-tag-line-re limit t)
(org-remove-flyspell-overlays-in (match-beginning 1) (match-end 1))
(add-text-properties (match-beginning 1) (match-end 1)
(list 'mouse-face 'highlight
'keymap org-mouse-map))
(org-rear-nonsticky-at (match-end 1))
t))
(defun org-activate-folds (limit)
"Arrange trailing newlines after folds to inherit face before the fold."
(let ((next-unfolded-newline (search-forward "\n" limit 'move)))
(while (and next-unfolded-newline (org-fold-folded-p) (not (eobp)))
(goto-char (org-fold-core-next-visibility-change nil limit))
(setq next-unfolded-newline (search-forward "\n" limit 'move)))
(when next-unfolded-newline
(org-with-wide-buffer
(when (and (> (match-beginning 0) (point-min))
(org-fold-folded-p (1- (match-beginning 0))))
(put-text-property
(match-beginning 0) (match-end 0)
'face
(get-text-property
(org-fold-previous-visibility-change
(1- (match-beginning 0)))
'face)))
t))))
(defun org-outline-level ()
"Compute the outline level of the heading at point.
If this is called at a normal headline, the level is the number
of stars. Use `org-reduced-level' to remove the effect of
`org-odd-levels-only'. Unlike `org-current-level', this function
takes into consideration inlinetasks."
(org-with-wide-buffer
(end-of-line)
(if (re-search-backward org-outline-regexp-bol nil t)
(1- (- (match-end 0) (match-beginning 0)))
0)))
(defvar org-font-lock-keywords nil)
(defsubst org-re-property (property &optional literal allow-null value)
"Return a regexp matching a PROPERTY line.
When optional argument LITERAL is non-nil, do not quote PROPERTY.
This is useful when PROPERTY is a regexp. When ALLOW-NULL is
non-nil, match properties even without a value.
Match group 3 is set to the value when it exists. If there is no
value and ALLOW-NULL is non-nil, it is set to the empty string.
With optional argument VALUE, match only property lines with
that value; in this case, ALLOW-NULL is ignored. VALUE is quoted
unless LITERAL is non-nil."
(concat
"^\\(?4:[ \t]*\\)"
(format "\\(?1::\\(?2:%s\\):\\)"
(if literal property (regexp-quote property)))
(cond (value
(format "[ \t]+\\(?3:%s\\)\\(?5:[ \t]*\\)$"
(if literal value (regexp-quote value))))
(allow-null
"\\(?:\\(?3:$\\)\\|[ \t]+\\(?3:.*?\\)\\)\\(?5:[ \t]*\\)$")
(t
"[ \t]+\\(?3:[^ \r\t\n]+.*?\\)\\(?5:[ \t]*\\)$"))))
(defconst org-property-re
(org-re-property "\\S-+" 'literal t)
"Regular expression matching a property line.
There are four matching groups:
1: :PROPKEY: including the leading and trailing colon,
2: PROPKEY without the leading and trailing colon,
3: PROPVAL without leading or trailing spaces,
4: the indentation of the current line,
5: trailing whitespace.")
(defvar org-font-lock-hook nil
"Functions to be called for special font lock stuff.")
(defvar org-font-lock-extra-keywords nil) ;Dynamically scoped.
(defvar org-font-lock-set-keywords-hook nil
"Functions that can manipulate `org-font-lock-extra-keywords'.
This is called after `org-font-lock-extra-keywords' is defined, but before
it is installed to be used by font lock. This can be useful if something
needs to be inserted at a specific position in the font-lock sequence.")
(defun org-font-lock-hook (limit)
"Run `org-font-lock-hook' within LIMIT."
(run-hook-with-args 'org-font-lock-hook limit))
(defun org-set-font-lock-defaults ()
"Set font lock defaults for the current buffer."
(let ((org-font-lock-extra-keywords
;; As a general rule, we apply the element (container) faces
;; first and then prepend the object faces on top.
(list
;; Call the hook
'(org-font-lock-hook)
;; Headlines
`(,(if org-fontify-whole-heading-line
"^\\(\\**\\)\\(\\* \\)\\(.*\n?\\)"
"^\\(\\**\\)\\(\\* \\)\\(.*\\)")
(1 (org-get-level-face 1))
(2 (org-get-level-face 2))
(3 (org-get-level-face 3)))
;; Table lines
'("^[ \t]*\\(\\(|\\|\\+-[-+]\\).*\\S-\\)\n?"
(0 'org-table-row t)
(1 'org-table t))
;; Table internals
'("^[ \t]*|\\(?:.*?|\\)? *\\(:?=[^|\n]*\\)" (1 'org-formula t))
'("^[ \t]*| *\\([#*]\\) *|" (1 'org-formula t))
'("^[ \t]*|\\( *\\([$!_^/]\\) *|.*\\)|" (1 'org-formula t))
'("| *\\(<[lrc]?[0-9]*>\\)" (1 'org-formula t))
;; Properties
(list org-property-re
'(1 'org-special-keyword t)
'(3 'org-property-value t))
;; Drawer boundaries.
'(org-fontify-drawers)
;; Diary sexps.
'("^&?%%(.*\\|<%%([^>\n]*?>" (0 'org-sexp-date t))
;; Link related fontification.
'(org-activate-links) ; `org-activate-links' prepends faces
(when (memq 'tag org-highlight-links) '(org-activate-tags (1 'org-tag prepend)))
(when (memq 'radio org-highlight-links) '(org-activate-target-links (1 'org-link prepend)))
(when (memq 'date org-highlight-links) '(org-activate-dates (0 'org-date prepend)))
;; `org-activate-footnote-links' prepends faces
(when (memq 'footnote org-highlight-links) '(org-activate-footnote-links))
;; Targets.
(list org-radio-target-regexp '(0 'org-target prepend))
(list org-target-regexp '(0 'org-target prepend))
;; Macro
'(org-fontify-macros) ; `org-fontify-macro' pepends faces
;; TODO keyword
(list (format org-heading-keyword-regexp-format
org-todo-regexp)
'(2 (org-get-todo-face 2) prepend))
;; TODO
(when org-fontify-todo-headline
(list (format org-heading-keyword-regexp-format
(concat
"\\(?:"
(mapconcat 'regexp-quote org-not-done-keywords "\\|")
"\\)"))
'(2 'org-headline-todo prepend)))
;; DONE
(when org-fontify-done-headline
(list (format org-heading-keyword-regexp-format
(concat
"\\(?:"
(mapconcat 'regexp-quote org-done-keywords "\\|")
"\\)"))
'(2 'org-headline-done prepend)))
;; Priorities
;; `org-font-lock-add-priority-faces' prepends faces
'(org-font-lock-add-priority-faces)
;; Tags
;; `org-font-lock-add-tag-faces' prepends faces
'(org-font-lock-add-tag-faces)
;; Tags groups
(when (and org-group-tags org-tag-groups-alist)
(list (concat org-outline-regexp-bol ".+\\(:"
(regexp-opt (mapcar 'car org-tag-groups-alist))
":\\).*$")
'(1 'org-tag-group prepend)))
;; Special keywords (as a part of planning)
(list (concat "\\<" org-deadline-string) '(0 'org-special-keyword t))
(list (concat "\\<" org-scheduled-string) '(0 'org-special-keyword t))
(list (concat "\\<" org-closed-string) '(0 'org-special-keyword t))
(list (concat "\\<" org-clock-string) '(0 'org-special-keyword t))
;; Emphasis
;; `org-do-emphasis-faces' prepends faces
(when org-fontify-emphasized-text '(org-do-emphasis-faces))
;; Checkboxes
`(,org-list-full-item-re 3 'org-checkbox prepend lax)
(when (cdr (assq 'checkbox org-list-automatic-rules))
'("\\[\\([0-9]*%\\)\\]\\|\\[\\([0-9]*\\)/\\([0-9]*\\)\\]"
(0 (org-get-checkbox-statistics-face) prepend)))
;; Description list items
'("\\(?:^[ \t]*[-+]\\|^[ \t]+[*]\\)[ \t]+\\(.*?[ \t]+::\\)\\([ \t]+\\|$\\)"
1 'org-list-dt prepend)
;; Inline export snippets
'("\\(@@\\)\\([a-z-]+:\\).*?\\(@@\\)"
(1 'font-lock-comment-face prepend)
(2 'org-tag prepend)
(3 'font-lock-comment-face prepend))
;; ARCHIVEd headings
(list (concat
org-outline-regexp-bol
"\\(.*:" org-archive-tag ":.*\\)")
'(1 'org-archived prepend))
;; Specials
'(org-do-latex-and-related) ; prepends faces
'(org-fontify-entities) ; applies composition
'(org-raise-scripts) ; applies display
;; Code
'(org-activate-code (1 'org-code prepend))
;; Blocks and meta lines
;; Their face is an override - keywords, affiliated
;; keywords, blocks, and block boundaries are all
;; containers or part of container-only markup.
'(org-fontify-meta-lines-and-blocks)
;; `org-fontify-inline-src-blocks' prepends object boundary
;; faces and overrides native faces.
'(org-fontify-inline-src-blocks)
;; Citations. When an activate processor is specified, if
;; specified, try loading it beforehand.
(progn
(unless (null org-cite-activate-processor)
(org-cite-try-load-processor org-cite-activate-processor))
;; prepends faces
'(org-cite-activate))
;; COMMENT
;; Apply this last, after all the markup is highlighted, so
;; that even "bright" markup will become dim.
(list (format
"^\\*+\\(?: +%s\\)?\\(?: +\\[#[A-Z0-9]\\]\\)? +\\(?9:%s\\)\\(?: \\|$\\)"
org-todo-regexp
org-comment-string)
'(9 'org-special-keyword prepend))
'(org-activate-folds))))
(setq org-font-lock-extra-keywords (delq nil org-font-lock-extra-keywords))
(run-hooks 'org-font-lock-set-keywords-hook)
;; Now set the full font-lock-keywords
(setq-local org-font-lock-keywords org-font-lock-extra-keywords)
(setq-local font-lock-defaults
'(org-font-lock-keywords t nil nil backward-paragraph))
(setq-local font-lock-extend-after-change-region-function
#'org-fontify-extend-region)
(kill-local-variable 'font-lock-keywords)
nil))
(defun org-toggle-pretty-entities ()
"Toggle the composition display of entities as UTF8 characters."
(interactive)
(setq-local org-pretty-entities (not org-pretty-entities))
(org-restart-font-lock)
(if org-pretty-entities
(message "Entities are now displayed as UTF8 characters")
(save-restriction
(widen)
(decompose-region (point-min) (point-max))
(message "Entities are now displayed as plain text"))))
(defvar-local org-custom-properties-overlays nil
"List of overlays used for custom properties.")
;; Preserve when switching modes or when restarting Org.
(put 'org-custom-properties-overlays 'permanent-local t)
(defun org-toggle-custom-properties-visibility ()
"Display or hide properties in `org-custom-properties'."
(interactive)
(if org-custom-properties-overlays
(progn (mapc #'delete-overlay org-custom-properties-overlays)
(setq org-custom-properties-overlays nil))
(when org-custom-properties
(org-with-wide-buffer
(goto-char (point-min))
(let ((regexp (org-re-property (regexp-opt org-custom-properties) t t)))
(while (re-search-forward regexp nil t)
(let ((end (cdr (save-match-data (org-get-property-block)))))
(when (and end (< (point) end))
;; Hide first custom property in current drawer.
(let ((o (make-overlay (match-beginning 0) (1+ (match-end 0)))))
(overlay-put o 'invisible t)
(overlay-put o 'org-custom-property t)
(push o org-custom-properties-overlays))
;; Hide additional custom properties in the same drawer.
(while (re-search-forward regexp end t)
(let ((o (make-overlay (match-beginning 0) (1+ (match-end 0)))))
(overlay-put o 'invisible t)
(overlay-put o 'org-custom-property t)
(push o org-custom-properties-overlays)))))
;; Each entry is limited to a single property drawer.
(outline-next-heading)))))))
(defun org-fontify-entities (limit)
"Find an entity to fontify."
(let (ee)
(when org-pretty-entities
(catch 'match
;; "\_ "-family is left out on purpose. Only the first one,
;; i.e., "\_ ", could be fontified anyway, and it would be
;; confusing when adding a second white space character.
(while (re-search-forward
"\\\\\\(there4\\|sup[123]\\|frac[13][24]\\|[a-zA-Z]+\\)\\($\\|{}\\|[^[:alpha:]\n]\\)"
limit t)
(when (and (not (org-at-comment-p))
(setq ee (org-entity-get (match-string 1)))
(= (length (nth 6 ee)) 1))
(let* ((end (if (equal (match-string 2) "{}")
(match-end 2)
(match-end 1))))
(add-text-properties
(match-beginning 0) end
(list 'font-lock-fontified t))
(compose-region (match-beginning 0) end
(nth 6 ee) nil)
(backward-char 1)
(throw 'match t))))
nil))))
(defun org-fontify-like-in-org-mode (s &optional odd-levels)
"Fontify string S like in Org mode."
(with-temp-buffer
(insert s)
(let ((org-odd-levels-only odd-levels))
(org-mode)
(font-lock-ensure)
(if org-link-descriptive
(org-link-display-format
(buffer-string))
(buffer-string)))))
(defun org-get-level-face (n)
"Get the right face for match N in font-lock matching of headlines."
(let* ((org-l0 (- (match-end 2) (match-beginning 1) 1))
(org-l (if org-odd-levels-only (1+ (/ org-l0 2)) org-l0))
(org-f (if org-cycle-level-faces
(nth (% (1- org-l) org-n-level-faces) org-level-faces)
(nth (1- (min org-l org-n-level-faces)) org-level-faces))))
(cond
((eq n 1) (if org-hide-leading-stars 'org-hide org-f))
((eq n 2) org-f)
(t (unless org-level-color-stars-only org-f)))))
(defun org-face-from-face-or-color (context inherit face-or-color)
"Create a face list that inherits INHERIT, but sets the foreground color.
When FACE-OR-COLOR is not a string, just return it."
(if (stringp face-or-color)
(list :inherit inherit
(cdr (assoc context org-faces-easy-properties))
face-or-color)
face-or-color))
(defun org-get-todo-face (kwd)
"Get the right face for a TODO keyword KWD.
If KWD is a number, get the corresponding match group."
(when (numberp kwd) (setq kwd (match-string kwd)))
(or (org-face-from-face-or-color
'todo 'org-todo (cdr (assoc kwd org-todo-keyword-faces)))
(and (member kwd org-done-keywords) 'org-done)
'org-todo))
(defun org-get-priority-face (priority)
"Get the right face for PRIORITY.
PRIORITY is a character."
(or (org-face-from-face-or-color
'priority 'org-priority (cdr (assq priority org-priority-faces)))
'org-priority))
(defun org-get-tag-face (tag)
"Get the right face for TAG.
If TAG is a number, get the corresponding match group."
(let ((tag (if (wholenump tag) (match-string tag) tag)))
(or (org-face-from-face-or-color
'tag 'org-tag (cdr (assoc tag org-tag-faces)))
'org-tag)))
(defvar org-priority-regexp) ; defined later in the file
(defun org-font-lock-add-priority-faces (limit)
"Add the special priority faces."
(while (re-search-forward (concat "^\\*+" org-priority-regexp) limit t)
(let ((beg (match-beginning 1))
(end (1+ (match-end 2))))
(add-face-text-property
beg end
(org-get-priority-face (string-to-char (match-string 2))))
(add-text-properties
beg end
(list 'font-lock-fontified t)))))
(defun org-font-lock-add-tag-faces (limit)
"Add the special tag faces."
(when (and org-tag-faces org-tags-special-faces-re)
(while (re-search-forward org-tags-special-faces-re limit t)
(add-face-text-property
(match-beginning 1)
(match-end 1)
(org-get-tag-face 1))
(add-text-properties (match-beginning 1) (match-end 1)
(list 'font-lock-fontified t))
(backward-char 1))))
(defun org-unfontify-region (beg end &optional _maybe_loudly)
"Remove fontification and activation overlays from links."
(font-lock-default-unfontify-region beg end)
(with-silent-modifications
(decompose-region beg end)
(remove-text-properties beg end
'(mouse-face t keymap t org-linked-text t
invisible t intangible t
org-emphasis t))
(org-fold-core-update-optimisation beg end)
(org-remove-font-lock-display-properties beg end)))
(defconst org-script-display '(((raise -0.3) (height 0.7))
((raise 0.3) (height 0.7))
((raise -0.5))
((raise 0.5)))
"Display properties for showing superscripts and subscripts.")
(defun org-remove-font-lock-display-properties (beg end)
"Remove specific display properties that have been added by font lock.
The will remove the raise properties that are used to show superscripts
and subscripts."
(let (next prop)
(while (< beg end)
(setq next (next-single-property-change beg 'display nil end)
prop (get-text-property beg 'display))
(when (member prop org-script-display)
(put-text-property beg next 'display nil))
(setq beg next))))
(defun org-raise-scripts (limit)
"Add raise properties to sub/superscripts."
(when (and org-pretty-entities org-pretty-entities-include-sub-superscripts
(re-search-forward
(if (eq org-use-sub-superscripts t)
org-match-substring-regexp
org-match-substring-with-braces-regexp)
limit t))
(let* ((pos (point)) table-p comment-p
(mpos (match-beginning 3))
(emph-p (get-text-property mpos 'org-emphasis))
(link-p (get-text-property mpos 'mouse-face))
(keyw-p (eq 'org-special-keyword (get-text-property mpos 'face))))
(goto-char (line-beginning-position))
(setq table-p (looking-at-p org-table-dataline-regexp)
comment-p (looking-at-p "^[ \t]*#[ +]"))
(goto-char pos)
;; Handle a_b^c
(when (member (char-after) '(?_ ?^)) (goto-char (1- pos)))
(unless (or comment-p emph-p link-p keyw-p)
(put-text-property (match-beginning 3) (match-end 0)
'display
(if (equal (char-after (match-beginning 2)) ?^)
(nth (if table-p 3 1) org-script-display)
(nth (if table-p 2 0) org-script-display)))
(put-text-property (match-beginning 2) (match-end 3)
'org-emphasis t)
(add-text-properties (match-beginning 2) (match-end 2)
(list 'invisible t))
(when (and (eq (char-after (match-beginning 3)) ?{)
(eq (char-before (match-end 3)) ?}))
(add-text-properties (match-beginning 3) (1+ (match-beginning 3))
(list 'invisible t))
(add-text-properties (1- (match-end 3)) (match-end 3)
(list 'invisible t))))
t)))
(defun org-remove-empty-overlays-at (pos)
"Remove outline overlays that do not contain non-white stuff."
(dolist (o (overlays-at pos))
(and (eq 'outline (overlay-get o 'invisible))
(not (string-match-p
"\\S-" (buffer-substring (overlay-start o)
(overlay-end o))))
(delete-overlay o))))
;; FIXME: This function is unused.
(defun org-show-empty-lines-in-parent ()
"Move to the parent and re-show empty lines before visible headlines."
(save-excursion
(let ((context (if (org-up-heading-safe) 'children 'overview)))
(org-cycle-show-empty-lines context))))
(defun org-files-list ()
"Return `org-agenda-files' list, plus all open Org files.
This is useful for operations that need to scan all of a user's
open and agenda-wise Org files."
(let ((files (mapcar #'expand-file-name (org-agenda-files))))
(dolist (buf (buffer-list))
(with-current-buffer buf
(when (and (derived-mode-p 'org-mode) (buffer-file-name))
(cl-pushnew (expand-file-name (buffer-file-name)) files
:test #'equal))))
files))
(defsubst org-entry-beginning-position ()
"Return the beginning position of the current entry."
(save-excursion (org-back-to-heading t) (point)))
(defsubst org-entry-end-position ()
"Return the end position of the current entry."
(save-excursion (outline-next-heading) (point)))
(defun org-subtree-end-visible-p ()
"Is the end of the current subtree visible?"
(pos-visible-in-window-p
(save-excursion (org-end-of-subtree t) (point))))
(defun org-first-headline-recenter ()
"Move cursor to the first headline and recenter the headline."
(let ((window (get-buffer-window)))
(when window
(goto-char (point-min))
(when (re-search-forward (concat "^\\(" org-outline-regexp "\\)") nil t)
(set-window-start window (line-beginning-position))))))
;; FIXME: It was in the middle of visibility section. Where should it go to?
(defvar org-called-with-limited-levels nil
"Non-nil when `org-with-limited-levels' is currently active.")
;;; Indirect buffer display of subtrees
(defvar org-indirect-dedicated-frame nil
"This is the frame being used for indirect tree display.")
(defvar org-last-indirect-buffer nil)
(defun org-tree-to-indirect-buffer (&optional arg)
"Create indirect buffer and narrow it to current subtree.
With a numerical prefix ARG, go up to this level and then take that tree.
If ARG is negative, go up that many levels.
If `org-indirect-buffer-display' is not `new-frame', the command removes the
indirect buffer previously made with this command, to avoid proliferation of
indirect buffers. However, when you call the command with a \
`\\[universal-argument]' prefix, or
when `org-indirect-buffer-display' is `new-frame', the last buffer is kept
so that you can work with several indirect buffers at the same time. If
`org-indirect-buffer-display' is `dedicated-frame', the \
`\\[universal-argument]' prefix also
requests that a new frame be made for the new buffer, so that the dedicated
frame is not changed."
(interactive "P")
(let ((cbuf (current-buffer))
(cwin (selected-window))
(pos (point))
beg end level heading ibuf
(last-indirect-window
(and org-last-indirect-buffer
(get-buffer-window org-last-indirect-buffer))))
(save-excursion
(org-back-to-heading t)
(when (numberp arg)
(setq level (org-outline-level))
(when (< arg 0) (setq arg (+ level arg)))
(while (> (setq level (org-outline-level)) arg)
(org-up-heading-safe)))
(setq beg (point)
heading (org-get-heading 'no-tags))
(org-end-of-subtree t t)
(when (and (not (eobp)) (org-at-heading-p)) (backward-char 1))
(setq end (point)))
(when (and (buffer-live-p org-last-indirect-buffer)
(not (eq org-indirect-buffer-display 'new-frame))
(not arg))
(kill-buffer org-last-indirect-buffer))
(setq ibuf (org-get-indirect-buffer cbuf heading)
org-last-indirect-buffer ibuf)
(cond
((or (eq org-indirect-buffer-display 'new-frame)
(and arg (eq org-indirect-buffer-display 'dedicated-frame)))
(select-frame (make-frame))
(pop-to-buffer ibuf '(org-display-buffer-full-frame))
(org-set-frame-title heading))
((eq org-indirect-buffer-display 'dedicated-frame)
(raise-frame
(select-frame (or (and org-indirect-dedicated-frame
(frame-live-p org-indirect-dedicated-frame)
org-indirect-dedicated-frame)
(setq org-indirect-dedicated-frame (make-frame)))))
(pop-to-buffer ibuf '(org-display-buffer-full-frame))
(org-set-frame-title (concat "Indirect: " heading)))
((eq org-indirect-buffer-display 'current-window)
(pop-to-buffer-same-window ibuf))
((eq org-indirect-buffer-display 'other-window)
(pop-to-buffer
ibuf
`(org-display-buffer-in-window (window . ,last-indirect-window)
(same-frame . t))))
(t (error "Invalid value")))
(narrow-to-region beg end)
(org-fold-show-all '(headings drawers blocks))
(goto-char pos)
(run-hook-with-args 'org-cycle-hook 'all)
(and (window-live-p cwin) (select-window cwin))))
(cl-defun org-get-indirect-buffer (&optional (buffer (current-buffer)) heading)
"Return an indirect buffer based on BUFFER.
If HEADING, append it to the name of the new buffer."
(let* ((base-buffer (or (buffer-base-buffer buffer) buffer))
(buffer-name (generate-new-buffer-name
(format "%s%s"
(buffer-name base-buffer)
(if heading
(concat "::" heading)
""))))
(indirect-buffer (make-indirect-buffer base-buffer buffer-name 'clone)))
;; Decouple folding state. We need to do it manually since
;; `make-indirect-buffer' does not run
;; `clone-indirect-buffer-hook'.
(org-fold-core-decouple-indirect-buffer-folds)
indirect-buffer))
(defun org-set-frame-title (title)
"Set the title of the current frame to the string TITLE."
(modify-frame-parameters (selected-frame) (list (cons 'name title))))
;;;; Structure editing
;;; Inserting headlines
(defun org--blank-before-heading-p (&optional parent)
"Non-nil when an empty line should precede a new heading here.
When optional argument PARENT is non-nil, consider parent
headline instead of current one."
(pcase (assq 'heading org-blank-before-new-entry)
(`(heading . auto)
(save-excursion
(org-with-limited-levels
(unless (and (org-before-first-heading-p)
(not (outline-next-heading)))
(org-back-to-heading t)
(when parent (org-up-heading-safe))
(cond ((not (bobp))
(org-previous-line-empty-p))
((outline-next-heading)
(org-previous-line-empty-p))
;; Ignore trailing spaces on last buffer line.
((progn (skip-chars-backward " \t") (bolp))
(org-previous-line-empty-p))
(t nil))))))
(`(heading . ,value) value)
(_ nil)))
(defun org-insert-heading (&optional arg invisible-ok level)
"Insert a new heading or an item with the same depth at point.
If point is at the beginning of a heading, insert a new heading
or a new headline above the current one. When at the beginning
of a regular line of text, turn it into a heading.
If point is in the middle of a line, split it and create a new
headline with the text in the current line after point (see
`org-M-RET-may-split-line' on how to modify this behavior). As
a special case, on a headline, splitting can only happen on the
title itself. E.g., this excludes breaking stars or tags.
With a `\\[universal-argument]' prefix, set \
`org-insert-heading-respect-content' to
a non-nil value for the duration of the command. This forces the
insertion of a heading after the current subtree, independently
on the location of point.
With a `\\[universal-argument] \\[universal-argument]' prefix, \
insert the heading at the end of the tree
above the current heading. For example, if point is within a
2nd-level heading, then it will insert a 2nd-level heading at
the end of the 1st-level parent subtree.
When INVISIBLE-OK is set, stop at invisible headlines when going
back. This is important for non-interactive uses of the
command.
When optional argument LEVEL is a number, insert a heading at
that level. For backwards compatibility, when LEVEL is non-nil
but not a number, insert a level-1 heading."
(interactive "P")
(let* ((blank? (org--blank-before-heading-p (equal arg '(16))))
(current-level (org-current-level))
(num-stars (or
;; Backwards compat: if LEVEL non-nil, level is 1
(and level (if (wholenump level) level 1))
current-level
;; This `1' is for when before first headline
1))
(stars (make-string num-stars ?*))
(maybe-add-blank-after
(lambda (blank?)
"Add a blank line before next heading when BLANK? is non-nil.
Assume that point is on the inserted heading."
(save-excursion
(end-of-line)
(unless (eobp)
(forward-char)
(when (and blank? (org-at-heading-p))
(insert "\n")))))))
(cond
((or org-insert-heading-respect-content
(member arg '((4) (16)))
(and (not invisible-ok)
(invisible-p (max (1- (point)) (point-min)))))
;; Position point at the location of insertion. Make sure we
;; end up on a visible headline if INVISIBLE-OK is nil.
(org-with-limited-levels
(if (not current-level) (outline-next-heading) ;before first headline
(org-back-to-heading invisible-ok)
(when (equal arg '(16)) (org-up-heading-safe))
(org-end-of-subtree invisible-ok 'to-heading)))
;; At `point-max', if the file does not have ending newline,
;; create one, so that we are not appending stars at non-empty
;; line.
(unless (bolp) (insert "\n"))
(when (and blank? (save-excursion
(backward-char)
(org-before-first-heading-p)))
(insert "\n")
(backward-char))
(when (and (not current-level) (not (eobp)) (not (bobp)))
(when (org-at-heading-p) (insert "\n"))
(backward-char))
(unless (and blank? (org-previous-line-empty-p))
(org-N-empty-lines-before-current (if blank? 1 0)))
(insert stars " " "\n")
;; Move point after stars.
(backward-char)
;; Retain blank lines before next heading.
(funcall maybe-add-blank-after blank?)
;; When INVISIBLE-OK is non-nil, ensure newly created headline
;; is visible.
(unless invisible-ok
(if (eq org-fold-core-style 'text-properties)
(cond
((org-fold-folded-p
(max (point-min)
(1- (line-beginning-position)))
'headline)
(org-fold-region (line-end-position 0) (line-end-position) nil 'headline))
(t nil))
(pcase (get-char-property-and-overlay (point) 'invisible)
(`(outline . ,o)
(move-overlay o (overlay-start o) (line-end-position 0)))
(_ nil)))))
;; At a headline...
((org-at-heading-p)
(cond ((bolp)
(when blank? (save-excursion (insert "\n")))
(save-excursion (insert stars " \n"))
(unless (and blank? (org-previous-line-empty-p))
(org-N-empty-lines-before-current (if blank? 1 0)))
(end-of-line))
((and (org-get-alist-option org-M-RET-may-split-line 'headline)
(org-match-line org-complex-heading-regexp)
(org-pos-in-match-range (point) 4))
;; Grab the text that should moved to the new headline.
;; Preserve tags.
(let ((split (delete-and-extract-region (point) (match-end 4))))
(if (looking-at "[ \t]*$") (replace-match "")
(when org-auto-align-tags (org-align-tags)))
(end-of-line)
(when blank? (insert "\n"))
(insert "\n" stars " ")
;; Retain blank lines before next heading.
(funcall maybe-add-blank-after blank?)
(when (org-string-nw-p split) (insert split))))
(t
(end-of-line)
(when blank? (insert "\n"))
(insert "\n" stars " ")
;; Retain blank lines before next heading.
(funcall maybe-add-blank-after blank?))))
;; On regular text, turn line into a headline or split, if
;; appropriate.
((bolp)
(insert stars " ")
(unless (and blank? (org-previous-line-empty-p))
(org-N-empty-lines-before-current (if blank? 1 0)))
;; Retain blank lines before next heading.
(funcall maybe-add-blank-after blank?))
(t
(unless (org-get-alist-option org-M-RET-may-split-line 'headline)
(end-of-line))
(insert "\n" stars " ")
(unless (and blank? (org-previous-line-empty-p))
(org-N-empty-lines-before-current (if blank? 1 0)))
;; Retain blank lines before next heading.
(funcall maybe-add-blank-after blank?))))
(run-hooks 'org-insert-heading-hook))
(defun org-N-empty-lines-before-current (n)
"Make the number of empty lines before current exactly N.
So this will delete or add empty lines."
(let ((column (current-column)))
(forward-line 0)
(unless (bobp)
(let ((start (save-excursion
(skip-chars-backward " \r\t\n")
(line-end-position))))
(delete-region start (line-end-position 0))))
(insert (make-string n ?\n))
(move-to-column column)))
(defun org-get-heading (&optional no-tags no-todo no-priority no-comment)
"Return the heading of the current entry, without the stars.
When NO-TAGS is non-nil, don't include tags.
When NO-TODO is non-nil, don't include TODO keywords.
When NO-PRIORITY is non-nil, don't include priority cookie.
When NO-COMMENT is non-nil, don't include COMMENT string.
Return nil before first heading."
(unless (org-before-first-heading-p)
(save-excursion
(org-back-to-heading t)
(let ((case-fold-search nil))
(looking-at org-complex-heading-regexp)
;; When using `org-fold-core--optimise-for-huge-buffers',
;; returned text will be invisible. Clear it up.
(save-match-data
(org-fold-core-remove-optimisation (match-beginning 0) (match-end 0)))
(let ((todo (and (not no-todo) (match-string 2)))
(priority (and (not no-priority) (match-string 3)))
(headline (pcase (match-string 4)
(`nil "")
((and (guard no-comment) h)
(replace-regexp-in-string
(eval-when-compile
(format "\\`%s[ \t]+" org-comment-string))
"" h))
(h h)))
(tags (and (not no-tags) (match-string 5))))
;; Restore cleared optimization.
(org-fold-core-update-optimisation (match-beginning 0) (match-end 0))
(mapconcat #'identity
(delq nil (list todo priority headline tags))
" "))))))
(defun org-heading-components ()
"Return the components of the current heading.
This is a list with the following elements:
- the level as an integer
- the reduced level, different if `org-odd-levels-only' is set.
- the TODO keyword, or nil
- the priority character, like ?A, or nil if no priority is given
- the headline text itself, or the tags string if no headline text
- the tags string, or nil."
(save-excursion
(org-back-to-heading t)
(when (let (case-fold-search) (looking-at org-complex-heading-regexp))
(org-fold-core-remove-optimisation (match-beginning 0) (match-end 0))
(prog1
(list (length (match-string 1))
(org-reduced-level (length (match-string 1)))
(match-string-no-properties 2)
(and (match-end 3) (aref (match-string 3) 2))
(match-string-no-properties 4)
(match-string-no-properties 5))
(org-fold-core-update-optimisation (match-beginning 0) (match-end 0))))))
(defun org-get-entry ()
"Get the entry text, after heading, entire subtree."
(save-excursion
(org-back-to-heading t)
(filter-buffer-substring (line-beginning-position 2) (org-end-of-subtree t))))
(defun org-edit-headline (&optional heading)
"Edit the current headline.
Set it to HEADING when provided."
(interactive)
(org-with-wide-buffer
(org-back-to-heading t)
(let ((case-fold-search nil))
(when (looking-at org-complex-heading-regexp)
(let* ((old (match-string-no-properties 4))
(new (save-match-data
(org-trim (or heading (read-string "Edit: " old))))))
(unless (equal old new)
(if old (replace-match new t t nil 4)
(goto-char (or (match-end 3) (match-end 2) (match-end 1)))
(insert " " new))
(when org-auto-align-tags (org-align-tags))
(when (looking-at "[ \t]*$") (replace-match ""))))))))
(defun org-insert-heading-after-current ()
"Insert a new heading with same level as current, after current subtree."
(interactive)
(org-back-to-heading)
(org-insert-heading)
(org-move-subtree-down)
(end-of-line 1))
(defun org-insert-heading-respect-content (&optional invisible-ok)
"Insert heading with `org-insert-heading-respect-content' set to t."
(interactive)
(org-insert-heading '(4) invisible-ok))
(defun org-insert-todo-heading-respect-content (&optional arg)
"Call `org-insert-todo-heading', inserting after current subtree.
ARG is passed to `org-insert-todo-heading'.
This command temporarily sets `org-insert-heading-respect-content' to t."
(interactive "P")
(let ((org-insert-heading-respect-content t))
(org-insert-todo-heading arg t)))
(defun org-insert-todo-heading (arg &optional force-heading)
"Insert a new heading with the same level and TODO state as current heading.
If the heading has no TODO state, or if the state is DONE, use
the first state (TODO by default). Also with `\\[universal-argument]'
prefix, force first state. With a `\\[universal-argument]
\\[universal-argument]' prefix, force inserting at the end of the
parent subtree.
When called at a plain list item, insert a new item with an
unchecked check box."
(interactive "P")
(when (or force-heading (not (org-insert-item 'checkbox)))
(org-insert-heading (or (and (equal arg '(16)) '(16))
force-heading))
(save-excursion
(org-forward-heading-same-level -1)
(let ((case-fold-search nil)) (looking-at org-todo-line-regexp)))
(let* ((new-mark-x
(if (or (equal arg '(4))
(not (match-beginning 2))
(member (match-string 2) org-done-keywords))
(car org-todo-keywords-1)
(match-string 2)))
(new-mark
(or
(run-hook-with-args-until-success
'org-todo-get-default-hook new-mark-x nil)
new-mark-x)))
(forward-line 0)
(and (looking-at org-outline-regexp) (goto-char (match-end 0))
(if org-treat-insert-todo-heading-as-state-change
(org-todo new-mark)
(insert new-mark " "))))
(when org-provide-todo-statistics
(org-update-parent-todo-statistics))))
(defun org-insert-subheading (arg)
"Insert a new subheading and demote it.
Works for outline headings and for plain lists alike.
The prefix argument ARG is passed to `org-insert-heading'.
Unlike `org-insert-heading', when point is at the beginning of a
heading, still insert the new sub-heading below."
(interactive "P")
(when (and (bolp) (not (eobp)) (not (eolp))) (forward-char))
(org-insert-heading arg)
(cond
((org-at-heading-p) (org-do-demote))
((org-at-item-p) (org-indent-item))))
(defun org-insert-todo-subheading (arg)
"Insert a new subheading with TODO keyword or checkbox and demote it.
Works for outline headings and for plain lists alike.
The prefix argument ARG is passed to `org-insert-todo-heading'."
(interactive "P")
(org-insert-todo-heading arg)
(cond
((org-at-heading-p) (org-do-demote))
((org-at-item-p) (org-indent-item))))
;;; Promotion and Demotion
(defvar org-after-demote-entry-hook nil
"Hook run after an entry has been demoted.
The cursor will be at the beginning of the entry.
When a subtree is being demoted, the hook will be called for each node.")
(defvar org-after-promote-entry-hook nil
"Hook run after an entry has been promoted.
The cursor will be at the beginning of the entry.
When a subtree is being promoted, the hook will be called for each node.")
(defun org-promote-subtree ()
"Promote the entire subtree.
See also `org-promote'."
(interactive)
(save-excursion
(org-back-to-heading t)
(org-combine-change-calls (point) (save-excursion (org-end-of-subtree t))
(org-with-limited-levels (org-map-tree 'org-promote))))
(org-fix-position-after-promote))
(defun org-demote-subtree ()
"Demote the entire subtree.
See `org-demote' and `org-promote'."
(interactive)
(save-excursion
(org-back-to-heading t)
(org-combine-change-calls (point) (save-excursion (org-end-of-subtree t))
(org-with-limited-levels (org-map-tree 'org-demote))))
(org-fix-position-after-promote))
(defun org-do-promote ()
"Promote the current heading higher up the tree.
If the region is active in `transient-mark-mode', promote all
headings in the region."
(interactive)
(save-excursion
(if (org-region-active-p)
(let ((deactivate-mark nil))
(org-map-region 'org-promote (region-beginning) (region-end)))
(org-promote)))
(org-fix-position-after-promote))
(defun org-do-demote ()
"Demote the current heading lower down the tree.
If the region is active in `transient-mark-mode', demote all
headings in the region."
(interactive)
(save-excursion
(if (org-region-active-p)
(let ((deactivate-mark nil))
(org-map-region 'org-demote (region-beginning) (region-end)))
(org-demote)))
(org-fix-position-after-promote))
(defun org-fix-position-after-promote ()
"Fix cursor position and indentation after demoting/promoting."
(let ((pos (point)))
(when (save-excursion
(forward-line 0)
(let ((case-fold-search nil)) (looking-at org-todo-line-regexp))
(or (eq pos (match-end 1)) (eq pos (match-end 2))))
(cond ((eobp) (insert " "))
((eolp) (insert " "))
((equal (char-after) ?\s) (forward-char 1))))))
(defun org-current-level ()
"Return the level of the current entry, or nil if before the first headline.
The level is the number of stars at the beginning of the
headline. Use `org-reduced-level' to remove the effect of
`org-odd-levels-only'. Unlike `org-outline-level', this function
ignores inlinetasks."
(let ((level (org-with-limited-levels (org-outline-level))))
(and (> level 0) level)))
(defun org-get-previous-line-level ()
"Return the outline depth of the last headline before the current line.
Returns 0 for the first headline in the buffer, and nil if before the
first headline."
(and (org-current-level)
(or (and (/= (line-beginning-position) (point-min))
(save-excursion (forward-line -1) (org-current-level)))
0)))
(defun org-reduced-level (l)
"Compute the effective level of a heading.
This takes into account the setting of `org-odd-levels-only'."
(cond
((zerop l) 0)
(org-odd-levels-only (1+ (floor (/ l 2))))
(t l)))
(defun org-level-increment ()
"Return the number of stars that will be added or removed at a
time to headlines when structure editing, based on the value of
`org-odd-levels-only'."
(if org-odd-levels-only 2 1))
(defun org-get-valid-level (level &optional change)
"Rectify a level change under the influence of `org-odd-levels-only'.
LEVEL is a current level, CHANGE is by how much the level should
be modified. Even if CHANGE is nil, LEVEL may be returned
modified because even level numbers will become the next higher
odd number. Returns values greater than 0."
(if org-odd-levels-only
(cond ((or (not change) (= 0 change)) (1+ (* 2 (/ level 2))))
((> change 0) (1+ (* 2 (/ (+ (1- level) (* 2 change)) 2))))
((< change 0) (max 1 (1+ (* 2 (/ (+ level (* 2 change)) 2))))))
(max 1 (+ level (or change 0)))))
(defun org-promote ()
"Promote the current heading higher up the tree."
(org-with-wide-buffer
(org-back-to-heading t)
(let* ((after-change-functions (remq 'flyspell-after-change-function
after-change-functions))
(level (save-match-data (funcall outline-level)))
(up-head (concat (make-string (org-get-valid-level level -1) ?*) " "))
(diff (abs (- level (length up-head) -1))))
(cond
((and (= level 1) org-allow-promoting-top-level-subtree)
(replace-match "# " nil t))
((= level 1)
(user-error "Cannot promote to level 0. UNDO to recover if necessary"))
(t (replace-match (apply #'propertize up-head (text-properties-at (match-beginning 0))) t)))
(unless (= level 1)
(when org-auto-align-tags (org-align-tags))
(when org-adapt-indentation (org-fixup-indentation (- diff))))
(run-hooks 'org-after-promote-entry-hook))))
(defun org-demote ()
"Demote the current heading lower down the tree."
(org-with-wide-buffer
(org-back-to-heading t)
(let* ((after-change-functions (remq 'flyspell-after-change-function
after-change-functions))
(level (save-match-data (funcall outline-level)))
(down-head (concat (make-string (org-get-valid-level level 1) ?*) " "))
(diff (abs (- level (length down-head) -1))))
(org-fold-core-ignore-fragility-checks
(replace-match (apply #'propertize down-head (text-properties-at (match-beginning 0))) t)
(when org-auto-align-tags (org-align-tags))
(when org-adapt-indentation (org-fixup-indentation diff)))
(run-hooks 'org-after-demote-entry-hook))))
(defun org-cycle-level ()
"Cycle the level of an empty headline through possible states.
This goes first to child, then to parent, level, then up the hierarchy.
After top level, it switches back to sibling level."
(interactive)
(let ((org-adapt-indentation nil))
(when (and (org-point-at-end-of-empty-headline)
(not (and (featurep 'org-inlinetask)
(org-inlinetask-in-task-p))))
(setq this-command 'org-cycle-level) ; Only needed for caching
(let ((cur-level (org-current-level))
(prev-level (org-get-previous-line-level)))
(cond
;; If first headline in file, promote to top-level.
((= prev-level 0)
(cl-loop repeat (/ (- cur-level 1) (org-level-increment))
do (org-do-promote)))
;; If same level as prev, demote one.
((= prev-level cur-level)
(org-do-demote))
;; If parent is top-level, promote to top level if not already.
((= prev-level 1)
(cl-loop repeat (/ (- cur-level 1) (org-level-increment))
do (org-do-promote)))
;; If top-level, return to prev-level.
((= cur-level 1)
(cl-loop repeat (/ (- prev-level 1) (org-level-increment))
do (org-do-demote)))
;; If less than prev-level, promote one.
((< cur-level prev-level)
(org-do-promote))
;; If deeper than prev-level, promote until higher than
;; prev-level.
((> cur-level prev-level)
(cl-loop repeat (+ 1 (/ (- cur-level prev-level) (org-level-increment)))
do (org-do-promote))))
t))))
(defun org-map-tree (fun)
"Call FUN for every heading underneath the current one."
(org-back-to-heading t)
(let ((level (funcall outline-level)))
(save-excursion
(funcall fun)
(while (and (progn
(outline-next-heading)
(> (funcall outline-level) level))
(not (eobp)))
(funcall fun)))))
(defun org-map-region (fun beg end)
"Call FUN for every heading between BEG and END."
(let ((org-ignore-region t))
(save-excursion
(setq end (copy-marker end))
(goto-char beg)
(when (and (re-search-forward org-outline-regexp-bol nil t)
(< (point) end))
(funcall fun))
(while (and (progn
(outline-next-heading)
(< (point) end))
(not (eobp)))
(funcall fun)))))
(defun org-fixup-indentation (diff)
"Change the indentation in the current entry by DIFF.
DIFF is an integer. Indentation is done according to the
following rules:
- Planning information and property drawers are always indented
according to the new level of the headline;
- Footnote definitions and their contents are ignored;
- Inlinetasks' boundaries are not shifted;
- Empty lines are ignored;
- Other lines' indentation are shifted by DIFF columns, unless
it would introduce a structural change in the document, in
which case no shifting is done at all.
Assume point is at a heading or an inlinetask beginning."
(org-with-wide-buffer
(narrow-to-region (line-beginning-position)
(save-excursion
(if (org-with-limited-levels (org-at-heading-p))
(org-with-limited-levels (outline-next-heading))
(org-inlinetask-goto-end))
(point)))
(forward-line)
;; Indent properly planning info and property drawer.
(when (looking-at-p org-planning-line-re)
(org-indent-line)
(forward-line))
(when (looking-at org-property-drawer-re)
(goto-char (match-end 0))
(forward-line)
(org-indent-region (match-beginning 0) (match-end 0)))
(when (looking-at org-logbook-drawer-re)
(let ((end-marker (move-marker (make-marker) (match-end 0)))
(col (+ (current-indentation) diff)))
(when (wholenump col)
(while (< (point) end-marker)
(if (natnump diff)
(insert (make-string diff 32))
(delete-char (abs diff)))
(forward-line)))))
(catch 'no-shift
(when (or (zerop diff) (not (eq org-adapt-indentation t)))
(throw 'no-shift nil))
;; If DIFF is negative, first check if a shift is possible at all
;; (e.g., it doesn't break structure). This can only happen if
;; some contents are not properly indented.
(let ((case-fold-search t))
(when (< diff 0)
(let ((diff (- diff))
(forbidden-re (concat org-outline-regexp
"\\|"
(substring org-footnote-definition-re 1))))
(save-excursion
(while (not (eobp))
(cond
((looking-at-p "[ \t]*$") (forward-line))
((and (looking-at-p org-footnote-definition-re)
(let ((e (org-element-at-point)))
(and (org-element-type-p e 'footnote-definition)
(goto-char (org-element-end e))))))
((looking-at-p org-outline-regexp) (forward-line))
;; Give up if shifting would move before column 0 or
;; if it would introduce a headline or a footnote
;; definition.
(t
(skip-chars-forward " \t")
(let ((ind (current-column)))
(when (or (< ind diff)
(and (= ind diff) (looking-at-p forbidden-re)))
(throw 'no-shift nil)))
;; Ignore contents of example blocks and source
;; blocks if their indentation is meant to be
;; preserved. Jump to block's closing line.
(forward-line 0)
(or (and (looking-at-p "[ \t]*#\\+BEGIN_\\(EXAMPLE\\|SRC\\)")
(let ((e (org-element-at-point)))
(and (org-src-preserve-indentation-p e)
(goto-char (org-element-end e))
(progn (skip-chars-backward " \r\t\n")
(forward-line 0)
t))))
(forward-line))))))))
;; Shift lines but footnote definitions, inlinetasks boundaries
;; by DIFF. Also skip contents of source or example blocks
;; when indentation is meant to be preserved.
(while (not (eobp))
(cond
((and (looking-at-p org-footnote-definition-re)
(let ((e (org-element-at-point)))
(and (org-element-type-p e 'footnote-definition)
(goto-char (org-element-end e))))))
((looking-at-p org-outline-regexp) (forward-line))
((looking-at-p "[ \t]*$") (forward-line))
(t
(indent-line-to (+ (current-indentation) diff))
(forward-line 0)
(or (and (looking-at-p "[ \t]*#\\+BEGIN_\\(EXAMPLE\\|SRC\\)")
(let ((e (org-element-at-point)))
(and (org-src-preserve-indentation-p e)
(goto-char (org-element-end e))
(progn (skip-chars-backward " \r\t\n")
(forward-line 0)
t))))
(forward-line)))))))))
(defun org-convert-to-odd-levels ()
"Convert an Org file with all levels allowed to one with odd levels.
This will leave level 1 alone, convert level 2 to level 3, level 3 to
level 5 etc."
(interactive)
(when (yes-or-no-p "Are you sure you want to globally change levels to odd? ")
(let ((outline-level 'org-outline-level)
(org-odd-levels-only nil) n)
(save-excursion
(goto-char (point-min))
(while (re-search-forward "^\\*\\*+ " nil t)
(setq n (- (length (match-string 0)) 2))
(while (>= (setq n (1- n)) 0)
(org-demote))
(end-of-line 1))))))
(defun org-convert-to-oddeven-levels ()
"Convert an Org file with only odd levels to one with odd/even levels.
This promotes level 3 to level 2, level 5 to level 3 etc. If the
file contains a section with an even level, conversion would
destroy the structure of the file. An error is signaled in this
case."
(interactive)
(goto-char (point-min))
;; First check if there are no even levels
(when (re-search-forward "^\\(\\*\\*\\)+ " nil t)
(org-fold-show-set-visibility 'canonical)
(error "Not all levels are odd in this file. Conversion not possible"))
(when (yes-or-no-p "Are you sure you want to globally change levels to odd-even? ")
(let ((outline-regexp org-outline-regexp)
(outline-level 'org-outline-level)
(org-odd-levels-only nil) n)
(save-excursion
(goto-char (point-min))
(while (re-search-forward "^\\*\\*+ " nil t)
(setq n (/ (1- (length (match-string 0))) 2))
(while (>= (setq n (1- n)) 0)
(org-promote))
(end-of-line 1))))))
(defun org-tr-level (n)
"Make N odd if required."
(if org-odd-levels-only (1+ (/ n 2)) n))
;;; Vertical tree motion, cutting and pasting of subtrees
(defun org-move-subtree-up (&optional arg)
"Move the current subtree up past ARG headlines of the same level."
(interactive "p")
(org-move-subtree-down (- (prefix-numeric-value arg))))
(defun org-clean-visibility-after-subtree-move ()
"Fix visibility issues after moving a subtree."
;; First, find a reasonable region to look at:
;; Start two siblings above, end three below
(let* ((beg (save-excursion
(and (org-get-previous-sibling)
(org-get-previous-sibling))
(point)))
(end (save-excursion
(and (org-get-next-sibling)
(org-get-next-sibling)
(org-get-next-sibling))
(if (org-at-heading-p)
(line-end-position)
(point))))
(level (looking-at "\\*+"))
(re (when level (concat "^" (regexp-quote (match-string 0)) " "))))
(save-excursion
(save-restriction
(narrow-to-region beg end)
(when re
;; Properly fold already folded siblings
(goto-char (point-min))
(while (re-search-forward re nil t)
(when (and (not (org-invisible-p))
(org-invisible-p (line-end-position)))
(org-fold-heading nil))))
(org-cycle-hide-drawers 'all)
(org-cycle-show-empty-lines 'overview)))))
(defun org-move-subtree-down (&optional arg)
"Move the current subtree down past ARG headlines of the same level."
(interactive "p")
(setq arg (prefix-numeric-value arg))
(org-preserve-local-variables
(let ((movfunc (if (> arg 0) 'org-get-next-sibling
'org-get-previous-sibling))
(ins-point (make-marker))
(cnt (abs arg))
(col (current-column))
beg end txt folded)
;; Select the tree
(org-back-to-heading)
(setq beg (point))
(save-match-data
(save-excursion (outline-end-of-heading)
(setq folded (org-invisible-p)))
(progn (org-end-of-subtree nil t)
(unless (eobp) (backward-char))))
(outline-next-heading)
(setq end (point))
(goto-char beg)
;; Find insertion point, with error handling
(while (> cnt 0)
(unless (and (funcall movfunc) (looking-at org-outline-regexp))
(goto-char beg)
(user-error "Cannot move past superior level or buffer limit"))
(setq cnt (1- cnt)))
(when (> arg 0)
;; Moving forward - still need to move over subtree
(org-end-of-subtree t t)
(save-excursion
(org-back-over-empty-lines)
(or (bolp) (newline))))
(move-marker ins-point (point))
(setq txt (buffer-substring beg end))
(org-save-markers-in-region beg end)
(delete-region beg end)
(when (eq org-fold-core-style 'overlays) (org-remove-empty-overlays-at beg))
(unless (= beg (point-min)) (org-fold-region (1- beg) beg nil 'outline))
(unless (bobp) (org-fold-region (1- (point)) (point) nil 'outline))
(and (not (bolp)) (looking-at "\n") (forward-char 1))
(let ((bbb (point)))
(insert-before-markers txt)
(org-reinstall-markers-in-region bbb)
(move-marker ins-point bbb))
(or (bolp) (insert "\n"))
(goto-char ins-point)
(org-skip-whitespace)
(move-marker ins-point nil)
(if folded
(org-fold-subtree t)
(org-fold-show-entry 'hide-drawers)
(org-fold-show-children))
(org-clean-visibility-after-subtree-move)
;; move back to the initial column we were at
(move-to-column col))))
(defvar org-subtree-clip ""
"Clipboard for cut and paste of subtrees.
This is actually only a copy of the kill, because we use the normal kill
ring. We need it to check if the kill was created by `org-copy-subtree'.")
(defvar org-subtree-clip-folded nil
"Was the last copied subtree folded?
This is used to fold the tree back after pasting.")
(defun org-cut-subtree (&optional n)
"Cut the current subtree into the clipboard.
With prefix arg N, cut this many sequential subtrees.
This is a short-hand for marking the subtree and then cutting it."
(interactive "p")
(org-copy-subtree n 'cut))
(defun org-copy-subtree (&optional n cut force-store-markers nosubtrees)
"Copy the current subtree into the clipboard.
With prefix arg N, copy this many sequential subtrees.
This is a short-hand for marking the subtree and then copying it.
If CUT is non-nil, actually cut the subtree.
If FORCE-STORE-MARKERS is non-nil, store the relative locations
of some markers in the region, even if CUT is non-nil. This is
useful if the caller implements cut-and-paste as copy-then-paste-then-cut."
(interactive "p")
(org-preserve-local-variables
(let (beg end folded (beg0 (point)))
(if (called-interactively-p 'any)
(org-back-to-heading nil) ; take what looks like a subtree
(org-back-to-heading t)) ; take what is really there
;; Do not consider inlinetasks as a subtree.
(when (org-element-type-p (org-element-at-point) 'inlinetask)
(org-up-element))
(setq beg (point))
(skip-chars-forward " \t\r\n")
(save-match-data
(if nosubtrees
(outline-next-heading)
(save-excursion (outline-end-of-heading)
(setq folded (org-invisible-p)))
(ignore-errors (org-forward-heading-same-level (1- n) t))
(org-end-of-subtree t t)))
;; Include the end of an inlinetask
(when (and (featurep 'org-inlinetask)
(looking-at-p (concat (org-inlinetask-outline-regexp)
"END[ \t]*$")))
(end-of-line))
(setq end (point))
(goto-char beg0)
(when (> end beg)
(setq org-subtree-clip-folded folded)
(when (or cut force-store-markers)
(org-save-markers-in-region beg end))
(if cut (kill-region beg end) (copy-region-as-kill beg end))
(setq org-subtree-clip (current-kill 0))
(message "%s: Subtree(s) with %d characters"
(if cut "Cut" "Copied")
(length org-subtree-clip))))))
(defun org-paste-subtree (&optional level tree for-yank remove)
"Paste the clipboard as a subtree, with modification of headline level.
The entire subtree is promoted or demoted in order to match a new headline
level.
If the cursor is at the beginning of a headline, the same level as
that headline is used to paste the tree before current headline.
With `\\[universal-argument]' prefix, force inserting at the same level
as current headline, after subtree at point.
With `\\[universal-argument]' `\\[universal-argument]' prefix, force
inserting as a child headline, as the first child.
If not, the new level is derived from the *visible* headings
before and after the insertion point, and taken to be the inferior headline
level of the two. So if the previous visible heading is level 3 and the
next is level 4 (or vice versa), level 4 will be used for insertion.
This makes sure that the subtree remains an independent subtree and does
not swallow low level entries.
You can also force a different level, either by using a numeric prefix
argument, or by inserting the heading marker by hand. For example, if the
cursor is after \"*****\", then the tree will be shifted to level 5.
If optional TREE is given, use this text instead of the kill ring.
When FOR-YANK is set, this is called by `org-yank'. In this case, do not
move back over whitespace before inserting, and move point to the end of
the inserted text when done.
When REMOVE is non-nil, remove the subtree from the clipboard."
(interactive "P")
(setq tree (or tree (current-kill 0)))
(unless (org-kill-is-subtree-p tree)
(user-error
(substitute-command-keys
"The kill is not a (set of) tree(s). Use `\\[yank]' to yank anyway")))
(org-with-limited-levels
(org-fold-core-ignore-fragility-checks
(let* ((visp (not (org-invisible-p)))
(txt tree)
(old-level (if (string-match org-outline-regexp-bol txt)
(- (match-end 0) (match-beginning 0) 1)
-1))
level-indicator?
(force-level
(cond
;; When point is after the stars in an otherwise empty
;; headline, use the number of stars as the forced level.
((and (or (not level) (member level '((4) (16))))
(org-match-line "^\\*+[ \t]*$")
(not (eq ?* (char-after))))
(setq level-indicator? (org-outline-level)))
((equal level '(4)) (org-outline-level))
((equal level '(16)) nil) ; handle later
(level (prefix-numeric-value level))
((looking-at-p org-outline-regexp-bol) (org-outline-level))))
(previous-level
(save-excursion
(unless (org-at-heading-p) (org-previous-visible-heading 1))
(if (org-at-heading-p) (org-outline-level) 1)))
(next-level
(save-excursion
(org-next-visible-heading 1)
(if (org-at-heading-p) (org-outline-level) 1)))
(new-level (or force-level
(max
;; C-u C-u forces child.
(if (equal level '(16)) (1+ previous-level) 0)
previous-level
next-level)))
(shift (if (or (= old-level -1)
(= new-level -1)
(= old-level new-level))
0
(- new-level old-level)))
(delta (if (> shift 0) -1 1))
(func (if (> shift 0) #'org-demote #'org-promote))
(org-odd-levels-only nil)
beg end newend)
;; Remove the forced level indicator.
(when level-indicator?
(delete-region (line-beginning-position) (line-beginning-position 2)))
;; Paste before the next visible heading or at end of buffer,
;; unless point is at the beginning of a headline.
(unless (and (bolp) (org-at-heading-p) (not (member level '((4) (16)))))
(when (equal level '(4)) (org-end-of-subtree t))
(org-next-visible-heading 1)
(unless (bolp) (insert "\n")))
(setq beg (point))
;; Avoid re-parsing cache elements when i.e. level 1 heading
;; is inserted and then promoted.
(org-combine-change-calls beg beg
(when (fboundp 'org-id-paste-tracker) (org-id-paste-tracker txt))
(insert txt)
(unless (string-suffix-p "\n" txt) (insert "\n"))
(setq newend (point))
(org-reinstall-markers-in-region beg)
(setq end (point))
(goto-char beg)
(skip-chars-forward " \t\n\r")
(setq beg (point))
(when (and (org-invisible-p) visp)
(save-excursion (org-fold-heading nil)))
;; Shift if necessary.
(unless (= shift 0)
(save-restriction
(narrow-to-region beg end)
(while (not (= shift 0))
(org-map-region func (point-min) (point-max))
(setq shift (+ delta shift)))
(goto-char (point-min))
(setq newend (point-max)))))
(when (or for-yank (called-interactively-p 'interactive))
(message "Clipboard pasted as level %d subtree" new-level))
(when (and (not for-yank) ; in this case, org-yank will decide about folding
(equal org-subtree-clip tree)
org-subtree-clip-folded)
;; The tree was folded before it was killed/copied
(org-fold-subtree t))
(when for-yank (goto-char newend))
(when remove (pop kill-ring))))))
(defun org-kill-is-subtree-p (&optional txt)
"Check if the current kill is an outline subtree, or a set of trees.
Returns nil if kill does not start with a headline, or if the first
headline level is not the largest headline level in the tree.
So this will actually accept several entries of equal levels as well,
which is OK for `org-paste-subtree'.
If optional TXT is given, check this string instead of the current kill."
(let* ((kill (or txt (ignore-errors (current-kill 0))))
(re (org-get-limited-outline-regexp))
(^re (concat "^" re))
(start-level (and kill
(string-match
(concat "\\`\\([ \t\n\r]*?\n\\)?\\(" re "\\)")
kill)
(- (match-end 2) (match-beginning 2) 1)))
(start (1+ (or (match-beginning 2) -1))))
(if (not start-level)
(progn
nil) ;; does not even start with a heading
(catch 'exit
(while (setq start (string-match ^re kill (1+ start)))
(when (< (- (match-end 0) (match-beginning 0) 1) start-level)
(throw 'exit nil)))
t))))
(defvar org-markers-to-move nil
"Markers that should be moved with a cut-and-paste operation.
Those markers are stored together with their positions relative to
the start of the region.")
(defvar org-log-note-marker) ; defined later
(defun org-save-markers-in-region (beg end)
"Check markers in region.
If these markers are between BEG and END, record their position relative
to BEG, so that after moving the block of text, we can put the markers back
into place.
This function gets called just before an entry or tree gets cut from the
buffer. After re-insertion, `org-reinstall-markers-in-region' must be
called immediately, to move the markers with the entries."
(setq org-markers-to-move nil)
(org-check-and-save-marker org-log-note-marker beg end)
(when (featurep 'org-clock)
(org-clock-save-markers-for-cut-and-paste beg end))
(when (featurep 'org-agenda)
(org-agenda-save-markers-for-cut-and-paste beg end)))
(defun org-check-and-save-marker (marker beg end)
"Check if MARKER is between BEG and END.
If yes, remember the marker and the distance to BEG."
(when (and (marker-buffer marker)
(or (equal (marker-buffer marker) (current-buffer))
(equal (marker-buffer marker) (buffer-base-buffer (current-buffer))))
(>= marker beg) (< marker end))
(push (cons marker (- marker beg)) org-markers-to-move)))
(defun org-reinstall-markers-in-region (beg)
"Move all remembered markers to their position relative to BEG."
(dolist (x org-markers-to-move)
(move-marker (car x) (+ beg (cdr x))))
(setq org-markers-to-move nil))
(defun org-narrow-to-subtree (&optional element)
"Narrow buffer to the current subtree.
Use the command `\\[widen]' to see the whole buffer again.
With optional argument ELEMENT narrow to subtree around ELEMENT."
(interactive)
(let* ((heading
(org-element-lineage
(or element (org-element-at-point))
'headline 'with-self))
(begin (org-element-begin heading))
(end (org-element-end heading)))
(if (and heading end
;; Preserve historical behavior throwing an error when
;; current heading starts before active narrowing.
(<= (point-min) begin))
(narrow-to-region
begin
;; Preserve historical behavior not extending the active
;; narrowing when the subtree extends beyond it.
(min (point-max)
(if (= end (point-max))
end (1- end))))
(signal 'outline-before-first-heading nil))))
(defun org-toggle-narrow-to-subtree ()
"Narrow to the subtree at point or widen a narrowed buffer.
Use the command `\\[widen]' to see the whole buffer again."
(interactive)
(if (buffer-narrowed-p)
(progn (widen) (message "Buffer widen"))
(org-narrow-to-subtree)
(message "Buffer narrowed to current subtree")))
(defun org-narrow-to-block ()
"Narrow buffer to the current block.
Use the command `\\[widen]' to see the whole buffer again."
(interactive)
(let* ((case-fold-search t)
(element (org-element-at-point)))
(if (string-match-p "block" (symbol-name (org-element-type element)))
(org-narrow-to-element)
(user-error "Not in a block"))))
(defun org-clone-subtree-with-time-shift (n &optional shift)
"Clone the task (subtree) at point N times.
The clones will be inserted as siblings.
In interactive use, the user will be prompted for the number of
clones to be produced. If the entry has a timestamp, the user
will also be prompted for a time shift, which may be a repeater
as used in time stamps, for example `+3d'. To disable this,
you can call the function with a universal prefix argument.
When a valid repeater is given and the entry contains any time
stamps, the clones will become a sequence in time, with time
stamps in the subtree shifted for each clone produced. If SHIFT
is nil or the empty string, time stamps will be left alone. The
ID property of the original subtree is removed.
In each clone, all the CLOCK entries will be removed. This
prevents Org from considering that the clocked times overlap.
If the original subtree did contain time stamps with a repeater,
the following will happen:
- the repeater will be removed in each clone
- an additional clone will be produced, with the current, unshifted
date(s) in the entry.
- the original entry will be placed *after* all the clones, with
repeater intact.
- the start days in the repeater in the original entry will be shifted
to past the last clone.
In this way you can spell out a number of instances of a repeating task,
and still retain the repeater to cover future instances of the task.
As described above, N+1 clones are produced when the original
subtree has a repeater. Setting N to 0, then, can be used to
remove the repeater from a subtree and create a shifted clone
with the original repeater."
(interactive "nNumber of clones to produce: ")
(unless (wholenump n) (user-error "Invalid number of replications %s" n))
(when (org-before-first-heading-p) (user-error "No subtree to clone"))
(let* ((beg (save-excursion (org-back-to-heading t) (point)))
(end-of-tree (save-excursion (org-end-of-subtree t t) (point)))
(shift
(or shift
(if (and (not (equal current-prefix-arg '(4)))
(save-excursion
(goto-char beg)
(re-search-forward org-ts-regexp-both end-of-tree t)))
(read-from-minibuffer
"Date shift per clone (e.g. +1w, empty to copy unchanged): ")
""))) ;No time shift
(doshift
(and (org-string-nw-p shift)
(or (string-match "\\`[ \t]*\\([+-]?[0-9]+\\)\\([hdwmy]\\)[ \t]*\\'"
shift)
(user-error "Invalid shift specification %s" shift)))))
(goto-char end-of-tree)
(unless (bolp) (insert "\n"))
(let* ((end (point))
(template (buffer-substring beg end))
(shift-n (and doshift (string-to-number (match-string 1 shift))))
(shift-what (pcase (and doshift (match-string 2 shift))
(`nil nil)
("h" 'hour)
("d" 'day)
("w" (setq shift-n (* 7 shift-n)) 'day)
("m" 'month)
("y" 'year)
(_ (error "Unsupported time unit"))))
(nmin 1)
(nmax n)
(n-no-remove -1)
(org-id-overriding-file-name (buffer-file-name (buffer-base-buffer)))
(idprop (org-entry-get beg "ID")))
(when (and doshift
(string-match-p "<[^<>\n]+ [.+]?\\+[0-9]+[hdwmy][^<>\n]*>"
template))
(delete-region beg end)
(setq end beg)
(setq nmin 0)
(setq nmax (1+ nmax))
(setq n-no-remove nmax))
(goto-char end)
(cl-loop for n from nmin to nmax do
(insert
;; Prepare clone.
(with-temp-buffer
(insert template)
(org-mode)
(goto-char (point-min))
(org-fold-show-subtree)
(and idprop (if org-clone-delete-id
(org-entry-delete nil "ID")
(org-id-get-create t)))
(unless (= n 0)
(while (re-search-forward org-clock-line-re nil t)
(delete-region (line-beginning-position)
(line-beginning-position 2)))
(goto-char (point-min))
(while (re-search-forward org-drawer-regexp nil t)
(org-remove-empty-drawer-at (point))))
(goto-char (point-min))
(when doshift
(while (re-search-forward org-ts-regexp-both nil t)
(org-timestamp-change (* n shift-n) shift-what))
(unless (= n n-no-remove)
(goto-char (point-min))
(while (re-search-forward org-ts-regexp nil t)
(save-excursion
(goto-char (match-beginning 0))
(when (looking-at "<[^<>\n]+\\( +[.+]?\\+[0-9]+[hdwmy]\\)")
(delete-region (match-beginning 1) (match-end 1)))))))
(buffer-string)))))
(goto-char beg)))
;;; Outline path
(defvar org-outline-path-cache nil
"Alist between buffer positions and outline paths.
It value is an alist (POSITION . PATH) where POSITION is the
buffer position at the beginning of an entry and PATH is a list
of strings describing the outline path for that entry, in reverse
order.")
(defun org--get-outline-path-1 (&optional use-cache)
"Return outline path to current headline.
Outline path is a list of strings, in reverse order. When
optional argument USE-CACHE is non-nil, make use of a cache. See
`org-get-outline-path' for details.
Assume buffer is widened and point is on a headline."
(or (and use-cache (cdr (assq (point) org-outline-path-cache)))
(let ((p (point))
(heading (let ((case-fold-search nil))
(looking-at org-complex-heading-regexp)
(if (not (match-end 4)) ""
;; Remove statistics cookies.
(org-trim
(org-link-display-format
(replace-regexp-in-string
"\\[[0-9]+%\\]\\|\\[[0-9]+/[0-9]+\\]" ""
(match-string-no-properties 4))))))))
(when (org-element-property :commentedp (org-element-at-point))
(setq heading (replace-regexp-in-string (format "^%s[ \t]*" org-comment-string) "" heading)))
(if (org-up-heading-safe)
(let ((path (cons heading (org--get-outline-path-1 use-cache))))
(when use-cache
(push (cons p path) org-outline-path-cache))
path)
;; This is a new root node. Since we assume we are moving
;; forward, we can drop previous cache so as to limit number
;; of associations there.
(let ((path (list heading)))
(when use-cache (setq org-outline-path-cache (list (cons p path))))
path)))))
(defun org-get-outline-path (&optional with-self use-cache)
"Return the outline path to the current entry.
An outline path is a list of ancestors for current headline, as
a list of strings. Statistics cookies are removed and links are
replaced with their description, if any, or their path otherwise.
When optional argument WITH-SELF is non-nil, the path also
includes the current headline.
When optional argument USE-CACHE is non-nil, cache outline paths
between calls to this function so as to avoid backtracking. This
argument is useful when planning to find more than one outline
path in the same document. In that case, there are two
conditions to satisfy:
- `org-outline-path-cache' is set to nil before starting the
process;
- outline paths are computed by increasing buffer positions."
(org-with-wide-buffer
(and (or (and with-self (org-back-to-heading t))
(org-up-heading-safe))
(reverse (org--get-outline-path-1 use-cache)))))
(defun org-format-outline-path (path &optional width prefix separator)
"Format the outline path PATH for display.
WIDTH is the maximum number of characters that is available.
PREFIX is a prefix to be included in the returned string,
such as the file name.
SEPARATOR is inserted between the different parts of the path,
the default is \"/\"."
(setq width (or width 79))
(setq path (delq nil path))
(unless (> width 0)
(user-error "Argument `width' must be positive"))
(setq separator (or separator "/"))
(let* ((org-odd-levels-only nil)
(fpath (concat
prefix (and prefix path separator)
(mapconcat
(lambda (s) (replace-regexp-in-string "[ \t]+\\'" "" s))
(cl-loop for head in path
for n from 0
collect (org-add-props
head nil 'face
(nth (% n org-n-level-faces) org-level-faces)))
separator))))
(when (> (length fpath) width)
(if (< width 7)
;; It's unlikely that `width' will be this small, but don't
;; waste characters by adding ".." if it is.
(setq fpath (substring fpath 0 width))
(setf (substring fpath (- width 2)) "..")))
fpath))
(defun org-get-title (&optional buffer-or-file)
"Collect title from the provided `org-mode' BUFFER-OR-FILE.
Returns nil if there are no #+TITLE property."
(let ((buffer (cond ((bufferp buffer-or-file) buffer-or-file)
((stringp buffer-or-file) (find-file-noselect
buffer-or-file))
(t (current-buffer)))))
(with-current-buffer buffer
(org-macro-initialize-templates)
(let ((title (assoc-default "title" org-macro-templates)))
(unless (string= "" title)
title)))))
(defun org-display-outline-path (&optional file-or-title current separator just-return-string)
"Display the current outline path in the echo area.
If FILE-OR-TITLE is `title', prepend outline with file title. If
it is non-nil or title is not present in document, prepend
outline path with the file name.
If CURRENT is non-nil, append the current heading to the output.
SEPARATOR is passed through to `org-format-outline-path'. It separates
the different parts of the path and defaults to \"/\".
If JUST-RETURN-STRING is non-nil, return a string, don't display a message."
(interactive "P")
(let* (case-fold-search
(bfn (buffer-file-name (buffer-base-buffer)))
(title-prop (when (eq file-or-title 'title) (org-get-title)))
(path (and (derived-mode-p 'org-mode) (org-get-outline-path)))
res)
(when current (setq path (append path
(save-excursion
(org-back-to-heading t)
(when (looking-at org-complex-heading-regexp)
(list (match-string 4)))))))
(setq res
(org-format-outline-path
path
(1- (frame-width))
(and file-or-title bfn (concat (if (and (eq file-or-title 'title) title-prop)
title-prop
(file-name-nondirectory bfn))
separator))
separator))
(add-face-text-property 0 (length res)
`(:height ,(face-attribute 'default :height))
nil res)
(if just-return-string
res
(org-unlogged-message "%s" res))))
;;; Outline Sorting
(defun org-sort (&optional with-case)
"Call `org-sort-entries', `org-table-sort-lines' or `org-sort-list'.
Optional argument WITH-CASE means sort case-sensitively."
(interactive "P")
(org-call-with-arg
(cond ((org-at-table-p) #'org-table-sort-lines)
((org-at-item-p) #'org-sort-list)
(t #'org-sort-entries))
with-case))
(defun org-sort-remove-invisible (s)
"Remove emphasis markers and any invisible property from string S.
Assume S may contain only objects."
;; org-element-interpret-data clears any text property, including
;; invisible part.
(org-element-interpret-data
(let ((tree (org-element-parse-secondary-string
s (org-element-restriction 'paragraph))))
(org-element-map tree '(bold code italic link strike-through underline verbatim)
(lambda (o)
(pcase (org-element-type o)
;; Terminal object. Replace it with its value.
((or `code `verbatim)
(let ((new (org-element-property :value o)))
(org-element-insert-before new o)
(org-element-put-property
new :post-blank (org-element-post-blank o))))
;; Non-terminal objects. Splice contents.
(type
(let ((contents
(or (org-element-contents o)
(and (eq type 'link)
(list (org-element-property :raw-link o)))))
(c nil))
(while contents
(setq c (pop contents))
(org-element-insert-before c o))
(org-element-put-property
c :post-blank (org-element-post-blank o)))))
(org-element-extract o)))
;; Return modified tree.
tree)))
(defvar org-after-sorting-entries-or-items-hook nil
"Hook that is run after a bunch of entries or items have been sorted.
When children are sorted, the cursor is in the parent line when this
hook gets called. When a region or a plain list is sorted, the cursor
will be in the first entry of the sorted region/list.")
(defun org-sort-entries
(&optional with-case sorting-type getkey-func compare-func property
interactive?)
"Sort entries on a certain level of an outline tree.
If there is an active region, the entries in the region are sorted.
Else, if the cursor is before the first entry, sort the top-level items.
Else, the children of the entry at point are sorted.
Sorting can be alphabetically, numerically, by date/time as given by
a time stamp, by a property, by priority order, or by a custom function.
The command prompts for the sorting type unless it has been given to the
function through the SORTING-TYPE argument, which needs to be a character,
\(?n ?N ?a ?A ?t ?T ?s ?S ?d ?D ?p ?P ?o ?O ?r ?R ?f ?F ?k ?K). Here is
the precise meaning of each character:
a Alphabetically, ignoring the TODO keyword and the priority, if any.
c By creation time, which is assumed to be the first inactive time stamp
at the beginning of a line.
d By deadline date/time.
k By clocking time.
n Numerically, by converting the beginning of the entry/item to a number.
o By order of TODO keywords.
p By priority according to the cookie.
r By the value of a property.
s By scheduled date/time.
t By date/time, either the first active time stamp in the entry, or, if
none exist, by the first inactive one.
Capital letters will reverse the sort order.
If the SORTING-TYPE is ?f or ?F, then GETKEY-FUNC specifies a function to be
called with point at the beginning of the record. It must return a
value that is compatible with COMPARE-FUNC, the function used to
compare entries.
Comparing entries ignores case by default. However, with an optional argument
WITH-CASE, the sorting considers case as well.
Sorting is done against the visible part of the headlines, it ignores hidden
links.
When sorting is done, call `org-after-sorting-entries-or-items-hook'.
A non-nil value for INTERACTIVE? is used to signal that this
function is being called interactively."
(interactive (list current-prefix-arg nil nil nil nil t))
(let ((case-func (if with-case 'identity 'downcase))
start beg end stars re re2
txt what tmp)
;; Find beginning and end of region to sort
(cond
((org-region-active-p)
(setq start (region-beginning)
end (region-end))
;; we will sort the region
;; Limit the region to full headings.
(goto-char start)
;; Move to beginning of heading.
;; If we are inside heading, move to next.
;; If we are on heading, move to its begin position.
(if (org-at-heading-p)
(forward-line 0)
(outline-next-heading))
(setq start (point))
;; Extend region end beyond the last subtree.
(goto-char end)
(org-end-of-subtree nil t)
(setq end (point)
what "region")
(goto-char start))
((or (org-at-heading-p)
(ignore-errors (progn (org-back-to-heading) t)))
;; we will sort the children of the current headline
(org-back-to-heading)
(setq start (point)
end (progn (org-end-of-subtree t t)
(or (bolp) (insert "\n"))
(when (>= (org-back-over-empty-lines) 1)
(forward-line 1))
(point))
what "children")
(goto-char start)
(org-fold-show-subtree)
(outline-next-heading))
(t
;; we will sort the top-level entries in this file
(goto-char (point-min))
(or (org-at-heading-p) (outline-next-heading))
(setq start (point))
(goto-char (point-max))
(forward-line 0)
(when (looking-at ".*?\\S-")
;; File ends in a non-white line
(end-of-line 1)
(insert "\n"))
(setq end (point-max))
(setq what "top-level")
(goto-char start)
(org-fold-show-all '(headings drawers blocks))))
(setq beg (point))
(when (>= beg end) (goto-char start) (user-error "Nothing to sort"))
(looking-at "\\(\\*+\\)")
(setq stars (match-string 1)
re (concat "^" (regexp-quote stars) " +")
re2 (concat "^" (regexp-quote (substring stars 0 -1)) "[ \t\n]")
txt (buffer-substring beg end))
(unless (equal (substring txt -1) "\n") (setq txt (concat txt "\n")))
(when (and (not (equal stars "*")) (string-match re2 txt))
(user-error "Region to sort contains a level above the first entry"))
(unless sorting-type
(message
"Sort %s: [a]lpha [n]umeric [p]riority p[r]operty todo[o]rder [f]unc
[t]ime [s]cheduled [d]eadline [c]reated cloc[k]ing
A/N/P/R/O/F/T/S/D/C/K means reversed:"
what)
(setq sorting-type (read-char-exclusive)))
(unless getkey-func
(and (= (downcase sorting-type) ?f)
(setq getkey-func
(or (and interactive?
(org-read-function
"Function for extracting keys: "))
(error "Missing key extractor")))))
(and (= (downcase sorting-type) ?r)
(not property)
(setq property
(completing-read "Property: "
(mapcar #'list (org-buffer-property-keys t))
nil t)))
(when (member sorting-type '(?k ?K)) (org-clock-sum))
(message "Sorting entries...")
(save-restriction
(narrow-to-region start end)
;; No trailing newline - add one to avoid
;; * heading
;; text* another heading
(save-excursion
(goto-char end)
(unless (bolp) (insert "\n")))
(let ((restore-clock?
;; The clock marker is lost when using `sort-subr'; mark
;; the clock with temporary `:org-clock-marker-backup'
;; text property.
(when (and (eq (org-clocking-buffer) (current-buffer))
(<= start (marker-position org-clock-marker))
(>= end (marker-position org-clock-marker)))
(with-silent-modifications
(put-text-property (1- org-clock-marker) org-clock-marker
:org-clock-marker-backup t))
t))
(dcst (downcase sorting-type))
(case-fold-search nil)
(now (current-time)))
(org-preserve-local-variables
(sort-subr
(/= dcst sorting-type)
;; This function moves to the beginning character of the
;; "record" to be sorted.
(lambda nil
(if (re-search-forward re nil t)
(goto-char (match-beginning 0))
(goto-char (point-max))))
;; This function moves to the last character of the "record" being
;; sorted.
(lambda nil
(save-match-data
(condition-case nil
(outline-forward-same-level 1)
(error
(goto-char (point-max))))))
;; This function returns the value that gets sorted against.
(lambda ()
(cond
((= dcst ?n)
(string-to-number
(org-sort-remove-invisible (org-get-heading t t t t))))
((= dcst ?a)
(funcall case-func
(org-sort-remove-invisible (org-get-heading t t t t))))
((= dcst ?k)
(or (get-text-property (point) :org-clock-minutes) 0))
((= dcst ?t)
(let ((end (save-excursion (outline-next-heading) (point))))
(if (or (re-search-forward org-ts-regexp end t)
(re-search-forward org-ts-regexp-both end t))
(org-time-string-to-seconds (match-string 0))
(float-time now))))
((= dcst ?c)
(let ((end (save-excursion (outline-next-heading) (point))))
(if (re-search-forward
(concat "^[ \t]*\\[" org-ts-regexp1 "\\]")
end t)
(org-time-string-to-seconds (match-string 0))
(float-time now))))
((= dcst ?s)
(let ((end (save-excursion (outline-next-heading) (point))))
(if (re-search-forward org-scheduled-time-regexp end t)
(org-time-string-to-seconds (match-string 1))
(float-time now))))
((= dcst ?d)
(let ((end (save-excursion (outline-next-heading) (point))))
(if (re-search-forward org-deadline-time-regexp end t)
(org-time-string-to-seconds (match-string 1))
(float-time now))))
((= dcst ?p)
(if (re-search-forward org-priority-regexp (line-end-position) t)
(string-to-char (match-string 2))
org-priority-default))
((= dcst ?r)
(or (org-entry-get nil property) ""))
((= dcst ?o)
(when (looking-at org-complex-heading-regexp)
(let* ((m (match-string 2))
(s (if (member m org-done-keywords) '- '+)))
(- 99 (funcall s (length (member m org-todo-keywords-1)))))))
((= dcst ?f)
(if getkey-func
(progn
(setq tmp (funcall getkey-func))
(when (stringp tmp) (setq tmp (funcall case-func tmp)))
tmp)
(error "Invalid key function `%s'" getkey-func)))
(t (error "Invalid sorting type `%c'" sorting-type))))
nil
(cond
((= dcst ?a) #'org-string<)
((= dcst ?f)
(or compare-func
(and interactive?
(org-read-function
(concat "Function for comparing keys "
"(empty for default `sort-subr' predicate): ")
'allow-empty))))
((member dcst '(?p ?t ?s ?d ?c ?k)) '<))))
(org-cycle-hide-drawers 'all)
(when restore-clock?
(move-marker org-clock-marker
(1+ (next-single-property-change
start :org-clock-marker-backup)))
(remove-text-properties (1- org-clock-marker) org-clock-marker
'(:org-clock-marker-backup t)))))
(run-hooks 'org-after-sorting-entries-or-items-hook)
(message "Sorting entries...done")))
(defun org-contextualize-keys (alist contexts)
"Return valid elements in ALIST depending on CONTEXTS.
`org-agenda-custom-commands' or `org-capture-templates' are the
values used for ALIST, and `org-agenda-custom-commands-contexts'
or `org-capture-templates-contexts' are the associated contexts
definitions."
(let ((contexts
;; normalize contexts
(mapcar
(lambda(c) (cond ((listp (cadr c))
(list (car c) (car c) (nth 1 c)))
((string= "" (cadr c))
(list (car c) (car c) (nth 2 c)))
(t c)))
contexts))
(a alist) r s)
;; loop over all commands or templates
(dolist (c a)
(let (vrules repl)
(cond
((not (assoc (car c) contexts))
(push c r))
((and (assoc (car c) contexts)
(setq vrules (org-contextualize-validate-key
(car c) contexts)))
(mapc (lambda (vr)
(unless (equal (car vr) (cadr vr))
(setq repl vr)))
vrules)
(if (not repl) (push c r)
(push (cadr repl) s)
(push
(cons (car c)
(cdr (or (assoc (cadr repl) alist)
(error "Undefined key `%s' as contextual replacement for `%s'"
(cadr repl) (car c)))))
r))))))
;; Return limited ALIST, possibly with keys modified, and deduplicated
(delq
nil
(delete-dups
(mapcar (lambda (x)
(let ((tpl (car x)))
(unless (delq
nil
(mapcar (lambda (y)
(equal y tpl))
s))
x)))
(reverse r))))))
(defun org-contextualize-validate-key (key contexts)
"Check CONTEXTS for agenda or capture KEY."
(let (res)
(dolist (r contexts)
(dolist (rr (car (last r)))
(when
(and (equal key (car r))
(if (functionp rr) (funcall rr)
(or (and (eq (car rr) 'in-file)
(buffer-file-name)
(string-match (cdr rr) (buffer-file-name)))
(and (eq (car rr) 'in-mode)
(string-match (cdr rr) (symbol-name major-mode)))
(and (eq (car rr) 'in-buffer)
(string-match (cdr rr) (buffer-name)))
(when (and (eq (car rr) 'not-in-file)
(buffer-file-name))
(not (string-match (cdr rr) (buffer-file-name))))
(when (eq (car rr) 'not-in-mode)
(not (string-match (cdr rr) (symbol-name major-mode))))
(when (eq (car rr) 'not-in-buffer)
(not (string-match (cdr rr) (buffer-name)))))))
(push r res))))
(delete-dups (delq nil res))))
;; Defined to provide a value for defcustom, since there is no
;; string-collate-greaterp in Emacs.
(defun org-string-collate-greaterp (s1 s2)
"Return non-nil if S1 is greater than S2 in collation order."
(not (string-collate-lessp s1 s2)))
;;;###autoload
(defun org-run-like-in-org-mode (cmd)
"Run a command, pretending that the current buffer is in Org mode.
This will temporarily bind local variables that are typically bound in
Org mode to the values they have in Org mode, and then interactively
call CMD."
(org-load-modules-maybe)
(let (vars vals)
(dolist (var (org-get-local-variables))
(when (or (not (boundp (car var)))
(eq (symbol-value (car var))
(default-value (car var))))
(push (car var) vars)
(push (cadr var) vals)))
(cl-progv vars vals
(call-interactively cmd))))
(defun org-get-category (&optional pos _)
"Get the category applying to position POS.
Return \"???\" when no category is set.
This function may modify the match data."
;; Sync cache.
(or (org-entry-get-with-inheritance
"CATEGORY" nil (or pos (point)))
"???"))
;;; Refresh properties
(defun org-refresh-properties (dprop tprop)
"Refresh buffer text properties.
DPROP is the drawer property and TPROP is either the
corresponding text property to set, or an alist with each element
being a text property (as a symbol) and a function to apply to
the value of the drawer property."
(let* ((case-fold-search t)
(inhibit-read-only t)
(inherit? (org-property-inherit-p dprop))
(property-re (org-re-property (concat (regexp-quote dprop) "\\+?") t))
(global-or-keyword (and inherit?
(org--property-global-or-keyword-value dprop nil))))
(with-silent-modifications
(org-with-point-at 1
;; Set global and keyword based values to the whole buffer.
(when global-or-keyword
(put-text-property (point-min) (point-max) tprop global-or-keyword))
;; Set values based on property-drawers throughout the document.
(while (re-search-forward property-re nil t)
(when (org-at-property-p)
(org-refresh-property tprop (org-entry-get (point) dprop) inherit?))
(outline-next-heading))))))
(defun org-refresh-property (tprop p &optional inherit)
"Refresh the buffer text property TPROP from the drawer property P.
The refresh happens only for the current entry, or the whole
sub-tree if optional argument INHERIT is non-nil.
If point is before first headline, the function applies to the
part before the first headline. In that particular case, when
optional argument INHERIT is non-nil, it refreshes properties for
the whole buffer."
(save-excursion
(org-back-to-heading-or-point-min t)
(let ((start (point))
(end (save-excursion
(cond ((and inherit (org-before-first-heading-p))
(point-max))
(inherit
(org-end-of-subtree t t))
((outline-next-heading))
((point-max))))))
(with-silent-modifications
(if (symbolp tprop)
;; TPROP is a text property symbol.
(put-text-property start end tprop p)
;; TPROP is an alist with (property . function) elements.
(pcase-dolist (`(,prop . ,f) tprop)
(put-text-property start end prop (funcall f p))))))))
(defun org-refresh-category-properties ()
"Refresh category text properties in the buffer."
(let ((case-fold-search t)
(inhibit-read-only t)
(default-category
(cond ((null org-category)
(if buffer-file-name
(file-name-sans-extension
(file-name-nondirectory buffer-file-name))
"???"))
((symbolp org-category) (symbol-name org-category))
(t org-category))))
(let ((category (catch 'buffer-category
(org-with-wide-buffer
(goto-char (point-max))
(while (re-search-backward "^[ \t]*#\\+CATEGORY:" (point-min) t)
(let ((element (org-element-at-point-no-context)))
(when (org-element-type-p element 'keyword)
(throw 'buffer-category
(org-element-property :value element))))))
default-category)))
(with-silent-modifications
(org-with-wide-buffer
;; Set buffer-wide property from keyword. Search last #+CATEGORY
;; keyword. If none is found, fall-back to `org-category' or
;; buffer file name, or set it by the document property drawer.
(put-text-property (point-min) (point-max)
'org-category category)
;; Set categories from the document property drawer or
;; property drawers in the outline. If category is found in
;; the property drawer for the whole buffer that value
;; overrides the keyword-based value set above.
(goto-char (point-min))
(let ((regexp (org-re-property "CATEGORY")))
(while (re-search-forward regexp nil t)
(let ((value (match-string-no-properties 3)))
(when (org-at-property-p)
(put-text-property
(save-excursion (org-back-to-heading-or-point-min t))
(save-excursion (if (org-before-first-heading-p)
(point-max)
(org-end-of-subtree t t)))
'org-category
value))))))))))
(defun org-refresh-stats-properties ()
"Refresh stats text properties in the buffer."
(with-silent-modifications
(org-with-point-at 1
(let ((regexp (concat org-outline-regexp-bol
".*\\[\\([0-9]*\\)\\(?:%\\|/\\([0-9]*\\)\\)\\]")))
(while (re-search-forward regexp nil t)
(let* ((numerator (string-to-number (match-string 1)))
(denominator (and (match-end 2)
(string-to-number (match-string 2))))
(stats (cond ((not denominator) numerator) ;percent
((= denominator 0) 0)
(t (/ (* numerator 100) denominator)))))
(put-text-property (point) (progn (org-end-of-subtree t t) (point))
'org-stats stats)))))))
(defun org-refresh-effort-properties ()
"Refresh effort properties."
(org-refresh-properties
org-effort-property
'((effort . identity)
(effort-minutes . org-duration-to-minutes))))
(defun org-find-file-at-mouse (ev)
"Open file link or URL at mouse."
(interactive "e")
(mouse-set-point ev)
(org-open-at-point 'in-emacs))
(defun org-open-at-mouse (ev)
"Open file link or URL at mouse.
See the docstring of `org-open-file' for details."
(interactive "e")
(mouse-set-point ev)
(when (eq major-mode 'org-agenda-mode)
(org-agenda-copy-local-variable 'org-link-abbrev-alist-local))
;; FIXME: This feature is actually unreliable - if we are in non-Org
;; buffer and the link happens to be inside what Org parser
;; recognizes as verbarim (for exampe, src block),
;; `org-open-at-point' will do nothing.
;; We might have used `org-open-at-point-global' instead, but it is
;; not exactly the same. For example, it will have no way to open
;; link abbreviations. So, suppressing parser complains about
;; non-Org buffer to keep the feature working at least to the extent
;; it did before.
(require 'warnings) ; Emacs <30
(defvar warning-suppress-types) ; warnings.el
(let ((warning-suppress-types
(cons '(org-element org-element-parser)
warning-suppress-types)))
;; FIXME: Suppress warning in Emacs <30
;; (ignore warning-suppress-types)
(org-open-at-point)))
(defvar org-window-config-before-follow-link nil
"The window configuration before following a link.
This is saved in case the need arises to restore it.")
(defun org--file-default-apps ()
"Return the default applications for this operating system."
(pcase system-type
(`darwin org-file-apps-macos)
(`windows-nt org-file-apps-windowsnt)
(_ org-file-apps-gnu)))
(defun org--file-apps-entry-locator-p (entry)
"Non-nil if ENTRY should be matched against the link by `org-open-file'.
It assumes that is the case when the entry uses a regular
expression which has at least one grouping construct and the
action is either a Lisp form or a command string containing
\"%1\", i.e., using at least one subexpression match as
a parameter."
(pcase entry
(`(,selector . ,action)
(and (stringp selector)
(> (regexp-opt-depth selector) 0)
(or (and (stringp action)
(string-match "%[0-9]" action))
(functionp action))))
(_ nil)))
(defun org--file-apps-regexp-alist (list &optional add-auto-mode)
"Convert extensions to regular expressions in the cars of LIST.
Also, weed out any non-string entries, because the return value
is used only for regexp matching.
When ADD-AUTO-MODE is non-nil, make all matches in `auto-mode-alist'
point to the symbol `emacs', indicating that the file should be
opened in Emacs."
(append
(delq nil
(mapcar (lambda (x)
(unless (not (stringp (car x)))
(if (string-match "\\W" (car x))
x
(cons (concat "\\." (car x) "\\'") (cdr x)))))
list))
(when add-auto-mode
(mapcar (lambda (x) (cons (car x) 'emacs)) auto-mode-alist))))
(defun org--open-file-format-command
(mailcap-command file link match-data)
"Format MAILCAP-COMMAND to launch viewer for the FILE.
MAILCAP-COMMAND may be an entry from the `org-file-apps' list or viewer
field from mailcap file loaded to `mailcap-mime-data'. See \"RFC
1524. A User Agent Configuration Mechanism For Multimedia Mail Format
Information\" (URL `https://www.rfc-editor.org/rfc/rfc1524.html') for
details, man page `mailcap(5)' for brief summary, and Info node
`(emacs-mime) mailcap' for specific related to Emacs. Only a part of
mailcap specification is supported.
The following substitutions are interpolated in the MAILCAP-COMMAND
string:
- \"%s\" to FILE name passed through
`convert-standard-filename', so it must be absolute path.
- \"%1\" to \"%9\" groups from MATCH-DATA found in the LINK string by
the regular expression in the key part of the `org-file-apps' entry.
(performed by caller). Not recommended, consider a lisp function
instead of a shell command. For example, the following link in an
Org file
<file:///usr/share/doc/bash/bashref.pdf::#Redirections::allocate a file>
may be handled by an `org-file-apps' entry like
(\"\\\\.pdf\\\\(?:\\\\.[gx]z\\\\|\\\\.bz2\\\\)?::\\\\(#[^:]+\\\\)::\\\\(.+\\\\)\\\\\\='\"
. \"okular --find %2 %s%1\")
Use backslash \"\\\" to quote percent \"%\" or any other character
including backslash itself.
In addition, each argument is passed through `shell-quote-argument',
so quotes around substitutions should not be used. For compliance
with mailcap files shipped e.g. in Debian GNU/Linux, single or double
quotes around substitutions are stripped. It deviates from mailcap
specification that requires file name to be safe for shell and for the
application."
(let ((spec (list (cons ?s (convert-standard-filename file))))
(ngroups (min 9 (- (/ (length match-data) 2) 1))))
(when (> ngroups 0)
(set-match-data match-data)
(dolist (i (number-sequence 1 ngroups))
(push (cons (+ ?0 i) (match-string-no-properties i link)) spec)))
(replace-regexp-in-string
(rx (or (and "\\" (or (group anything) string-end))
(and (optional (group (any "'\"")))
"%"
(or (group anything) string-end)
(optional (group (backref 2))))))
(lambda (fmt)
(let* ((backslash (match-string-no-properties 1 fmt))
(key (match-string 3 fmt))
(value (and key (alist-get (string-to-char key) spec))))
(cond
(backslash)
(value (let ((quot (match-string 2 fmt))
(subst (shell-quote-argument value)))
;; Remove quotes around the file name - we use
;; `shell-quote-argument'.
(if (match-string 4 fmt)
subst
(concat quot subst))))
(t (error "Invalid format `%s'" fmt)))))
mailcap-command nil 'literal)))
;;;###autoload
(defun org-open-file (path &optional in-emacs line search)
"Open the file at PATH.
First, this expands any special file name abbreviations. Then the
configuration variable `org-file-apps' is checked if it contains an
entry for this file type, and if yes, the corresponding command is launched.
If no application is found, Emacs simply visits the file.
With optional prefix argument IN-EMACS, Emacs will visit the file.
With a double \\[universal-argument] \\[universal-argument] \
prefix arg, Org tries to avoid opening in Emacs
and to use an external application to visit the file.
Optional LINE specifies a line to go to, optional SEARCH a string
to search for. If LINE or SEARCH is given, the file will be
opened in Emacs, unless an entry from `org-file-apps' that makes
use of groups in a regexp matches.
If you want to change the way frames are used when following a
link, please customize `org-link-frame-setup'.
If the file does not exist, throw an error."
(let* ((file (if (equal path "") buffer-file-name
(substitute-in-file-name (expand-file-name path))))
(file-apps (append org-file-apps (org--file-default-apps)))
(apps (cl-remove-if #'org--file-apps-entry-locator-p file-apps))
(apps-locator (cl-remove-if-not #'org--file-apps-entry-locator-p
file-apps))
(remp (and (assq 'remote apps) (file-remote-p file)))
(dirp (unless remp (file-directory-p file)))
(file (if (and dirp org-open-directory-means-index-dot-org)
(concat (file-name-as-directory file) "index.org")
file))
(a-m-a-p (assq 'auto-mode apps))
(dfile (downcase file))
;; Reconstruct the original link from the PATH, LINE and
;; SEARCH args.
(link (cond (line (concat file "::" (number-to-string line)))
(search (concat file "::" search))
(t file)))
(ext
(and (string-match "\\`.*?\\.\\([a-zA-Z0-9]+\\(\\.gz\\)?\\)\\'" dfile)
(match-string 1 dfile)))
(save-position-maybe
(let ((old-buffer (current-buffer))
(old-pos (point))
(old-mode major-mode))
(lambda ()
(and (derived-mode-p 'org-mode)
(eq old-mode 'org-mode)
(or (not (eq old-buffer (current-buffer)))
(not (eq old-pos (point))))
(org-mark-ring-push old-pos old-buffer)))))
cmd link-match-data)
(cond
((member in-emacs '((16) system))
(setq cmd (cdr (assq 'system apps))))
(in-emacs (setq cmd 'emacs))
(t
(setq cmd (or (and remp (cdr (assq 'remote apps)))
(and dirp (cdr (assq 'directory apps)))
;; First, try matching against apps-locator if we
;; get a match here, store the match data for
;; later.
(let* ((case-fold-search t)
(match (assoc-default link apps-locator
'string-match)))
(if match
(progn (setq link-match-data (match-data))
match)
(progn (setq in-emacs (or in-emacs line search))
nil))) ; if we have no match in apps-locator,
; always open the file in emacs if line or search
; is given (for backwards compatibility)
(assoc-default dfile
(org--file-apps-regexp-alist apps a-m-a-p)
'string-match)
(cdr (assoc ext apps))
(cdr (assq t apps))))))
(when (eq cmd 'system)
(setq cmd (cdr (assq 'system apps))))
(when (eq cmd 'default)
(setq cmd (cdr (assoc t apps))))
(when (eq cmd 'mailcap)
(require 'mailcap)
(mailcap-parse-mailcaps)
(let* ((mime-type (mailcap-extension-to-mime (or ext "")))
(command (mailcap-mime-info mime-type)))
(if (stringp command)
(setq cmd command)
(setq cmd 'emacs))))
(when (and (not (eq cmd 'emacs)) ; Emacs has no problems with non-ex files
(not (file-exists-p file))
(not org-open-non-existing-files))
(user-error "No such file: %s" file))
(cond
((org-string-nw-p cmd)
(setq cmd (org--open-file-format-command cmd file link link-match-data))
(save-window-excursion
(message "Running %s...done" cmd)
;; Handlers such as "gio open" and kde-open5 start viewer in background
;; and exit immediately. Use pipe connection type instead of pty to
;; avoid killing children processes with SIGHUP when temporary terminal
;; session is finished.
;;
;; TODO: Once minimum Emacs version is 25.1 or above, consider using
;; the `make-process' invocation from 5db61eb0f929 to get more helpful
;; error messages.
(let ((process-connection-type nil))
(start-process-shell-command cmd nil cmd))
(and (boundp 'org-wait) (numberp org-wait) (sit-for org-wait))))
((or (stringp cmd)
(eq cmd 'emacs))
(funcall (cdr (assq 'file org-link-frame-setup)) file)
(widen)
(cond (line (org-goto-line line)
(when (derived-mode-p 'org-mode) (org-fold-reveal)))
(search (condition-case err
(org-link-search search)
;; Save position before error-ing out so user
;; can easily move back to the original buffer.
(error (funcall save-position-maybe)
(error "%s" (error-message-string err)))))))
((functionp cmd)
(save-match-data
(set-match-data link-match-data)
(condition-case nil
(funcall cmd file link)
;; FIXME: Remove this check when most default installations
;; of Emacs have at least Org 9.0.
((debug wrong-number-of-arguments wrong-type-argument
invalid-function)
(user-error "Please see Org News for version 9.0 about \
`org-file-apps'--Lisp error: %S" cmd)))))
((consp cmd)
;; FIXME: Remove this check when most default installations of
;; Emacs have at least Org 9.0. Heads-up instead of silently
;; fall back to `org-link-frame-setup' for an old usage of
;; `org-file-apps' with sexp instead of a function for `cmd'.
(user-error "Please see Org News for version 9.0 about \
`org-file-apps'--Error: Deprecated usage of %S" cmd))
(t (funcall (cdr (assq 'file org-link-frame-setup)) file)))
(funcall save-position-maybe)))
;;;###autoload
(defun org-open-at-point-global ()
"Follow a link or a timestamp like Org mode does.
Also follow links and emails as seen by `thing-at-point'.
This command can be called in any mode to follow an external
link or a timestamp that has Org mode syntax. Its behavior
is undefined when called on internal links like fuzzy links.
Raise a user error when there is nothing to follow."
(interactive)
(let ((tap-url (thing-at-point 'url))
(tap-email (thing-at-point 'email)))
(cond ((org-in-regexp
org-link-any-re
(let ((origin (point)))
(max
(save-excursion
(backward-paragraph)
(count-lines (point) origin))
(save-excursion
(forward-paragraph)
(count-lines origin (point))))))
(org-link-open-from-string (match-string-no-properties 0)))
((or (org-in-regexp org-ts-regexp-both nil t)
(org-in-regexp org-tsr-regexp-both nil t))
(org-follow-timestamp-link))
(tap-url (org-link-open-from-string tap-url))
(tap-email (org-link-open-from-string
(concat "mailto:" tap-email)))
(t (user-error "No link found")))))
(defvar org-open-at-point-functions nil
"Hook that is run when following a link at point.
Functions in this hook must return t if they identify and follow
a link at point. If they don't find anything interesting at point,
they must return nil.")
(defun org-open-at-point (&optional arg)
"Open thing at point.
The thing can be a link, citation, timestamp, footnote, src-block or
tags.
When point is on a link, follow it. Normally, files will be opened by
an appropriate application (see `org-file-apps'). If the optional prefix
argument ARG is non-nil, Emacs will visit the file. With a double
prefix argument, try to open outside of Emacs, in the application the
system uses for this file type.
When point is on a timestamp, open the agenda at the day
specified.
When point is a footnote definition, move to the first reference
found. If it is on a reference, move to the associated
definition.
When point is on a src-block or inline src-block, open its result.
When point is on a citation, follow it.
When point is on a headline, display a list of every link in the
entry, so it is possible to pick one, or all, of them. If point
is on a tag, call `org-tags-view' instead.
On top of syntactically correct links, this function also tries
to open links and timestamps in comments, node properties, and
keywords if point is on something looking like a timestamp or
a link."
(interactive "P")
(org-load-modules-maybe)
(setq org-window-config-before-follow-link (current-window-configuration))
(org-remove-occur-highlights nil nil t)
(unless (run-hook-with-args-until-success 'org-open-at-point-functions)
(let* ((context
;; Only consider supported types, even if they are not the
;; closest one.
(org-element-lineage
(org-element-context)
'(citation citation-reference clock comment comment-block
footnote-definition footnote-reference headline
inline-src-block inlinetask keyword link node-property
planning src-block timestamp)
t))
(type (org-element-type context))
(value (org-element-property :value context)))
(cond
((not type) (user-error "No link found"))
;; No valid link at point. For convenience, look if something
;; looks like a link under point in some specific places.
((memq type '(comment comment-block node-property keyword))
(call-interactively #'org-open-at-point-global))
;; On a headline or an inlinetask, but not on a timestamp,
;; a link, a footnote reference or a citation.
((memq type '(headline inlinetask))
(org-match-line org-complex-heading-regexp)
(let ((tags-beg (match-beginning 5))
(tags-end (match-end 5)))
(if (and tags-beg (>= (point) tags-beg) (< (point) tags-end))
;; On tags.
(org-tags-view
arg
(save-excursion
(let* ((beg-tag (or (search-backward ":" tags-beg 'at-limit) (point)))
(end-tag (search-forward ":" tags-end nil 2)))
(buffer-substring (1+ beg-tag) (1- end-tag)))))
;; Not on tags.
(pcase (org-offer-links-in-entry (current-buffer) (point) arg)
(`(nil . ,_)
(require 'org-attach)
(when (org-attach-dir)
(message "Opening attachment")
(if (equal arg '(4))
(org-attach-reveal-in-emacs)
(org-attach-reveal))))
(`(,links . ,links-end)
(let ((link-marker (make-marker))
(last-moved-marker (point-marker)))
(dolist (link (if (stringp links) (list links) links))
(search-forward link nil links-end)
(goto-char (match-beginning 0))
(move-marker link-marker (point))
(save-excursion
(org-open-at-point arg)
(unless (equal (point-marker) link-marker)
(move-marker last-moved-marker (point-marker)))))
;; If any of the links moved point in current buffer,
;; move to the point corresponding to such latest link.
;; Otherwise, restore the original point position.
(goto-char last-moved-marker)))))))
;; On a footnote reference or at definition's label.
((or (eq type 'footnote-reference)
(and (eq type 'footnote-definition)
(save-excursion
;; Do not validate action when point is on the
;; spaces right after the footnote label, in order
;; to be on par with behavior on links.
(skip-chars-forward " \t")
(let ((begin
(org-element-contents-begin context)))
(if begin (< (point) begin)
(= (org-element-post-affiliated context)
(line-beginning-position)))))))
(org-footnote-action))
;; On a planning line. Check if we are really on a timestamp.
((and (eq type 'planning)
(org-in-regexp org-ts-regexp-both nil t))
(org-follow-timestamp-link))
;; On a clock line, make sure point is on the timestamp
;; before opening it.
((and (eq type 'clock)
value
(>= (point) (org-element-begin value))
(<= (point) (org-element-end value)))
(org-follow-timestamp-link))
((eq type 'src-block) (org-babel-open-src-block-result))
;; Do nothing on white spaces after an object.
((>= (point)
(save-excursion
(goto-char (org-element-end context))
(skip-chars-backward " \t")
(point)))
(user-error "No link found"))
((eq type 'inline-src-block) (org-babel-open-src-block-result))
((eq type 'timestamp) (org-follow-timestamp-link))
((eq type 'link) (org-link-open context arg))
((memq type '(citation citation-reference)) (org-cite-follow context arg))
(t (user-error "No link found")))))
(run-hook-with-args 'org-follow-link-hook))
;;;###autoload
(defun org-offer-links-in-entry (buffer marker &optional nth zero)
"Offer links in the current entry and return the selected link.
If there is only one link, return it.
If NTH is an integer, return the NTH link found.
If ZERO is a string, check also this string for a link, and if
there is one, return it."
(with-current-buffer buffer
(org-with-wide-buffer
(goto-char marker)
(let ((cnt ?0)
have-zero end links link c)
(when (and (stringp zero) (string-match org-link-bracket-re zero))
(push (match-string 0 zero) links)
(setq cnt (1- cnt) have-zero t))
(save-excursion
(org-back-to-heading t)
(setq end (save-excursion (outline-next-heading) (point)))
(while (re-search-forward org-link-any-re end t)
;; Only consider valid links or links openable via
;; `org-open-at-point'.
(when (org-element-type-p
(save-match-data (org-element-context))
'(link comment comment-block node-property keyword))
(push (match-string 0) links)))
(setq links (org-uniquify (reverse links))))
(cond
((null links)
(message "No links"))
((equal (length links) 1)
(setq link (car links)))
((and (integerp nth) (>= (length links) (if have-zero (1+ nth) nth)))
(setq link (nth (if have-zero nth (1- nth)) links)))
(t ; we have to select a link
(save-excursion
(save-window-excursion
;; We have no direct control over how
;; `with-output-to-temp-buffer' displays the buffer. Try
;; to gain more space, making sure that only the Org
;; buffer and the *Select link* buffer are displayed for
;; the duration of selection.
(ignore-errors (delete-other-windows))
(with-output-to-temp-buffer "*Select Link*"
(dolist (l links)
(cond
((not (string-match org-link-bracket-re l))
(princ (format "[%c] %s\n" (cl-incf cnt)
(org-unbracket-string "<" ">" l))))
((match-end 2)
(princ (format "[%c] %s (%s)\n" (cl-incf cnt)
(match-string 2 l) (match-string 1 l))))
(t (princ (format "[%c] %s\n" (cl-incf cnt)
(match-string 1 l)))))))
(org-fit-window-to-buffer (get-buffer-window "*Select Link*"))
(message "Select link to open, RET to open all:")
(unwind-protect (setq c (read-char-exclusive))
(and (get-buffer-window "*Select Link*" t)
(quit-window 'kill (get-buffer-window "*Select Link*" t)))
(and (get-buffer "*Select Link*") (kill-buffer "*Select Link*")))))
(when (equal c ?q) (user-error "Abort"))
(if (equal c ?\C-m)
(setq link links)
(setq nth (- c ?0))
(when have-zero (setq nth (1+ nth)))
(unless (and (integerp nth) (>= (length links) nth))
(user-error "Invalid link selection"))
(setq link (nth (1- nth) links)))))
(cons link end)))))
(defun org--link-at-point ()
"`thing-at-point' provider function."
(org-element-property :raw-link (org-element-context)))
(defun org--bounds-of-link-at-point ()
"`bounds-of-thing-at-point' provider function."
(let ((context (org-element-context)))
(when (eq (org-element-type context) 'link)
(cons (org-element-begin context)
(org-element-end context)))))
;;; File search
(defun org-do-occur (regexp &optional cleanup)
"Call the Emacs command `occur'.
If CLEANUP is non-nil, remove the printout of the regular expression
in the *Occur* buffer. This is useful if the regex is long and not useful
to read."
(occur regexp)
(when cleanup
(let ((cwin (selected-window)) win beg end)
(when (setq win (get-buffer-window "*Occur*"))
(select-window win))
(goto-char (point-min))
(when (re-search-forward "match[a-z]+" nil t)
(setq beg (match-end 0))
(when (re-search-forward "^[ \t]*[0-9]+" nil t)
(setq end (1- (match-beginning 0)))))
(and beg end (let ((inhibit-read-only t)) (delete-region beg end)))
(goto-char (point-min))
(select-window cwin))))
;;; The Mark Ring
(defvar org-mark-ring nil
"Mark ring for positions before jumps in Org mode.")
(defvar org-mark-ring-last-goto nil
"Last position in the mark ring used to go back.")
;; Fill and close the ring
(setq org-mark-ring nil)
(setq org-mark-ring-last-goto nil) ;in case file is reloaded
(dotimes (_ org-mark-ring-length) (push (make-marker) org-mark-ring))
(setcdr (nthcdr (1- org-mark-ring-length) org-mark-ring)
org-mark-ring)
(defun org-mark-ring-push (&optional pos buffer)
"Put the current position into the mark ring and rotate it.
Also push position into the Emacs mark ring. If optional
argument POS and BUFFER are not nil, mark this location instead."
(interactive)
(let ((pos (or pos (point)))
(buffer (or buffer (current-buffer))))
(with-current-buffer buffer
(org-with-point-at pos (push-mark nil t)))
(setq org-mark-ring (nthcdr (1- org-mark-ring-length) org-mark-ring))
(move-marker (car org-mark-ring) pos buffer))
(message
(substitute-command-keys
"Position saved to mark ring, go back with `\\[org-mark-ring-goto]'.")))
(defun org-mark-ring-goto (&optional n)
"Jump to the previous position in the mark ring.
With prefix arg N, jump back that many stored positions. When
called several times in succession, walk through the entire ring.
Org mode commands jumping to a different position in the current file,
or to another Org file, automatically push the old position onto the ring."
(interactive "p")
(let (p m)
(if (eq last-command this-command)
(setq p (nthcdr n (or org-mark-ring-last-goto org-mark-ring)))
(setq p org-mark-ring))
(setq org-mark-ring-last-goto p)
(setq m (car p))
(pop-to-buffer-same-window (marker-buffer m))
(goto-char m)
(when (or (org-invisible-p) (org-invisible-p2)) (org-fold-show-context 'mark-goto))))
;;; Following specific links
(defvar org-agenda-buffer-tmp-name)
(defvar org-agenda-start-on-weekday)
(defvar org-agenda-buffer-name)
(defun org-follow-timestamp-link ()
"Open an agenda view for the timestamp date/range at point."
(require 'org-agenda)
;; Avoid changing the global value.
(let ((org-agenda-buffer-name org-agenda-buffer-name))
(cond
((org-at-date-range-p t)
(let ((org-agenda-start-on-weekday)
(t1 (match-string 1))
(t2 (match-string 2)) tt1 tt2)
(setq tt1 (time-to-days (org-time-string-to-time t1))
tt2 (time-to-days (org-time-string-to-time t2)))
(let ((org-agenda-buffer-tmp-name
(format "*Org Agenda(a:%s)"
(concat (substring t1 0 10) "--" (substring t2 0 10)))))
(org-agenda-list nil tt1 (1+ (- tt2 tt1))))))
((org-at-timestamp-p 'lax)
(let ((org-agenda-buffer-tmp-name
(format "*Org Agenda(a:%s)" (substring (match-string 1) 0 10))))
(org-agenda-list nil (time-to-days (org-time-string-to-time
(substring (match-string 1) 0 10)))
1)))
(t (error "This should not happen")))))
;;; Following file links
(declare-function mailcap-parse-mailcaps "mailcap" (&optional path force))
(declare-function mailcap-extension-to-mime "mailcap" (extn))
(declare-function mailcap-mime-info
"mailcap" (string &optional request no-decode))
(defvar org-wait nil)
;;;; Refiling
(defun org-get-org-file ()
"Read a filename, with default directory `org-directory'."
(let ((default (or org-default-notes-file remember-data-file)))
(read-file-name (format "File name [%s]: " default)
(file-name-as-directory org-directory)
default)))
(defun org-notes-order-reversed-p ()
"Check if the current file should receive notes in reversed order."
(cond
((not org-reverse-note-order) nil)
((listp org-reverse-note-order)
(catch 'exit
(dolist (entry org-reverse-note-order)
(when (string-match (car entry) buffer-file-name)
(throw 'exit (cdr entry))))))
(t org-reverse-note-order)))
(defvar org-agenda-new-buffers nil
"Buffers created to visit agenda files.")
(declare-function org-string-nw-p "org-macs" (s))
;;;; Dynamic blocks
(defun org-find-dblock (name)
"Find the first dynamic block with name NAME in the buffer.
If not found, stay at current position and return nil."
(let ((case-fold-search t) pos)
(save-excursion
(goto-char (point-min))
(setq pos (and (re-search-forward
(concat "^[ \t]*#\\+\\(?:BEGIN\\|begin\\):[ \t]+" name "\\>") nil t)
(match-beginning 0))))
(when pos (goto-char pos))
pos))
(defun org-create-dblock (plist)
"Create a dynamic block section, with parameters taken from PLIST.
PLIST must contain a :name entry which is used as the name of the block."
(when (string-match "\\S-" (buffer-substring (line-beginning-position)
(line-end-position)))
(end-of-line 1)
(newline))
(let ((col (current-column))
(name (plist-get plist :name)))
(insert "#+BEGIN: " name)
(while plist
(if (eq (car plist) :name)
(setq plist (cddr plist))
(insert " " (prin1-to-string (pop plist)))))
(insert "\n\n" (make-string col ?\ ) "#+END:\n")
(forward-line -3)))
(defun org-prepare-dblock ()
"Prepare dynamic block for refresh.
This empties the block, puts the cursor at the insert position and returns
the property list including an extra property :name with the block name."
(unless (looking-at org-dblock-start-re)
(user-error "Not at a dynamic block"))
(let* ((begdel (1+ (match-end 0)))
(name (org-no-properties (match-string 1)))
(params (append (list :name name)
(read (concat "(" (match-string 3) ")")))))
(save-excursion
(forward-line 0)
(skip-chars-forward " \t")
(setq params (plist-put params :indentation-column (current-column))))
(unless (re-search-forward org-dblock-end-re nil t)
(error "Dynamic block not terminated"))
(setq params
(append params
(list :content (buffer-substring
begdel (match-beginning 0)))))
(delete-region begdel (match-beginning 0))
(goto-char begdel)
(open-line 1)
params))
(defun org-map-dblocks (&optional command)
"Apply COMMAND to all dynamic blocks in the current buffer.
If COMMAND is not given, use `org-update-dblock'."
(let ((cmd (or command 'org-update-dblock)))
(save-excursion
(goto-char (point-min))
(while (re-search-forward org-dblock-start-re nil t)
(goto-char (match-beginning 0))
(save-excursion
(condition-case-unless-debug nil
(funcall cmd)
(error (message "Error during update of dynamic block"))))
(unless (re-search-forward org-dblock-end-re nil t)
(error "Dynamic block not terminated"))))))
(defvar org-dynamic-block-alist nil
"Alist defining all the Org dynamic blocks.
The key is the dynamic block type name, as a string. The value
is the function used to insert the dynamic block.
Use `org-dynamic-block-define' to populate it.")
(defun org-dynamic-block-function (type)
"Return function associated to a given dynamic block type.
TYPE is the dynamic block type, as a string."
(cdr (assoc type org-dynamic-block-alist)))
(defun org-dynamic-block-types ()
"List all defined dynamic block types."
(mapcar #'car org-dynamic-block-alist))
;;;###org-autoload
(defun org-dynamic-block-define (type func)
"Define dynamic block TYPE with FUNC.
TYPE is a string. FUNC is the function creating the dynamic
block of such type. FUNC must be able to accept zero arguments."
(pcase (assoc type org-dynamic-block-alist)
(`nil (push (cons type func) org-dynamic-block-alist))
(def (setcdr def func))))
(defun org-dynamic-block-insert-dblock (type &optional interactive-p)
"Insert a dynamic block of type TYPE.
When used interactively, select the dynamic block types among
defined types, per `org-dynamic-block-define'. If INTERACTIVE-P
is non-nil, call the dynamic block function interactively."
(interactive (list (completing-read "Dynamic block: "
(org-dynamic-block-types))
t))
(pcase (org-dynamic-block-function type)
(`nil (error "No such dynamic block: %S" type))
((and f (pred functionp))
(if (and interactive-p (commandp f)) (call-interactively f) (funcall f)))
(_ (error "Invalid function for dynamic block %S" type))))
(defun org-dblock-update (&optional arg)
"User command for updating dynamic blocks.
Update the dynamic block at point. With prefix ARG, update all dynamic
blocks in the buffer."
(interactive "P")
(if arg
(org-update-all-dblocks)
(or (looking-at org-dblock-start-re)
(org-beginning-of-dblock))
(org-update-dblock)))
(defun org-update-dblock ()
"Update the dynamic block at point.
This means to empty the block, parse for parameters and then call
the correct writing function."
(interactive)
(save-excursion
(let* ((win (selected-window))
(pos (point))
(line (org-current-line))
(params
;; Called for side effect.
(org-prepare-dblock))
(name (plist-get params :name))
(indent (plist-get params :indentation-column))
(cmd (intern (concat "org-dblock-write:" name))))
(message "Updating dynamic block `%s' at line %d..." name line)
(funcall cmd params)
(message "Updating dynamic block `%s' at line %d...done" name line)
(goto-char pos)
(when (and indent (> indent 0))
(setq indent (make-string indent ?\ ))
(save-excursion
(select-window win)
(org-beginning-of-dblock)
(forward-line 1)
(while (not (looking-at org-dblock-end-re))
(insert indent)
(forward-line 1))
(when (looking-at org-dblock-end-re)
(and (looking-at "[ \t]+")
(replace-match ""))
(insert indent)))))))
(defun org-beginning-of-dblock ()
"Find the beginning of the dynamic block at point.
Error if there is no such block at point."
(let ((pos (point))
beg)
(end-of-line 1)
(if (and (re-search-backward org-dblock-start-re nil t)
(setq beg (match-beginning 0))
(re-search-forward org-dblock-end-re nil t)
(> (match-end 0) pos))
(goto-char beg)
(goto-char pos)
(error "Not in a dynamic block"))))
(defun org-update-all-dblocks ()
"Update all dynamic blocks in the buffer.
This function can be used in a hook."
(interactive)
(when (derived-mode-p 'org-mode)
(org-map-dblocks 'org-update-dblock)))
;;;; Completion
(declare-function org-export-backend-options "ox" (cl-x) t)
(defun org-get-export-keywords ()
"Return a list of all currently understood export keywords.
Export keywords include options, block names, attributes and
keywords relative to each registered export backend."
(let (keywords)
(dolist (backend
(bound-and-true-p org-export-registered-backends)
(delq nil keywords))
;; Backend name (for keywords, like #+LATEX:)
(push (upcase (symbol-name (org-export-backend-name backend))) keywords)
;; Backend attributes, like #+ATTR_LATEX:
(push (format "ATTR_%s" (upcase (symbol-name (org-export-backend-name backend)))) keywords)
(dolist (option-entry (org-export-backend-options backend))
;; Backend options.
(push (nth 1 option-entry) keywords)))))
(defconst org-options-keywords
'("ARCHIVE:" "AUTHOR:" "BIBLIOGRAPHY:" "BIND:" "CATEGORY:" "CITE_EXPORT:"
"COLUMNS:" "CREATOR:" "DATE:" "DESCRIPTION:" "DRAWERS:" "EMAIL:"
"EXCLUDE_TAGS:" "FILETAGS:" "INCLUDE:" "INDEX:" "KEYWORDS:" "LANGUAGE:"
"MACRO:" "OPTIONS:" "PROPERTY:" "PRINT_BIBLIOGRAPHY:" "PRIORITIES:"
"SELECT_TAGS:" "SEQ_TODO:" "SETUPFILE:" "STARTUP:" "TAGS:" "TITLE:" "TODO:"
"TYP_TODO:" "SELECT_TAGS:" "EXCLUDE_TAGS:" "EXPORT_FILE_NAME:"))
(defcustom org-structure-template-alist
'(("a" . "export ascii")
("c" . "center")
("C" . "comment")
("e" . "example")
("E" . "export")
("h" . "export html")
("l" . "export latex")
("q" . "quote")
("s" . "src")
("v" . "verse"))
"An alist of keys and block types.
`org-insert-structure-template' will display a menu with this list of
templates to choose from. The block type is inserted, with
\"#+begin_\" and \"#+end_\" added automatically. If the block type
consists of just uppercase letters, \"#+BEGIN_\" and \"#+END_\" are
added instead.
The menu keys are defined by the car of each entry in this alist.
If two entries have the keys \"a\" and \"aa\" respectively, the
former will be inserted by typing \"a TAB/RET/SPC\" and the
latter will be inserted by typing \"aa\". If an entry with the
key \"aab\" is later added, it can be inserted by typing \"ab\".
If loaded, Org Tempo also uses `org-structure-template-alist'. A
block can be inserted by pressing TAB after the string \"<KEY\"."
:group 'org-edit-structure
:type '(repeat
(cons (string :tag "Key")
(string :tag "Template")))
:package-version '(Org . "9.6"))
(defun org--check-org-structure-template-alist (&optional checklist)
"Check whether `org-structure-template-alist' is set up correctly.
In particular, check if the Org 9.2 format is used as opposed to
previous format."
(let ((elm (cl-remove-if-not (lambda (x) (listp (cdr x)))
(or (symbol-value checklist)
org-structure-template-alist))))
(when elm
(org-display-warning
(format "
Please update the entries of `%s'.
In Org 9.2 the format was changed from something like
(\"s\" \"#+BEGIN_SRC ?\\n#+END_SRC\")
to something like
(\"s\" . \"src\")
Please refer to the documentation of `org-structure-template-alist'.
The following entries must be updated:
%s"
(or checklist 'org-structure-template-alist)
(pp-to-string elm))))))
(defun org--insert-structure-template-mks ()
"Present `org-structure-template-alist' with `org-mks'.
Menus are added if keys require more than one keystroke. Tabs
are added to single key entries when more than one stroke is
needed. Keys longer than two characters are reduced to two
characters."
(org--check-org-structure-template-alist)
(let* (case-fold-search
(templates (append org-structure-template-alist
'(("\t" . "Press TAB, RET or SPC to write block name"))))
(keys (mapcar #'car templates))
(start-letters
(delete-dups (mapcar (lambda (key) (substring key 0 1)) keys)))
;; Sort each element of `org-structure-template-alist' into
;; sublists according to the first letter.
(superlist
(mapcar (lambda (letter)
(list letter
(cl-remove-if-not
(apply-partially #'string-match-p (concat "^" letter))
templates :key #'car)))
start-letters)))
(org-mks
(apply #'append
;; Make an `org-mks' table. If only one element is
;; present in a sublist, make it part of the top-menu,
;; otherwise make a submenu according to the starting
;; letter and populate it.
(mapcar (lambda (sublist)
(if (eq 1 (length (cadr sublist)))
(mapcar (lambda (elm)
(list (substring (car elm) 0 1)
(cdr elm) ""))
(cadr sublist))
;; Create submenu.
(let* ((topkey (car sublist))
(elms (cadr sublist))
(keys (mapcar #'car elms))
(long (> (length elms) 3)))
(append
(list
;; Make a description of the submenu.
(list topkey
(concat
(mapconcat #'cdr
(cl-subseq elms 0 (if long 3 (length elms)))
", ")
(when long ", ..."))))
;; List of entries in submenu.
(cl-mapcar #'list
(org--insert-structure-template-unique-keys keys)
(mapcar #'cdr elms)
(make-list (length elms) ""))))))
superlist))
"Select a key\n============"
"Key: ")))
(defun org--insert-structure-template-unique-keys (keys)
"Make a list of unique, two characters long elements from KEYS.
Elements of length one have a tab appended. Elements of length
two are kept as is. Longer elements are truncated to length two.
If an element cannot be made unique, an error is raised."
(let ((ordered-keys (cl-sort (copy-sequence keys) #'< :key #'length))
menu-keys)
(dolist (key ordered-keys)
(let ((potential-key
(cl-case (length key)
(1 (concat key "\t"))
(2 key)
(otherwise
(cl-find-if-not (lambda (k) (assoc k menu-keys))
(mapcar (apply-partially #'concat (substring key 0 1))
(split-string (substring key 1) "" t)))))))
(if (or (not potential-key) (assoc potential-key menu-keys))
(user-error "Could not make unique key for `%s'" key)
(push (cons potential-key key) menu-keys))))
(mapcar #'car
(cl-sort menu-keys #'<
:key (lambda (elm) (cl-position (cdr elm) keys))))))
(defun org-insert-structure-template (type)
"Insert a block structure of the type #+begin_foo/#+end_foo.
Select a block from `org-structure-template-alist' then type
either RET, TAB or SPC to write the block type. With an active
region, wrap the region in the block. Otherwise, insert an empty
block.
When foo is written as FOO, upcase the #+BEGIN/END as well."
(interactive
(list (pcase (org--insert-structure-template-mks)
(`("\t" . ,_)
(let ((type (read-string "Structure type: ")))
(when (string-empty-p type) (user-error "Empty structure type"))
type))
(`(,_ ,choice . ,_) choice))))
(when (or (not (stringp type)) (string-empty-p type))
(error "Invalid structure type: %S" type))
(let* ((case-fold-search t) ; Make sure that matches are case-insensitive.
(region? (use-region-p))
(region-start (and region? (region-beginning)))
(region-end (and region? (copy-marker (region-end))))
(extended? (string-match-p "\\`\\(src\\|export\\)\\'" type))
(verbatim? (string-match-p
(concat "\\`" (regexp-opt '("example" "export"
"src" "comment")))
type))
(upcase? (string= (car (split-string type))
(upcase (car (split-string type))))))
(when region? (goto-char region-start))
(let ((column (current-indentation)))
(if (save-excursion (skip-chars-backward " \t") (bolp))
(forward-line 0)
(insert "\n"))
(save-excursion
(indent-to column)
(insert (format "#+%s_%s%s\n" (if upcase? "BEGIN" "begin") type (if extended? " " "")))
(when region?
(when verbatim? (org-escape-code-in-region (point) region-end))
(goto-char region-end)
;; Ignore empty lines at the end of the region.
(skip-chars-backward " \r\t\n")
(end-of-line))
(unless (bolp) (insert "\n"))
(indent-to column)
(insert (format "#+%s_%s" (if upcase? "END" "end") (car (split-string type))))
(if (looking-at "[ \t]*$") (replace-match "")
(insert "\n"))
(when (and (eobp) (not (bolp))) (insert "\n")))
(if extended? (end-of-line)
(forward-line)
(skip-chars-forward " \t")))))
;;;; TODO, DEADLINE, Comments
(defun org-toggle-comment ()
"Change the COMMENT state of an entry."
(interactive)
(save-excursion
(org-back-to-heading)
(let ((case-fold-search nil))
(looking-at org-complex-heading-regexp))
(goto-char (or (match-end 3) (match-end 2) (match-end 1)))
(skip-chars-forward " \t")
(unless (memq (char-before) '(?\s ?\t)) (insert " "))
(if (org-in-commented-heading-p t)
(delete-region (point)
(progn (search-forward " " (line-end-position) 'move)
(skip-chars-forward " \t")
(point)))
(insert org-comment-string)
(unless (eolp) (insert " ")))))
(defvar org-last-todo-state-is-todo nil
"This is non-nil when the last TODO state change led to a TODO state.
If the last change removed the TODO tag or switched to DONE, then
this is nil.")
(defvar org-todo-setup-filter-hook nil
"Hook for functions that pre-filter todo specs.
Each function takes a todo spec and returns either nil or the spec
transformed into canonical form." )
(defvar org-todo-get-default-hook nil
"Hook for functions that get a default item for todo.
Each function takes arguments (NEW-MARK OLD-MARK) and returns either
nil or a string to be used for the todo mark." )
(defvar org-agenda-headline-snapshot-before-repeat)
(defun org-current-effective-time ()
"Return current time adjusted for `org-extend-today-until' variable."
(let* ((ct (org-current-time))
(dct (decode-time ct))
(ct1
(cond
(org-use-last-clock-out-time-as-effective-time
(or (org-clock-get-last-clock-out-time) ct))
((and org-use-effective-time (< (nth 2 dct) org-extend-today-until))
(org-encode-time 0 59 23 (1- (nth 3 dct)) (nth 4 dct) (nth 5 dct)))
(t ct))))
ct1))
(defun org-todo-yesterday (&optional arg)
"Like `org-todo' but the time of change will be 23:59 of yesterday."
(interactive "P")
(if (eq major-mode 'org-agenda-mode)
(org-agenda-todo-yesterday arg)
(let* ((org-use-effective-time t)
(hour (nth 2 (decode-time (org-current-time))))
(org-extend-today-until (1+ hour)))
(org-todo arg))))
(defvar org-block-entry-blocking ""
"First entry preventing the TODO state change.")
(defun org-cancel-repeater ()
"Cancel a repeater by setting its numeric value to zero."
(interactive)
(save-excursion
(org-back-to-heading t)
(let ((bound1 (point))
(bound0 (save-excursion (outline-next-heading) (point))))
(when (and (re-search-forward
(concat "\\(" org-scheduled-time-regexp "\\)\\|\\("
org-deadline-time-regexp "\\)\\|\\("
org-ts-regexp "\\)")
bound0 t)
(re-search-backward "[ \t]+\\(?:[.+]\\)?\\+\\([0-9]+\\)[hdwmy]"
bound1 t))
(replace-match "0" t nil nil 1)))))
(defvar org-state)
;; FIXME: We should refactor this and similar dynamically scoped blocker flags.
(defvar org-blocked-by-checkboxes nil) ; dynamically scoped
(defun org-todo (&optional arg)
"Change the TODO state of an item.
The state of an item is given by a keyword at the start of the heading,
like
*** TODO Write paper
*** DONE Call mom
The different keywords are specified in the variable `org-todo-keywords'.
By default the available states are \"TODO\" and \"DONE\". So, for this
example: when the item starts with TODO, it is changed to DONE.
When it starts with DONE, the DONE is removed. And when neither TODO nor
DONE are present, add TODO at the beginning of the heading.
You can set up single-character keys to fast-select the new state. See the
`org-todo-keywords' and `org-use-fast-todo-selection' for details.
With `\\[universal-argument]' prefix ARG, force logging the state change \
and take a
logging note.
With a `\\[universal-argument] \\[universal-argument]' prefix, switch to the \
next set of TODO \
keywords (nextset).
Another way to achieve this is `S-C-<right>'.
With a `\\[universal-argument] \\[universal-argument] \\[universal-argument]' \
prefix, circumvent any state blocking.
With numeric prefix arg, switch to the Nth state.
With a numeric prefix arg of 0, inhibit note taking for the change.
With a numeric prefix arg of -1, cancel repeater to allow marking as DONE.
When called through Elisp, arg is also interpreted in the following way:
`none' -> empty state
\"\" -> switch to empty state
`done' -> switch to DONE
`nextset' -> switch to the next set of keywords
`previousset' -> switch to the previous set of keywords
\"WAITING\" -> switch to the specified keyword, but only if it
really is a member of `org-todo-keywords'."
(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)
'region-start-level 'region))
org-loop-over-headlines-in-active-region)
(org-map-entries
(lambda () (org-todo arg))
nil cl
(when (org-invisible-p) (org-end-of-subtree nil t))))
(when (equal arg '(16)) (setq arg 'nextset))
(when (equal (prefix-numeric-value arg) -1) (org-cancel-repeater) (setq arg nil))
(when (< (prefix-numeric-value arg) -1) (user-error "Prefix argument %d not supported" arg))
(let ((org-blocker-hook org-blocker-hook)
commentp
case-fold-search)
(when (equal arg '(64))
(setq arg nil org-blocker-hook nil))
(when (and org-blocker-hook
(or org-inhibit-blocking
(org-entry-get nil "NOBLOCKING")))
(setq org-blocker-hook nil))
(save-excursion
(catch 'exit
(org-back-to-heading t)
(when (org-in-commented-heading-p t)
(org-toggle-comment)
(setq commentp t))
(when (looking-at org-outline-regexp) (goto-char (1- (match-end 0))))
(or (looking-at (concat " +" org-todo-regexp "\\( +\\|[ \t]*$\\)"))
(looking-at "\\(?: *\\|[ \t]*$\\)"))
(let* ((match-data (match-data))
(startpos (copy-marker (line-beginning-position)))
(force-log (and (equal arg '(4)) (prog1 t (setq arg nil))))
(logging (save-match-data (org-entry-get nil "LOGGING" t t)))
(org-log-done org-log-done)
(org-log-repeat org-log-repeat)
(org-todo-log-states org-todo-log-states)
(org-inhibit-logging
(if (equal arg 0)
(progn (setq arg nil) 'note) org-inhibit-logging))
(this (match-string 1))
(hl-pos (match-beginning 0))
(head (org-get-todo-sequence-head this))
(ass (assoc head org-todo-kwd-alist))
(interpret (nth 1 ass))
(done-word (nth 3 ass))
(final-done-word (nth 4 ass))
(org-last-state (or this ""))
(completion-ignore-case t)
(member (member this org-todo-keywords-1))
(tail (cdr member))
(org-state (cond
((eq arg 'right)
;; Next state
(if this
(if tail (car tail) nil)
(car org-todo-keywords-1)))
((eq arg 'left)
;; Previous state
(unless (equal member org-todo-keywords-1)
(if this
(nth (- (length org-todo-keywords-1)
(length tail) 2)
org-todo-keywords-1)
(org-last org-todo-keywords-1))))
(arg
;; User or caller requests a specific state.
(cond
((equal arg "") nil)
((eq arg 'none) nil)
((eq arg 'done) (or done-word (car org-done-keywords)))
((eq arg 'nextset)
(or (car (cdr (member head org-todo-heads)))
(car org-todo-heads)))
((eq arg 'previousset)
(let ((org-todo-heads (reverse org-todo-heads)))
(or (car (cdr (member head org-todo-heads)))
(car org-todo-heads))))
((car (member arg org-todo-keywords-1)))
((stringp arg)
(user-error "State `%s' not valid in this file" arg))
((nth (1- (prefix-numeric-value arg))
org-todo-keywords-1))))
((and org-todo-key-trigger org-use-fast-todo-selection)
;; Use fast selection.
(org-fast-todo-selection this))
((null member) (or head (car org-todo-keywords-1)))
((equal this final-done-word) nil) ;-> make empty
((null tail) nil) ;-> first entry
((memq interpret '(type priority))
(if (eq this-command last-command)
(car tail)
(if (> (length tail) 0)
(or done-word (car org-done-keywords))
nil)))
(t
(car tail))))
(org-state (or
(run-hook-with-args-until-success
'org-todo-get-default-hook org-state org-last-state)
org-state))
(next (if (org-string-nw-p org-state) (concat " " org-state " ") " "))
(change-plist (list :type 'todo-state-change :from this :to org-state
:position startpos))
dolog now-done-p)
(when org-blocker-hook
(let (org-blocked-by-checkboxes block-reason)
(setq org-last-todo-state-is-todo
(not (member this org-done-keywords)))
(unless (save-excursion
(save-match-data
(org-with-wide-buffer
(run-hook-with-args-until-failure
'org-blocker-hook change-plist))))
(setq block-reason (if org-blocked-by-checkboxes
"contained checkboxes"
(format "\"%s\"" org-block-entry-blocking)))
(if (called-interactively-p 'interactive)
(user-error "TODO state change from %s to %s blocked (by %s)"
this org-state block-reason)
;; Fail silently.
(message "TODO state change from %s to %s blocked (by %s)"
this org-state block-reason)
(throw 'exit nil)))))
(store-match-data match-data)
(org-fold-core-ignore-modifications
(goto-char (match-beginning 0))
(replace-match "")
;; We need to use `insert-before-markers-and-inherit'
;; because: (1) We want to preserve the folding state
;; text properties; (2) We do not want to make point
;; move before new todo state when inserting a new todo
;; into an empty heading. In (2), the above
;; `save-excursion' is relying on markers saved before.
(insert-before-markers-and-inherit next)
(unless (org-invisible-p (line-beginning-position))
(org-fold-region (line-beginning-position)
(line-end-position)
nil 'outline)))
(cond ((and org-state (equal this org-state))
(message "TODO state was already %s" (org-trim next)))
((not (pos-visible-in-window-p hl-pos))
(message "TODO state changed to %s" (org-trim next))))
(unless head
(setq head (org-get-todo-sequence-head org-state)
ass (assoc head org-todo-kwd-alist)
interpret (nth 1 ass)
done-word (nth 3 ass)
final-done-word (nth 4 ass)))
(when (memq arg '(nextset previousset))
(message "Keyword-Set %d/%d: %s"
(- (length org-todo-sets) -1
(length (memq (assoc org-state org-todo-sets) org-todo-sets)))
(length org-todo-sets)
(mapconcat 'identity (assoc org-state org-todo-sets) " ")))
(setq org-last-todo-state-is-todo
(not (member org-state org-done-keywords)))
(setq now-done-p (and (member org-state org-done-keywords)
(not (member this org-done-keywords))))
(and logging (org-local-logging logging))
(when (or (and (or org-todo-log-states org-log-done)
(not (eq org-inhibit-logging t))
(not (memq arg '(nextset previousset))))
force-log)
;; We need to look at recording a time and note.
(setq dolog (or (if force-log 'note)
(nth 1 (assoc org-state org-todo-log-states))
(nth 2 (assoc this org-todo-log-states))))
(when (and (eq dolog 'note) (eq org-inhibit-logging 'note))
(setq dolog 'time))
(when (or (and (not org-state) (not org-closed-keep-when-no-todo))
(and org-state
(member org-state org-not-done-keywords)
(not (member this org-not-done-keywords))))
;; This is now a todo state and was not one before
;; If there was a CLOSED time stamp, get rid of it.
(org-add-planning-info nil nil 'closed))
(when (and now-done-p org-log-done)
;; It is now done, and it was not done before.
(org-add-planning-info 'closed (org-current-effective-time))
(when (and (not dolog) (eq 'note org-log-done))
(org-add-log-setup 'done org-state this 'note)))
(when (and org-state dolog)
;; This is a non-nil state, and we need to log it.
(org-add-log-setup 'state org-state this dolog)))
;; Fixup tag positioning.
(org-todo-trigger-tag-changes org-state)
(when org-auto-align-tags (org-align-tags))
(when org-provide-todo-statistics
(org-update-parent-todo-statistics))
(when (bound-and-true-p org-clock-out-when-done)
(org-clock-out-if-current))
(run-hooks 'org-after-todo-state-change-hook)
(when (and arg (not (member org-state org-done-keywords)))
(setq head (org-get-todo-sequence-head org-state)))
(put-text-property (line-beginning-position)
(line-end-position) 'org-todo-head head)
;; Do we need to trigger a repeat?
(when now-done-p
(when (boundp 'org-agenda-headline-snapshot-before-repeat)
;; This is for the agenda, take a snapshot of the headline.
(save-match-data
(setq org-agenda-headline-snapshot-before-repeat
(org-get-heading))))
(org-auto-repeat-maybe org-state))
;; Fixup cursor location if close to the keyword.
(when (and (outline-on-heading-p)
(not (bolp))
(save-excursion
(forward-line 0)
(looking-at org-todo-line-regexp))
(< (point) (+ 2 (or (match-end 2) (match-end 1)))))
(goto-char (or (match-end 2) (match-end 1)))
(and (looking-at " ")
(not (looking-at " *:"))
(just-one-space)))
(when org-trigger-hook
(save-excursion
(run-hook-with-args 'org-trigger-hook change-plist)))
(when commentp (org-toggle-comment))))))))
(defun org-block-todo-from-children-or-siblings-or-parent (change-plist)
"Block turning an entry into a TODO, using the hierarchy.
This checks whether the current task should be blocked from state
changes. Such blocking occurs when:
1. The task has children which are not all in a completed state.
2. A task has a parent with the property :ORDERED:, and there
are siblings prior to the current task with incomplete
status.
3. The parent of the task is blocked because it has siblings that should
be done first, or is child of a block grandparent TODO entry."
(if (not org-enforce-todo-dependencies)
t ; if locally turned off don't block
(catch 'dont-block
;; If this is not a todo state change, or if this entry is already DONE,
;; do not block
(when (or (not (eq (plist-get change-plist :type) 'todo-state-change))
(member (plist-get change-plist :from)
(cons 'done org-done-keywords))
(member (plist-get change-plist :to)
(cons 'todo org-not-done-keywords))
(not (plist-get change-plist :to)))
(throw 'dont-block t))
;; If this task has children, and any are undone, it's blocked
(save-excursion
(org-back-to-heading t)
(let ((this-level (funcall outline-level)))
(outline-next-heading)
(let ((child-level (funcall outline-level)))
(while (and (not (eobp))
(> child-level this-level))
;; this todo has children, check whether they are all
;; completed
(when (and (not (org-entry-is-done-p))
(org-entry-is-todo-p))
(setq org-block-entry-blocking (org-get-heading))
(throw 'dont-block nil))
(outline-next-heading)
(setq child-level (funcall outline-level))))))
;; Otherwise, if the task's parent has the :ORDERED: property, and
;; any previous siblings are undone, it's blocked
(save-excursion
(org-back-to-heading t)
(let* ((pos (point))
(parent-pos (and (org-up-heading-safe) (point)))
(case-fold-search nil))
(unless parent-pos (throw 'dont-block t)) ; no parent
(when (and (org-not-nil (org-entry-get (point) "ORDERED"))
(forward-line 1)
(re-search-forward org-not-done-heading-regexp pos t))
(setq org-block-entry-blocking (match-string 0))
(throw 'dont-block nil)) ; block, there is an older sibling not done.
;; Search further up the hierarchy, to see if an ancestor is blocked
(while t
(goto-char parent-pos)
(unless (looking-at org-not-done-heading-regexp)
(throw 'dont-block t)) ; do not block, parent is not a TODO
(setq pos (point))
(setq parent-pos (and (org-up-heading-safe) (point)))
(unless parent-pos (throw 'dont-block t)) ; no parent
(when (and (org-not-nil (org-entry-get (point) "ORDERED"))
(forward-line 1)
(re-search-forward org-not-done-heading-regexp pos t)
(setq org-block-entry-blocking (org-get-heading)))
(throw 'dont-block nil)))))))) ; block, older sibling not done.
(defcustom org-track-ordered-property-with-tag nil
"Should the ORDERED property also be shown as a tag?
The ORDERED property decides if an entry should require subtasks to be
completed in sequence. Since a property is not very visible, setting
this option means that toggling the ORDERED property with the command
`org-toggle-ordered-property' will also toggle a tag ORDERED. That tag is
not relevant for the behavior, but it makes things more visible.
Note that toggling the tag with tags commands will not change the property
and therefore not influence behavior!
This can be t, meaning the tag ORDERED should be used. It can also be a
string to select a different tag for this task."
:group 'org-todo
:type '(choice
(const :tag "No tracking" nil)
(const :tag "Track with ORDERED tag" t)
(string :tag "Use other tag")))
(defun org-toggle-ordered-property ()
"Toggle the ORDERED property of the current entry.
For better visibility, you can track the value of this property with a tag.
See variable `org-track-ordered-property-with-tag'."
(interactive)
(let* ((t1 org-track-ordered-property-with-tag)
(tag (and t1 (if (stringp t1) t1 "ORDERED"))))
(save-excursion
(org-back-to-heading)
(if (org-entry-get nil "ORDERED")
(progn
(org-delete-property "ORDERED")
(and tag (org-toggle-tag tag 'off))
(message "Subtasks can be completed in arbitrary order"))
(org-entry-put nil "ORDERED" "t")
(and tag (org-toggle-tag tag 'on))
(message "Subtasks must be completed in sequence")))))
(defun org-block-todo-from-checkboxes (change-plist)
"Block turning an entry into a TODO, using checkboxes.
This checks whether the current task should be blocked from state
changes because there are unchecked boxes in this entry."
(if (not org-enforce-todo-checkbox-dependencies)
t ; if locally turned off don't block
(catch 'dont-block
;; If this is not a todo state change, or if this entry is already DONE,
;; do not block
(when (or (not (eq (plist-get change-plist :type) 'todo-state-change))
(member (plist-get change-plist :from)
(cons 'done org-done-keywords))
(member (plist-get change-plist :to)
(cons 'todo org-not-done-keywords))
(not (plist-get change-plist :to)))
(throw 'dont-block t))
;; If this task has checkboxes that are not checked, it's blocked
(save-excursion
(org-back-to-heading t)
(let ((beg (point)) end)
(outline-next-heading)
(setq end (point))
(goto-char beg)
(when (org-list-search-forward
(concat (org-item-beginning-re)
"\\(?:\\[@\\(?:start:\\)?\\([0-9]+\\|[A-Za-z]\\)\\][ \t]*\\)?"
"\\[[- ]\\]")
end t)
(when (boundp 'org-blocked-by-checkboxes)
(setq org-blocked-by-checkboxes t))
(throw 'dont-block nil))))
t))) ; do not block
(defun org-entry-blocked-p ()
"Non-nil if entry at point is blocked."
(and (not (org-entry-get nil "NOBLOCKING"))
(member (org-entry-get nil "TODO") org-not-done-keywords)
(not (run-hook-with-args-until-failure
'org-blocker-hook
(list :type 'todo-state-change
:position (point)
:from 'todo
:to 'done)))))
(defun org-update-statistics-cookies (all)
"Update the statistics cookie, either from TODO or from checkboxes.
This should be called with the cursor in a line with a statistics
cookie. When called with a \\[universal-argument] prefix, update
all statistics cookies in the buffer."
(interactive "P")
(if all
(progn
(org-update-checkbox-count 'all)
(org-map-region 'org-update-parent-todo-statistics
(point-min) (point-max)))
(if (not (org-at-heading-p))
(org-update-checkbox-count)
(let ((pos (point-marker))
end l1 l2)
(ignore-errors (org-back-to-heading t))
(if (not (org-at-heading-p))
(org-update-checkbox-count)
(setq l1 (org-outline-level))
(setq end
(save-excursion
(outline-next-heading)
(when (org-at-heading-p) (setq l2 (org-outline-level)))
(point)))
(if (and (save-excursion
(re-search-forward
"^[ \t]*\\([-+*]\\|[0-9]+[.)]\\) \\[[- X]\\]" end t))
(not (save-excursion
(re-search-forward
":COOKIE_DATA:.*\\<todo\\>" end t))))
(org-update-checkbox-count)
(if (and l2 (> l2 l1))
(progn
(goto-char end)
(org-update-parent-todo-statistics))
(goto-char pos)
(forward-line 0)
(while (re-search-forward
"\\(\\(\\[[0-9]*%\\]\\)\\|\\(\\[[0-9]*/[0-9]*\\]\\)\\)"
(line-end-position) t)
(replace-match (if (match-end 2) "[100%]" "[0/0]") t t)))))
(goto-char pos)
(move-marker pos nil)))))
(defvar org-entry-property-inherited-from) ;; defined below
(defun org-update-parent-todo-statistics ()
"Update any statistics cookie in the parent of the current headline.
When `org-hierarchical-todo-statistics' is nil, statistics will cover
the entire subtree and this will travel up the hierarchy and update
statistics everywhere."
(let* ((prop (save-excursion
(org-up-heading-safe)
(org-entry-get nil "COOKIE_DATA" 'inherit)))
(recursive (or (not org-hierarchical-todo-statistics)
(and prop (string-match "\\<recursive\\>" prop))))
(lim (or (and prop (marker-position org-entry-property-inherited-from))
0))
(first t)
(box-re "\\(\\(\\[[0-9]*%\\]\\)\\|\\(\\[[0-9]*/[0-9]*\\]\\)\\)")
level ltoggle l1 new ndel
(cnt-all 0) (cnt-done 0) is-percent kwd
checkbox-beg cookie-present)
(catch 'exit
(save-excursion
(forward-line 0)
(setq ltoggle (funcall outline-level))
;; Three situations are to consider:
;; 1. if `org-hierarchical-todo-statistics' is nil, repeat up
;; to the top-level ancestor on the headline;
;; 2. If parent has "recursive" property, repeat up to the
;; headline setting that property, taking inheritance into
;; account;
;; 3. Else, move up to direct parent and proceed only once.
(while (and (setq level (org-up-heading-safe))
(or recursive first)
(>= (point) lim))
(setq first nil cookie-present nil)
(unless (and level
(not (string-match
"\\<checkbox\\>"
(downcase (or (org-entry-get nil "COOKIE_DATA")
"")))))
(throw 'exit nil))
(while (re-search-forward box-re (line-end-position) t)
(setq cnt-all 0 cnt-done 0 cookie-present t)
(setq is-percent (match-end 2) checkbox-beg (match-beginning 0))
(when (org-element-type-p
(save-excursion
(goto-char checkbox-beg)
(save-match-data (org-element-context)))
'(statistics-cookie
;; Special case - statistics cookie inside properties.
keyword))
(save-match-data
(unless (outline-next-heading) (throw 'exit nil))
(while (and (looking-at org-complex-heading-regexp)
(> (setq l1 (length (match-string 1))) level))
(setq kwd (and (or recursive (= l1 ltoggle))
(match-string 2)))
(if (or (eq org-provide-todo-statistics 'all-headlines)
(and (eq org-provide-todo-statistics t)
(or (member kwd org-done-keywords)))
(and (listp org-provide-todo-statistics)
(stringp (car org-provide-todo-statistics))
(or (member kwd org-provide-todo-statistics)
(member kwd org-done-keywords)))
(and (listp org-provide-todo-statistics)
(listp (car org-provide-todo-statistics))
(or (member kwd (car org-provide-todo-statistics))
(and (member kwd org-done-keywords)
(member kwd (cadr org-provide-todo-statistics))))))
(setq cnt-all (1+ cnt-all))
(and (eq org-provide-todo-statistics t)
kwd
(setq cnt-all (1+ cnt-all))))
(when (or (and (member org-provide-todo-statistics '(t all-headlines))
(member kwd org-done-keywords))
(and (listp org-provide-todo-statistics)
(listp (car org-provide-todo-statistics))
(member kwd org-done-keywords)
(member kwd (cadr org-provide-todo-statistics)))
(and (listp org-provide-todo-statistics)
(stringp (car org-provide-todo-statistics))
(member kwd org-done-keywords)))
(setq cnt-done (1+ cnt-done)))
(outline-next-heading)))
(setq new
(if is-percent
(format "[%d%%]" (floor (* 100.0 cnt-done)
(max 1 cnt-all)))
(format "[%d/%d]" cnt-done cnt-all))
ndel (- (match-end 0) checkbox-beg))
(goto-char (match-end 0))
(unless (string-equal new (buffer-substring checkbox-beg (match-end 0)))
(goto-char checkbox-beg)
(insert new)
(delete-region (point) (+ (point) ndel))
(when org-auto-align-tags (org-fix-tags-on-the-fly)))))
(when cookie-present
(run-hook-with-args 'org-after-todo-statistics-hook
cnt-done (- cnt-all cnt-done))))))
(run-hooks 'org-todo-statistics-hook)))
(defvar org-after-todo-statistics-hook nil
"Hook that is called after a TODO statistics cookie has been updated.
Each function is called with two arguments: the number of not-done entries
and the number of done entries.
For example, the following function, when added to this hook, will switch
an entry to DONE when all children are done, and back to TODO when new
entries are set to a TODO status. Note that this hook is only called
when there is a statistics cookie in the headline!
(defun org-summary-todo (n-done n-not-done)
\"Switch entry to DONE when all subentries are done, to TODO otherwise.\"
(let (org-log-done org-todo-log-states) ; turn off logging
(org-todo (if (= n-not-done 0) \"DONE\" \"TODO\"))))")
(defvar org-todo-statistics-hook nil
"Hook that is run whenever Org thinks TODO statistics should be updated.
This hook runs even if there is no statistics cookie present, in which case
`org-after-todo-statistics-hook' would not run.")
(defun org-todo-trigger-tag-changes (state)
"Apply the changes defined in `org-todo-state-tags-triggers'."
(let ((l org-todo-state-tags-triggers)
changes)
(when (or (not state) (equal state ""))
(setq changes (append changes (cdr (assoc "" l)))))
(when (and (stringp state) (> (length state) 0))
(setq changes (append changes (cdr (assoc state l)))))
(when (member state org-not-done-keywords)
(setq changes (append changes (cdr (assq 'todo l)))))
(when (member state org-done-keywords)
(setq changes (append changes (cdr (assq 'done l)))))
(dolist (c changes)
(org-toggle-tag (car c) (if (cdr c) 'on 'off)))))
(defun org-local-logging (value)
"Get logging settings from a property VALUE."
;; Directly set the variables, they are already local.
(setq org-log-done nil
org-log-repeat nil
org-todo-log-states nil)
(dolist (w (split-string value))
(let (a)
(cond
((setq a (assoc w org-startup-options))
(and (member (nth 1 a) '(org-log-done org-log-repeat))
(set (nth 1 a) (nth 2 a))))
((setq a (org-extract-log-state-settings w))
(and (member (car a) org-todo-keywords-1)
(push a org-todo-log-states)))))))
(defun org-get-todo-sequence-head (kwd)
"Return the head of the TODO sequence to which KWD belongs.
If KWD is not set, check if there is a text property remembering the
right sequence."
(let (p)
(cond
((not kwd)
(or (get-text-property (line-beginning-position) 'org-todo-head)
(progn
(setq p (next-single-property-change (line-beginning-position)
'org-todo-head
nil (line-end-position)))
(get-text-property p 'org-todo-head))))
((not (member kwd org-todo-keywords-1))
(car org-todo-keywords-1))
(t (nth 2 (assoc kwd org-todo-kwd-alist))))))
(defun org-fast-todo-selection (&optional current-todo-keyword)
"Fast TODO keyword selection with single keys.
Returns the new TODO keyword, or nil if no state change should occur.
When CURRENT-TODO-KEYWORD is given and selection letters are not
unique globally, prefer a state in the current todo keyword sequence
where CURRENT-TODO-KEYWORD belongs over on in another sequence."
(let* ((todo-alist org-todo-key-alist) ; copy from the original Org buffer.
(todo-alist-tail todo-alist)
;; TODO keyword sequence that takes priority in case if there is binding collision.
(preferred-sequence-head (org-get-todo-sequence-head current-todo-keyword))
in-preferred-sequence preferred-todo-alist
(done-keywords org-done-keywords) ;; needed for the faces when calling `org-get-todo-face'.
(expert-interface (equal org-use-fast-todo-selection 'expert))
(prompt "") ; Additional expert prompt, listing todo keyword bindings.
;; Max width occupied by a single todo record in the completion buffer.
(field-width
(+ 3 ; keep space for "[c]" binding.
1 ; ensure that there is at least one space between adjacent todo fields.
3 ; FIXME: likely coped from `org-fast-tag-selection'
;; The longest todo keyword.
(apply 'max (mapcar
(lambda (x)
(if (stringp (car x)) (string-width (car x)) 0))
org-todo-key-alist))))
field-number ; current todo keyword column in the completion buffer.
todo-binding-spec todo-keyword todo-char input-char)
;; Display todo selection dialog, read the user input, and return.
(save-excursion
(save-window-excursion
;; Select todo keyword list buffer, and display it unless EXPERT-INTERFACE.
(if expert-interface
(set-buffer (get-buffer-create " *Org todo*"))
(pop-to-buffer
(get-buffer-create (get-buffer-create " *Org todo*"))
'(org-display-buffer-split (direction . down))))
;; Fill text in *Org todo* buffer.
(erase-buffer)
;; Copy `org-done-keywords' from the original Org buffer to be
;; used by `org-get-todo-face'.
(setq-local org-done-keywords done-keywords)
;; Show todo keyword sequences and bindings in a grid.
;; Each todo keyword in the grid occupies FIELD-WIDTH characters.
;; The keywords are filled up to `window-width'.
(setq field-number 0)
(while (setq todo-binding-spec (pop todo-alist-tail))
(pcase todo-binding-spec
;; Group keywords as { KWD1 KWD2 ... }
(`(:startgroup)
(unless (= field-number 0)
(setq field-number 0)
(insert "\n"))
(setq prompt (concat prompt "{"))
(insert "{ "))
(`(:endgroup)
(setq field-number 0
;; End of a group. Reset flag indicating preferred keyword sequence.
in-preferred-sequence nil)
(setq prompt (concat prompt "}"))
(insert "}\n"))
(`(:newline)
(unless (= field-number 0)
(insert "\n")
(setq field-number 0)
(setq todo-binding-spec (car todo-alist-tail))
(while (equal (car todo-alist-tail) '(:newline))
(insert "\n")
(pop todo-alist-tail))))
(_
(setq todo-keyword (car todo-binding-spec)
todo-char (cdr todo-binding-spec))
;; For the first keyword in a preferred sequence, set flag.
(if (equal todo-keyword preferred-sequence-head)
(setq in-preferred-sequence t))
;; Store the preferred todo keyword sequence.
(when in-preferred-sequence (push todo-binding-spec preferred-todo-alist))
;; Assign face to the todo keyword.
(setq todo-keyword
(org-add-props
todo-keyword nil
'face (org-get-todo-face todo-keyword)))
(when (= field-number 0) (insert " "))
(setq prompt (concat prompt "[" (char-to-string todo-char) "] " todo-keyword " "))
(insert "[" todo-char "] " todo-keyword
;; Fill spaces up to FIELD-WIDTH.
(make-string
(- field-width 4 (length todo-keyword)) ?\ ))
;; Last column in the row.
(when (and (= (setq field-number (1+ field-number))
(/ (- (window-width) 4) field-width))
;; Avoid lines with just a closing delimiter.
(not (equal (car todo-alist-tail) '(:endgroup))))
(insert "\n")
(setq field-number 0)))))
(insert "\n")
(goto-char (point-min))
(unless expert-interface (org-fit-window-to-buffer))
(message (concat "[a-z..]:Set [SPC]:clear"
(if expert-interface (concat "\n" prompt) "")))
;; Read the todo keyword input and exit.
(setq input-char
(let ((inhibit-quit t)) ; intercept C-g.
(read-char-exclusive)))
;; Restore the original keyword order. Previously, it was reversed using `push'.
(setq preferred-todo-alist (nreverse preferred-todo-alist))
(cond
((equal input-char ?\s) nil)
((or (= input-char ?\C-g)
(and (= input-char ?q) (not (rassoc input-char todo-alist))))
(signal 'quit nil))
((setq todo-binding-spec (or
;; Prefer bindings from todo sequence containing CURRENT-TODO-KEYWORD.
(rassoc input-char preferred-todo-alist)
(rassoc input-char todo-alist))
todo-keyword (car todo-binding-spec))
todo-keyword)
(t (signal 'quit nil)))))))
(defun org-entry-is-todo-p ()
(member (org-get-todo-state) org-not-done-keywords))
(defun org-entry-is-done-p ()
(member (org-get-todo-state) org-done-keywords))
(defun org-get-todo-state ()
"Return the TODO keyword of the current subtree."
(save-excursion
(org-back-to-heading t)
(and (let ((case-fold-search nil))
(looking-at org-todo-line-regexp))
(match-end 2)
(match-string 2))))
(defun org-at-date-range-p (&optional inactive-ok)
"Non-nil if point is inside a date range.
When optional argument INACTIVE-OK is non-nil, also consider
inactive time ranges.
When this function returns a non-nil value, match data is set
according to `org-tr-regexp-both' or `org-tr-regexp', depending
on INACTIVE-OK."
(save-excursion
(catch 'exit
(let ((pos (point)))
(skip-chars-backward "^[<\r\n")
(skip-chars-backward "<[")
(and (looking-at (if inactive-ok org-tr-regexp-both org-tr-regexp))
(>= (match-end 0) pos)
(throw 'exit t))
(skip-chars-backward "^<[\r\n")
(skip-chars-backward "<[")
(and (looking-at (if inactive-ok org-tr-regexp-both org-tr-regexp))
(>= (match-end 0) pos)
(throw 'exit t)))
nil)))
(defun org-get-repeat (&optional timestamp)
"Check if there is a timestamp with repeater in this entry.
Return the repeater, as a string, or nil. Also return nil when
this function is called before first heading.
When optional argument TIMESTAMP is a string, extract the
repeater from there instead."
(save-match-data
(cond
(timestamp
(and (string-match org-repeat-re timestamp)
(match-string-no-properties 1 timestamp)))
((org-before-first-heading-p) nil)
(t
(save-excursion
(org-back-to-heading t)
(let ((end (org-entry-end-position)))
(catch :repeat
(while (re-search-forward org-repeat-re end t)
(when (save-match-data (org-at-timestamp-p 'agenda))
(throw :repeat (match-string-no-properties 1)))))))))))
(defvar org-last-changed-timestamp)
(defvar org-last-inserted-timestamp)
(defvar org-log-post-message)
(defvar org-log-note-purpose)
(defvar org-log-note-how nil)
(defvar org-log-note-extra)
(defvar org-log-setup nil)
(defun org-auto-repeat-maybe (done-word)
"Check if the current headline contains a repeated timestamp.
If yes, set TODO state back to what it was and change the base date
of repeating deadline/scheduled time stamps to new date.
This function is run automatically after each state change to a DONE state."
(let* ((repeat (org-get-repeat))
(aa (assoc org-last-state org-todo-kwd-alist))
(interpret (nth 1 aa))
(head (nth 2 aa))
(whata '(("h" . hour) ("d" . day) ("m" . month) ("y" . year)))
(msg "Entry repeats: ")
(org-log-done nil)
(org-todo-log-states nil)
(end (copy-marker (org-entry-end-position))))
(when (and repeat (not (= 0 (string-to-number (substring repeat 1)))))
(when (eq org-log-repeat t) (setq org-log-repeat 'state))
(let ((to-state
(or (org-entry-get nil "REPEAT_TO_STATE" 'selective)
(and (stringp org-todo-repeat-to-state)
org-todo-repeat-to-state)
(and org-todo-repeat-to-state org-last-state))))
(org-todo (cond ((and to-state (member to-state org-todo-keywords-1))
to-state)
((eq interpret 'type) org-last-state)
(head)
(t 'none))))
(org-back-to-heading t)
(org-add-planning-info nil nil 'closed)
;; When `org-log-repeat' is non-nil or entry contains
;; a clock, set LAST_REPEAT property.
(when (or org-log-repeat
(catch :clock
(save-excursion
(while (re-search-forward org-clock-line-re end t)
(when (org-at-clock-log-p) (throw :clock t))))))
(org-entry-put nil "LAST_REPEAT" (format-time-string
(org-time-stamp-format t t)
(org-current-effective-time))))
(when org-log-repeat
(if org-log-setup
;; We are already setup for some record.
(when (eq org-log-repeat 'note)
;; Make sure we take a note, not only a time stamp.
(setq org-log-note-how 'note))
;; Set up for taking a record.
(org-add-log-setup 'state
(or done-word (car org-done-keywords))
org-last-state
org-log-repeat)))
;; Timestamps without a repeater are usually skipped. However,
;; a SCHEDULED timestamp without one is removed, as they are no
;; longer relevant.
(save-excursion
(let ((scheduled (org-entry-get (point) "SCHEDULED")))
(when (and scheduled (not (string-match-p org-repeat-re scheduled)))
(org-remove-timestamp-with-keyword org-scheduled-string))))
;; Update every timestamp with a repeater in the entry.
(let ((planning-re (regexp-opt
(list org-scheduled-string org-deadline-string))))
(while (re-search-forward org-repeat-re end t)
(let* ((ts (match-string 0))
(type (if (not (org-at-planning-p)) "Plain:"
(save-excursion
(re-search-backward
planning-re (line-beginning-position) t)
(match-string 0)))))
(when (and (org-at-timestamp-p 'agenda)
(string-match "\\([.+]\\)?\\(\\+[0-9]+\\)\\([hdwmy]\\)" ts))
(let ((n (string-to-number (match-string 2 ts)))
(what (match-string 3 ts)))
(when (equal what "w") (setq n (* n 7) what "d"))
(when (and (equal what "h")
(not (string-match-p "[0-9]\\{1,2\\}:[0-9]\\{2\\}"
ts)))
(user-error
"Cannot repeat in %d hour(s) because no hour has been set"
n))
;; Preparation, see if we need to modify the start
;; date for the change.
(when (match-end 1)
(let ((time (save-match-data (org-time-string-to-time ts)))
(repeater-type (match-string 1 ts)))
(cond
((equal "." repeater-type)
;; Shift starting date to today, or now if
;; repeater is by hours.
(if (equal what "h")
(org-timestamp-change
(floor (- (org-timestamp-to-now ts t)) 60) 'minute)
(org-timestamp-change
(- (org-today) (time-to-days time)) 'day)))
((equal "+" repeater-type)
(let ((nshiftmax 10)
(nshift 0))
(while (or (= nshift 0)
(if (equal what "h")
(not (time-less-p nil time))
(>= (org-today)
(time-to-days time))))
(when (= nshiftmax (cl-incf nshift))
(or (y-or-n-p
(format "%d repeater intervals were not \
enough to shift date past today. Continue? "
nshift))
(user-error "Abort")))
(org-timestamp-change n (cdr (assoc what whata)))
(org-in-regexp org-ts-regexp3)
(setq ts (match-string 1))
(setq time
(save-match-data
(org-time-string-to-time ts)))))
(org-timestamp-change (- n) (cdr (assoc what whata)))
;; Rematch, so that we have everything in place
;; for the real shift.
(org-in-regexp org-ts-regexp3)
(setq ts (match-string 1))
(string-match "\\([.+]\\)?\\(\\+[0-9]+\\)\\([hdwmy]\\)"
ts)))))
(save-excursion
(org-timestamp-change n (cdr (assoc what whata)) nil t))
(setq msg
(concat msg type " " org-last-changed-timestamp " ")))))))
(run-hooks 'org-todo-repeat-hook)
(setq org-log-post-message msg)
(message msg))))
(defun org-show-todo-tree (arg)
"Make a compact tree which shows all headlines marked with TODO.
The tree will show the lines where the regexp matches, and all higher
headlines above the match.
With a `\\[universal-argument]' prefix, prompt for a regexp to match.
With a numeric prefix N, construct a sparse tree for the Nth element
of `org-todo-keywords-1'."
(interactive "P")
(let ((case-fold-search nil)
(kwd-re
(cond ((null arg) (concat org-not-done-regexp "\\s-"))
((equal arg '(4))
(let ((kwd
(completing-read "Keyword (or KWD1|KWD2|...): "
(mapcar #'list org-todo-keywords-1))))
(concat "\\("
(mapconcat #'regexp-quote (org-split-string kwd "|") "\\|")
"\\)\\(?:[ \t]\\|$\\)")))
((<= (prefix-numeric-value arg) (length org-todo-keywords-1))
(regexp-quote (nth (1- (prefix-numeric-value arg))
org-todo-keywords-1)))
(t (user-error "Invalid prefix argument: %s" arg)))))
(message "%d TODO entries found"
(org-occur (concat "^" org-outline-regexp " *" kwd-re )))))
(defun org--deadline-or-schedule (arg type time)
"Insert DEADLINE or SCHEDULE information in current entry.
TYPE is either `deadline' or `scheduled'. See `org-deadline' or
`org-schedule' for information about ARG and TIME arguments."
(org-fold-core-ignore-modifications
(let* ((deadline? (eq type 'deadline))
(keyword (if deadline? org-deadline-string org-scheduled-string))
(log (if deadline? org-log-redeadline org-log-reschedule))
(old-date (org-entry-get nil (if deadline? "DEADLINE" "SCHEDULED")))
(old-date-time (and old-date (org-time-string-to-time old-date)))
;; Save repeater cookie from either TIME or current scheduled
;; time stamp. We are going to insert it back at the end of
;; the process.
(repeater (or (and (org-string-nw-p time)
;; We use `org-ts-regexp-both' because we
;; need to tell the difference between a
;; real repeater and a time delta, e.g.
;; "+2d".
(string-match-p org-ts-regexp-both time)
(string-match "\\([.+-]+[0-9]+[hdwmy]\
\\(?:[/ ][-+]?[0-9]+[hdwmy]\\)?\\)"
time)
(match-string 1 time))
(and (org-string-nw-p old-date)
(string-match "\\([.+-]+[0-9]+[hdwmy]\
\\(?:[/ ][-+]?[0-9]+[hdwmy]\\)?\\)"
old-date)
(match-string 1 old-date)))))
(pcase arg
(`(4)
(if (not old-date)
(message (if deadline? "Entry had no deadline to remove"
"Entry was not scheduled"))
(when (and old-date log)
(org-add-log-setup (if deadline? 'deldeadline 'delschedule)
nil old-date log))
(org-remove-timestamp-with-keyword keyword)
(message (if deadline? "Entry no longer has a deadline."
"Entry is no longer scheduled."))))
(`(16)
(save-excursion
(org-back-to-heading t)
(let ((regexp (if deadline? org-deadline-time-regexp
org-scheduled-time-regexp)))
(if (not (re-search-forward regexp (line-end-position 2) t))
(user-error (if deadline? "No deadline information to update"
"No scheduled information to update"))
(let* ((rpl0 (match-string 1))
(rpl (replace-regexp-in-string " -[0-9]+[hdwmy]" "" rpl0))
(msg (if deadline? "Warn starting from" "Delay until")))
(replace-match
(concat keyword
" <" rpl
(format " -%dd"
(abs (- (time-to-days
(save-match-data
(org-read-date
nil t nil msg old-date-time)))
(time-to-days old-date-time))))
">") t t))))))
(_
(org-add-planning-info type time 'closed)
(when (and old-date
log
(not (equal old-date org-last-inserted-timestamp)))
(org-add-log-setup (if deadline? 'redeadline 'reschedule)
org-last-inserted-timestamp
old-date
log))
(when repeater
(save-excursion
(org-back-to-heading t)
(when (re-search-forward
(concat keyword " " org-last-inserted-timestamp)
(line-end-position 2)
t)
(goto-char (1- (match-end 0)))
(insert-and-inherit " " repeater)
(setq org-last-inserted-timestamp
(concat (substring org-last-inserted-timestamp 0 -1)
" " repeater
(substring org-last-inserted-timestamp -1))))))
(message (if deadline? "Deadline on %s" "Scheduled to %s")
org-last-inserted-timestamp))))))
(defun org-deadline (arg &optional time)
"Insert a \"DEADLINE:\" string with a timestamp to make a deadline.
When called interactively, this command pops up the Emacs calendar to let
the user select a date.
With one universal prefix argument, remove any deadline from the item.
With two universal prefix arguments, prompt for a warning delay.
With argument TIME, set the deadline at the corresponding date. TIME
can either be an Org date like \"2011-07-24\" or a delta like \"+2d\"."
(interactive "P")
(if (and (org-region-active-p) org-loop-over-headlines-in-active-region)
(org-map-entries
(lambda () (org--deadline-or-schedule arg 'deadline time))
nil
(if (eq org-loop-over-headlines-in-active-region 'start-level)
'region-start-level
'region)
(lambda () (when (org-invisible-p) (org-end-of-subtree nil t))))
(org--deadline-or-schedule arg 'deadline time)))
(defun org-schedule (arg &optional time)
"Insert a \"SCHEDULED:\" string with a timestamp to schedule an item.
When called interactively, this command pops up the Emacs calendar to let
the user select a date.
With one universal prefix argument, remove any scheduling date from the item.
With two universal prefix arguments, prompt for a delay cookie.
With argument TIME, scheduled at the corresponding date. TIME can
either be an Org date like \"2011-07-24\" or a delta like \"+2d\"."
(interactive "P")
(if (and (org-region-active-p) org-loop-over-headlines-in-active-region)
(org-map-entries
(lambda () (org--deadline-or-schedule arg 'scheduled time))
nil
(if (eq org-loop-over-headlines-in-active-region 'start-level)
'region-start-level
'region)
(lambda () (when (org-invisible-p) (org-end-of-subtree nil t))))
(org--deadline-or-schedule arg 'scheduled time)))
(defun org-get-scheduled-time (pom &optional inherit)
"Get the scheduled time as a time tuple, of a format suitable
for calling org-schedule with, or if there is no scheduling,
returns nil."
(let ((time (org-entry-get pom "SCHEDULED" inherit)))
(when time
(org-time-string-to-time time))))
(defun org-get-deadline-time (pom &optional inherit)
"Get the deadline as a time tuple, of a format suitable for
calling org-deadline with, or if there is no scheduling, returns
nil."
(let ((time (org-entry-get pom "DEADLINE" inherit)))
(when time
(org-time-string-to-time time))))
(defun org-remove-timestamp-with-keyword (keyword)
"Remove all time stamps with KEYWORD in the current entry."
(let ((re (concat "\\<" (regexp-quote keyword) " +<[^>\n]+>[ \t]*"))
beg)
(save-excursion
(org-back-to-heading t)
(setq beg (point))
(outline-next-heading)
(while (re-search-backward re beg t)
(replace-match "")
(if (and (string-match "\\S-" (buffer-substring (line-beginning-position) (point)))
(equal (char-before) ?\ ))
(delete-char -1)
(when (string-match "^[ \t]*$" (buffer-substring
(line-beginning-position) (line-end-position)))
(delete-region (line-beginning-position)
(min (point-max) (1+ (line-end-position))))))))))
(defvar org-time-was-given) ; dynamically scoped parameter
(defvar org-end-time-was-given) ; dynamically scoped parameter
(defun org-at-planning-p ()
"Non-nil when point is on a planning info line."
;; This is as accurate and faster than `org-element-at-point' since
;; planning info location is fixed in the section.
(or (let ((cached (org-element-at-point nil 'cached)))
(and cached (org-element-type-p cached 'planning)))
(org-with-wide-buffer
(forward-line 0)
(and (looking-at-p org-planning-line-re)
(eq (point)
(ignore-errors
(if (and (featurep 'org-inlinetask) (org-inlinetask-in-task-p))
(org-back-to-heading t)
(org-with-limited-levels (org-back-to-heading t)))
(line-beginning-position 2)))))))
(defun org-add-planning-info (what &optional time &rest remove)
"Insert new timestamp with keyword in the planning line.
WHAT indicates what kind of time stamp to add. It is a symbol
among `closed', `deadline', `scheduled' and nil. TIME indicates
the time to use. If none is given, the user is prompted for
a date. REMOVE indicates what kind of entries to remove. An old
WHAT entry will also be removed."
(org-fold-core-ignore-modifications
(let (org-time-was-given org-end-time-was-given default-time default-input)
(when (and (memq what '(scheduled deadline))
(or (not time)
(and (stringp time)
(string-match "^[-+]+[0-9]" time))))
;; Try to get a default date/time from existing timestamp
(save-excursion
(org-back-to-heading t)
(let ((end (save-excursion (outline-next-heading) (point))) ts)
(when (re-search-forward (if (eq what 'scheduled)
org-scheduled-time-regexp
org-deadline-time-regexp)
end t)
(setq ts (match-string 1)
default-time (org-time-string-to-time ts)
default-input (and ts (org-get-compact-tod ts)))))))
(when what
(setq time
(if (stringp time)
;; This is a string (relative or absolute), set
;; proper date.
(org-encode-time
(org-read-date-analyze
time default-time (decode-time default-time)))
;; If necessary, get the time from the user
(or time (org-read-date nil 'to-time nil
(cl-case what
(deadline "DEADLINE")
(scheduled "SCHEDULED")
(otherwise nil))
default-time default-input)))))
(org-with-wide-buffer
(org-back-to-heading t)
(let ((planning? (save-excursion
(forward-line)
(looking-at-p org-planning-line-re))))
(cond
(planning?
(forward-line)
;; Move to current indentation.
(skip-chars-forward " \t")
;; Check if we have to remove something.
(dolist (type (if what (cons what remove) remove))
(save-excursion
(when (re-search-forward
(cl-case type
(closed org-closed-time-regexp)
(deadline org-deadline-time-regexp)
(scheduled org-scheduled-time-regexp)
(otherwise (error "Invalid planning type: %s" type)))
(line-end-position)
t)
;; Delete until next keyword or end of line.
(delete-region
(match-beginning 0)
(if (re-search-forward org-keyword-time-not-clock-regexp
(line-end-position)
t)
(match-beginning 0)
(line-end-position))))))
;; If there is nothing more to add and no more keyword is
;; left, remove the line completely.
(if (and (looking-at-p "[ \t]*$") (not what))
(delete-region (line-end-position 0)
(line-end-position))
;; If we removed last keyword, do not leave trailing white
;; space at the end of line.
(let ((p (point)))
(save-excursion
(end-of-line)
(unless (= (skip-chars-backward " \t" p) 0)
(delete-region (point) (line-end-position)))))))
(what
(end-of-line)
(insert-and-inherit "\n")
(when org-adapt-indentation
(indent-to-column (1+ (org-outline-level)))))
(t nil)))
(when what
;; Insert planning keyword.
(insert-and-inherit (cl-case what
(closed org-closed-string)
(deadline org-deadline-string)
(scheduled org-scheduled-string)
(otherwise (error "Invalid planning type: %s" what)))
" ")
;; Insert associated timestamp.
(let ((ts (org-insert-timestamp
time
(or org-time-was-given
(and (eq what 'closed) org-log-done-with-time))
(eq what 'closed)
nil nil (list org-end-time-was-given))))
(unless (eolp) (insert " "))
ts))))))
(defvar org-log-note-marker (make-marker)
"Marker pointing at the entry where the note is to be inserted.")
(defvar org-log-note-purpose nil)
(defvar org-log-note-state nil)
(defvar org-log-note-previous-state nil)
(defvar org-log-note-extra nil)
(defvar org-log-note-window-configuration nil)
(defvar org-log-note-return-to (make-marker))
(defvar org-log-note-effective-time nil
"Remembered current time.
So that dynamically scoped `org-extend-today-until' affects
timestamps in state change log.")
(defvar org-log-note-this-command
"`this-command' when `org-add-log-setup' is called.")
(defvar org-log-note-recursion-depth
"`recursion-depth' when `org-add-log-setup' is called.")
(defvar org-log-post-message nil
"Message to be displayed after a log note has been stored.
The auto-repeater uses this.")
(defun org-add-note ()
"Add a note to the current entry.
This is done in the same way as adding a state change note."
(interactive)
(org-add-log-setup 'note))
(defun org-log-beginning (&optional create)
"Return expected start of log notes in current entry.
When optional argument CREATE is non-nil, the function creates
a drawer to store notes, if necessary. Returned position ignores
narrowing."
(org-with-wide-buffer
(let ((drawer (org-log-into-drawer)))
(cond
(drawer
;; This either moves past planning and property drawer, to
;; first line below heading, or to `eob' (if heading is the
;; last heading in buffer without contents).
(org-end-of-meta-data)
(let ((regexp (concat "^[ \t]*:" (regexp-quote drawer) ":[ \t]*$"))
(end (if (org-at-heading-p) (point)
(save-excursion (outline-next-heading) (point))))
(case-fold-search t))
(catch 'exit
;; Try to find existing drawer.
(while (re-search-forward regexp end t)
(let ((element (org-element-at-point)))
(when (org-element-type-p element 'drawer)
(let ((cend (org-element-contents-end element)))
(when (and (not org-log-states-order-reversed) cend)
(goto-char cend)))
(throw 'exit nil))))
;; No drawer found. Create one, if permitted.
(when create
;; `org-end-of-meta-data' ended up at next heading
;; * Heading to insert darawer<maybe folded>
;; * Another heading
;;
;; Unless current heading is the last heading in buffer
;; and does not have a newline, `org-end-of-meta-data'
;; can move us to the next heading.
;; Avoid situation when we insert drawer right before
;; first "*". Otherwise, if the heading is folded, we
;; are inserting after visible newline at the end of the
;; fold, thus breaking the fold continuity.
(unless (eobp)
(when (org-at-heading-p) (backward-char)))
(org-fold-core-ignore-modifications
(let (;; Heading
;; <point>
;; Text
(at-blank-line? (looking-at-p "^[ \t]*$"))
;; Heading
;; <point>Text
(at-beginning-of-non-blank-line?
(and (bolp) (not (eolp)))))
(unless (bolp)
;; Heading<point> (see `backward-char' branch above)
(insert-and-inherit "\n"))
(let ((beg (point)) cbeg)
(insert-and-inherit ":" drawer ":")
(setq cbeg (point))
(insert-and-inherit "\n:END:")
(cond
(at-blank-line?
;; Heading
;; :LOGBOOK:
;; :END:
;;
;; Text
(insert "\n")
(backward-char))
(at-beginning-of-non-blank-line?
;; Heading
;; :LOGBOOK:
;; :END:
;; Text
(insert "\n")
(backward-char)))
(org-indent-region beg (point))
(org-fold-region cbeg (point) t 'drawer)))))
(end-of-line 0))))
(t
(org-end-of-meta-data org-log-state-notes-insert-after-drawers)
(let ((endpos (point)))
(skip-chars-forward " \t\n")
(forward-line 0)
(unless org-log-states-order-reversed
(org-skip-over-state-notes)
(skip-chars-backward " \t\n")
(forward-line 1))
;; When current headline is at the end of buffer and does not
;; end with trailing newline the above can move to the
;; beginning of the headline.
(when (< (point) endpos) (goto-char endpos))))))
(if (bolp) (point) (line-beginning-position 2))))
(defun org-add-log-setup (&optional purpose state prev-state how extra)
"Set up the post command hook to take a note.
If this is about to TODO state change, the new state is expected in STATE.
HOW is an indicator what kind of note should be created.
EXTRA is additional text that will be inserted into the notes buffer."
(move-marker org-log-note-marker (point))
(setq org-log-note-purpose purpose
org-log-note-state state
org-log-note-previous-state prev-state
org-log-note-how how
org-log-note-extra extra
org-log-note-effective-time (org-current-effective-time)
org-log-note-this-command this-command
org-log-note-recursion-depth (recursion-depth)
org-log-setup t)
(add-hook 'post-command-hook 'org-add-log-note 'append))
(defun org-skip-over-state-notes ()
"Skip past the list of State notes in an entry.
The point is assumed to be on a list of State notes, each matching
`org-log-note-headings'. The function moves point to the first list
item that is not a State note or to the end of the list if all the
items are State notes."
(when (ignore-errors (goto-char (org-in-item-p)))
(let* ((struct (org-list-struct))
(prevs (org-list-prevs-alist struct))
(regexp
(concat "[ \t]*- +"
(replace-regexp-in-string
" +" " +"
(org-replace-escapes
(regexp-quote (cdr (assq 'state org-log-note-headings)))
`(("%d" . ,org-ts-regexp-inactive)
("%D" . ,org-ts-regexp)
("%s" . "\\(?:\"\\S-+\"\\)?")
("%S" . "\\(?:\"\\S-+\"\\)?")
("%t" . ,org-ts-regexp-inactive)
("%T" . ,org-ts-regexp)
("%u" . ".*?")
("%U" . ".*?")))))))
(while (looking-at-p regexp)
(goto-char (or (org-list-get-next-item (point) struct prevs)
(org-list-get-item-end (point) struct)))))))
(defun org-add-log-note (&optional _purpose)
"Pop up a window for taking a note, and add this note later."
(when (and (equal org-log-note-this-command this-command)
(= org-log-note-recursion-depth (recursion-depth)))
(remove-hook 'post-command-hook 'org-add-log-note)
(setq org-log-setup nil)
(setq org-log-note-window-configuration (current-window-configuration))
(move-marker org-log-note-return-to (point))
(pop-to-buffer (marker-buffer org-log-note-marker) '(org-display-buffer-full-frame))
(goto-char org-log-note-marker)
(pop-to-buffer "*Org Note*" '(org-display-buffer-split))
(erase-buffer)
(if (memq org-log-note-how '(time state))
(org-store-log-note)
(let ((org-inhibit-startup t)) (org-mode))
(insert (format "# Insert note for %s.
# Finish with C-c C-c, or cancel with C-c C-k.\n\n"
(cl-case org-log-note-purpose
(clock-out "stopped clock")
(done "closed todo item")
(reschedule "rescheduling")
(delschedule "no longer scheduled")
(redeadline "changing deadline")
(deldeadline "removing deadline")
(refile "refiling")
(note "this entry")
(state
(format "state change from \"%s\" to \"%s\""
(or org-log-note-previous-state "")
(or org-log-note-state "")))
(t (error "This should not happen")))))
(when org-log-note-extra (insert org-log-note-extra))
(setq-local org-finish-function 'org-store-log-note)
(run-hooks 'org-log-buffer-setup-hook))))
(defvar org-note-abort nil) ; dynamically scoped
(defun org-store-log-note ()
"Finish taking a log note, and insert it to where it belongs."
(let ((txt (prog1 (buffer-string)
(kill-buffer)))
(note (cdr (assq org-log-note-purpose org-log-note-headings)))
lines)
(while (string-match "\\`# .*\n[ \t\n]*" txt)
(setq txt (replace-match "" t t txt)))
(when (string-match "\\s-+\\'" txt)
(setq txt (replace-match "" t t txt)))
(setq lines (and (not (equal "" txt)) (org-split-string txt "\n")))
(when (org-string-nw-p note)
(setq note
(org-replace-escapes
note
(list (cons "%u" (user-login-name))
(cons "%U" user-full-name)
(cons "%t" (format-time-string
(org-time-stamp-format 'long 'inactive)
org-log-note-effective-time))
(cons "%T" (format-time-string
(org-time-stamp-format 'long nil)
org-log-note-effective-time))
(cons "%d" (format-time-string
(org-time-stamp-format nil 'inactive)
org-log-note-effective-time))
(cons "%D" (format-time-string
(org-time-stamp-format nil nil)
org-log-note-effective-time))
(cons "%s" (cond
((not org-log-note-state) "")
((string-match-p org-ts-regexp
org-log-note-state)
(format "\"[%s]\""
(substring org-log-note-state 1 -1)))
(t (format "\"%s\"" org-log-note-state))))
(cons "%S"
(cond
((not org-log-note-previous-state) "")
((string-match-p org-ts-regexp
org-log-note-previous-state)
(format "\"[%s]\""
(substring
org-log-note-previous-state 1 -1)))
(t (format "\"%s\""
org-log-note-previous-state)))))))
(when lines (setq note (concat note " \\\\")))
(push note lines))
(when (and lines (not org-note-abort))
(with-current-buffer (marker-buffer org-log-note-marker)
(org-fold-core-ignore-modifications
(org-with-wide-buffer
;; Find location for the new note.
(goto-char org-log-note-marker)
(set-marker org-log-note-marker nil)
;; Note associated to a clock is to be located right after
;; the clock. Do not move point.
(unless (eq org-log-note-purpose 'clock-out)
(goto-char (org-log-beginning t)))
;; Make sure point is at the beginning of an empty line.
(cond ((not (bolp)) (let ((inhibit-read-only t)) (insert-and-inherit "\n")))
((looking-at "[ \t]*\\S-") (save-excursion (insert-and-inherit "\n"))))
;; In an existing list, add a new item at the top level.
;; Otherwise, indent line like a regular one.
(let ((itemp (org-in-item-p)))
(if itemp
(indent-line-to
(let ((struct (save-excursion
(goto-char itemp) (org-list-struct))))
(org-list-get-ind (org-list-get-top-point struct) struct)))
(org-indent-line)))
(insert-and-inherit (org-list-bullet-string "-") (pop lines))
(let ((ind (org-list-item-body-column (line-beginning-position))))
(dolist (line lines)
(insert-and-inherit "\n")
(unless (string-empty-p line)
(indent-line-to ind)
(insert-and-inherit line))))
(run-hooks 'org-after-note-stored-hook)
(message "Note stored")
(org-back-to-heading t))))))
;; Don't add undo information when called from `org-agenda-todo'.
(set-window-configuration org-log-note-window-configuration)
(with-current-buffer (marker-buffer org-log-note-return-to)
(goto-char org-log-note-return-to))
(move-marker org-log-note-return-to nil)
(when org-log-post-message (message "%s" org-log-post-message)))
(defun org-remove-empty-drawer-at (pos)
"Remove an empty drawer at position POS.
POS may also be a marker."
(with-current-buffer (if (markerp pos) (marker-buffer pos) (current-buffer))
(org-with-wide-buffer
(goto-char pos)
(let ((drawer (org-element-at-point)))
(when (and (org-element-type-p drawer '(drawer property-drawer))
(not (org-element-contents-begin drawer)))
(delete-region (org-element-begin drawer)
(progn (goto-char (org-element-end drawer))
(skip-chars-backward " \r\t\n")
(forward-line)
(point))))))))
(defvar org-ts-type nil)
(defun org-sparse-tree (&optional arg type)
"Create a sparse tree, prompt for the details.
This command can create sparse trees. You first need to select the type
of match used to create the tree:
t Show all TODO entries.
T Show entries with a specific TODO keyword.
m Show entries selected by a tags/property match.
p Enter a property name and its value (both with completion on existing
names/values) and show entries with that property.
r Show entries matching a regular expression (`/' can be used as well).
b Show deadlines and scheduled items before a date.
a Show deadlines and scheduled items after a date.
d Show deadlines due within `org-deadline-warning-days'.
D Show deadlines and scheduled items between a date range."
(interactive "P")
(setq type (or type org-sparse-tree-default-date-type))
(setq org-ts-type type)
(message "Sparse tree: [r]egexp [t]odo [T]odo-kwd [m]atch [p]roperty
[d]eadlines [b]efore-date [a]fter-date [D]ates range
[c]ycle through date types: %s"
(cl-case type
(all "all timestamps")
(scheduled "only scheduled")
(deadline "only deadline")
(active "only active timestamps")
(inactive "only inactive timestamps")
(closed "with a closed timestamp")
(otherwise "scheduled/deadline")))
(let ((answer (read-char-exclusive)))
(cl-case answer
(?c
(org-sparse-tree
arg
(cadr
(memq type '(nil all scheduled deadline active inactive closed)))))
(?d (call-interactively 'org-check-deadlines))
(?b (call-interactively 'org-check-before-date))
(?a (call-interactively 'org-check-after-date))
(?D (call-interactively 'org-check-dates-range))
(?t (call-interactively 'org-show-todo-tree))
(?T (org-show-todo-tree '(4)))
(?m (call-interactively 'org-match-sparse-tree))
((?p ?P)
(let* ((kwd (completing-read
"Property: " (mapcar #'list (org-buffer-property-keys))))
(kwd
;; Escape "-" in property names.
(replace-regexp-in-string "-" "\\\\-" kwd))
(value (completing-read
"Value: " (mapcar #'list (org-property-values kwd)))))
(unless (string-match "\\`{.*}\\'" value)
(setq value (concat "\"" value "\"")))
(org-match-sparse-tree arg (concat kwd "=" value))))
((?r ?R ?/) (call-interactively 'org-occur))
(otherwise (user-error "No such sparse tree command \"%c\"" answer)))))
(defvar-local org-occur-highlights nil
"List of overlays used for occur matches.")
(put 'org-occur-highlights 'permanent-local t)
(defvar-local org-occur-parameters nil
"Parameters of the active org-occur calls.
This is a list, each call to org-occur pushes as cons cell,
containing the regular expression and the callback, onto the list.
The list can contain several entries if `org-occur' has been called
several time with the KEEP-PREVIOUS argument. Otherwise, this list
will only contain one set of parameters. When the highlights are
removed (for example with \\`C-c C-c', or with the next edit (depending
on `org-remove-highlights-with-change'), this variable is emptied
as well.")
(defun org-occur (regexp &optional keep-previous callback)
"Make a compact tree showing all matches of REGEXP.
The tree will show the lines where the regexp matches, and any other context
defined in `org-fold-show-context-detail', which see.
When optional argument KEEP-PREVIOUS is non-nil, highlighting and exposing
done by a previous call to `org-occur' will be kept, to allow stacking of
calls to this command.
Optional argument CALLBACK can be a function of no argument. In this case,
it is called with point at the end of the match, match data being set
accordingly. Current match is shown only if the return value is non-nil.
The function must neither move point nor alter narrowing."
(interactive "sRegexp: \nP")
(when (equal regexp "")
(user-error "Regexp cannot be empty"))
(unless keep-previous
(org-remove-occur-highlights nil nil t))
(push (cons regexp callback) org-occur-parameters)
(let ((cnt 0))
(save-excursion
(goto-char (point-min))
(when (or (not keep-previous) ; do not want to keep
(not org-occur-highlights)) ; no previous matches
;; hide everything
(org-cycle-overview))
(let ((case-fold-search (if (eq org-occur-case-fold-search 'smart)
(isearch-no-upper-case-p regexp t)
org-occur-case-fold-search)))
(while (re-search-forward regexp nil t)
(when (or (not callback)
(save-match-data (funcall callback)))
(setq cnt (1+ cnt))
(when org-highlight-sparse-tree-matches
(org-highlight-new-match (match-beginning 0) (match-end 0)))
(org-fold-show-context 'occur-tree)))))
(when org-remove-highlights-with-change
(add-hook 'before-change-functions 'org-remove-occur-highlights
nil 'local))
(unless org-sparse-tree-open-archived-trees
(org-fold-hide-archived-subtrees (point-min) (point-max)))
(run-hooks 'org-occur-hook)
(when (called-interactively-p 'interactive)
(message "%d match(es) for regexp %s" cnt regexp))
cnt))
(defun org-occur-next-match (&optional n _reset)
"Function for `next-error-function' to find sparse tree matches.
N is the number of matches to move, when negative move backwards.
This function always goes back to the starting point when no
match is found."
(let* ((limit (if (< n 0) (point-min) (point-max)))
(search-func (if (< n 0)
'previous-single-char-property-change
'next-single-char-property-change))
(n (abs n))
(pos (point))
p1)
(catch 'exit
(while (setq p1 (funcall search-func (point) 'org-type))
(when (equal p1 limit)
(goto-char pos)
(user-error "No more matches"))
(when (equal (get-char-property p1 'org-type) 'org-occur)
(setq n (1- n))
(when (= n 0)
(goto-char p1)
(throw 'exit (point))))
(goto-char p1))
(goto-char p1)
(user-error "No more matches"))))
(defun org-highlight-new-match (beg end)
"Highlight from BEG to END and mark the highlight is an occur headline."
(let ((ov (make-overlay beg end)))
(overlay-put ov 'face 'secondary-selection)
(overlay-put ov 'org-type 'org-occur)
(push ov org-occur-highlights)))
(defun org-remove-occur-highlights (&optional _beg _end noremove)
"Remove the occur highlights from the buffer.
BEG and END are ignored. If NOREMOVE is nil, remove this function
from the `before-change-functions' in the current buffer."
(interactive)
(unless org-inhibit-highlight-removal
(mapc #'delete-overlay org-occur-highlights)
(setq org-occur-highlights nil)
(setq org-occur-parameters nil)
(unless noremove
(remove-hook 'before-change-functions
'org-remove-occur-highlights 'local))))
;;;; Priorities
(defvar org-priority-regexp ".*?\\(\\[#\\([A-Z0-9]+\\)\\] ?\\)"
"Regular expression matching the priority indicator.
A priority indicator can be e.g. [#A] or [#1].
This regular expression matches these groups:
0 : the whole match, e.g. \"TODO [#A] Hack\"
1 : the priority cookie, e.g. \"[#A]\"
2 : the value of the priority cookie, e.g. \"A\".")
(defun org-priority-up ()
"Increase the priority of the current item."
(interactive)
(org-priority 'up))
(defun org-priority-down ()
"Decrease the priority of the current item."
(interactive)
(org-priority 'down))
(defun org-priority (&optional action show)
"Change the priority of an item.
When called interactively with a `\\[universal-argument]' prefix,
show the priority in the minibuffer instead of changing it.
When called programmatically, ACTION can be `set', `up', `down',
or a character."
(interactive "P")
(when show
;; Deprecation warning inserted for Org 9.2; once enough time has
;; passed the SHOW argument should be removed.
(warn "`org-priority' called with deprecated SHOW argument"))
(if (equal action '(4))
(org-priority-show)
(unless org-priority-enable-commands
(user-error "Priority commands are disabled"))
(setq action (or action 'set))
(let ((nump (< org-priority-lowest 65))
current new news have remove)
(save-excursion
(org-back-to-heading t)
(when (looking-at org-priority-regexp)
(let ((ms (match-string 2)))
(setq current (org-priority-to-value ms)
have t)))
(cond
((eq action 'remove)
(setq remove t new ?\ ))
((or (eq action 'set)
(integerp action))
(if (not (eq action 'set))
(setq new action)
(setq
new
(if nump
(let* ((msg (format "Priority %s-%s, SPC to remove: "
(number-to-string org-priority-highest)
(number-to-string org-priority-lowest)))
(s (if (< 9 org-priority-lowest)
(read-string msg)
(message msg)
(char-to-string (read-char-exclusive)))))
(if (equal s " ") ?\s (string-to-number s)))
(progn (message "Priority %c-%c, SPC to remove: "
org-priority-highest org-priority-lowest)
(save-match-data
(setq new (read-char-exclusive)))))))
(when (and (= (upcase org-priority-highest) org-priority-highest)
(= (upcase org-priority-lowest) org-priority-lowest))
(setq new (upcase new)))
(cond ((equal new ?\s) (setq remove t))
((or (< (upcase new) org-priority-highest) (> (upcase new) org-priority-lowest))
(user-error
(if nump
"Priority must be between `%s' and `%s'"
"Priority must be between `%c' and `%c'")
org-priority-highest org-priority-lowest))))
((eq action 'up)
(setq new (if have
(1- current) ; normal cycling
;; last priority was empty
(if (eq last-command this-command)
org-priority-lowest ; wrap around empty to lowest
;; default
(if org-priority-start-cycle-with-default
org-priority-default
(1- org-priority-default))))))
((eq action 'down)
(setq new (if have
(1+ current) ; normal cycling
;; last priority was empty
(if (eq last-command this-command)
org-priority-highest ; wrap around empty to highest
;; default
(if org-priority-start-cycle-with-default
org-priority-default
(1+ org-priority-default))))))
(t (user-error "Invalid action")))
(when (or (< (upcase new) org-priority-highest)
(> (upcase new) org-priority-lowest))
(if (and (memq action '(up down))
(not have) (not (eq last-command this-command)))
;; `new' is from default priority
(error
"The default can not be set, see `org-priority-default' why")
;; normal cycling: `new' is beyond highest/lowest priority
;; and is wrapped around to the empty priority
(setq remove t)))
;; Numerical priorities are limited to 64, beyond that number,
;; assume the priority cookie is a character.
(setq news (if (> new 64) (format "%c" new) (format "%s" new)))
(if have
(if remove
(replace-match "" t t nil 1)
(replace-match news t t nil 2))
(if remove
(user-error "No priority cookie found in line")
(let ((case-fold-search nil)) (looking-at org-todo-line-regexp))
(if (match-end 2)
(progn
(goto-char (match-end 2))
(insert " [#" news "]"))
(goto-char (match-beginning 3))
(insert "[#" news "] "))))
(when org-auto-align-tags (org-align-tags)))
(if remove
(message "Priority removed")
(message "Priority of current item set to %s" news)))))
(defalias 'org-show-priority 'org-priority-show)
(defun org-priority-show ()
"Show the priority of the current item as number.
Return the priority value."
(interactive)
(let ((pri (if (eq major-mode 'org-agenda-mode)
(org-get-at-bol 'priority)
(save-excursion
(save-match-data
(forward-line 0)
(and (looking-at org-heading-regexp)
(org-get-priority (match-string 0))))))))
(message "Priority is %d" (if pri pri -1000))))
(defun org-get-priority (s)
"Find priority cookie and return priority.
S is a string against which you can match `org-priority-regexp'.
If `org-priority-get-priority-function' is set to a custom
function, use it. Otherwise process S and output the priority
value, an integer."
(save-match-data
(if (functionp org-priority-get-priority-function)
(funcall org-priority-get-priority-function s)
(if (not (string-match org-priority-regexp s))
(* 1000 (- org-priority-lowest org-priority-default))
(* 1000 (- org-priority-lowest
(org-priority-to-value (match-string 2 s))))))))
;;;; Tags
(defvar org-agenda-archives-mode)
(defvar org-map-continue-from nil
"Position from where mapping should continue.
Can be set by the action argument to `org-scan-tags' and `org-map-entries'.")
(defvar org-scanner-tags nil
"The current tag list while the tags scanner is running.")
(defvar org-trust-scanner-tags nil
"Should `org-get-tags' use the tags for the scanner.
This is for internal dynamical scoping only.
When this is non-nil, the function `org-get-tags' will return the value
of `org-scanner-tags' instead of building the list by itself. This
can lead to large speed-ups when the tags scanner is used in a file with
many entries, and when the list of tags is retrieved, for example to
obtain a list of properties. Building the tags list for each entry in such
a file becomes an N^2 operation - but with this variable set, it scales
as N.")
(defvar org--matcher-tags-todo-only nil)
(defun org-scan-tags (action matcher todo-only &optional start-level)
"Scan headline tags with inheritance and produce output ACTION.
ACTION can be `sparse-tree' to produce a sparse tree in the current buffer,
or `agenda' to produce an entry list for an agenda view. It can also be
a Lisp form or a function that should be called at each matched headline, in
this case the return value is a list of all return values from these calls.
MATCHER is a function accepting three arguments, returning
a non-nil value whenever a given set of tags qualifies a headline
for inclusion. See `org-make-tags-matcher' for more information.
As a special case, it can also be set to t (respectively nil) in
order to match all (respectively none) headline.
When TODO-ONLY is non-nil, only lines with a TODO keyword are
included in the output.
START-LEVEL can be a string with asterisks, reducing the scope to
headlines matching this string."
(require 'org-agenda)
(let* ((heading-re
(concat ;;FIXME: use cache
"^"
(if start-level
;; Get the correct level to match
(concat "\\*\\{" (number-to-string start-level) "\\} ")
org-outline-regexp)))
(props (list 'face 'default
'done-face 'org-agenda-done
'undone-face 'default
'mouse-face 'highlight
'org-not-done-regexp org-not-done-regexp
'org-todo-regexp org-todo-regexp
'org-complex-heading-regexp org-complex-heading-regexp
'help-echo
(format "mouse-2 or RET jump to Org file %S"
(abbreviate-file-name
(or (buffer-file-name (buffer-base-buffer))
(buffer-name (buffer-base-buffer)))))))
(org-map-continue-from nil)
tags-list rtn rtn1 level category txt
todo marker priority
ts-date ts-date-type ts-date-pair)
(unless (or (member action '(agenda sparse-tree)) (functionp action))
(setq action (list 'lambda nil action)))
(save-excursion
(goto-char (point-min))
(when (eq action 'sparse-tree)
(org-cycle-overview)
(org-remove-occur-highlights))
(org-element-cache-map
(lambda (el)
(goto-char (org-element-begin el))
(setq todo (org-element-property :todo-keyword el)
level (org-element-property :level el)
category (org-entry-get-with-inheritance "CATEGORY" nil el)
tags-list (org-get-tags el)
org-scanner-tags tags-list)
(when (eq action 'agenda)
(setq ts-date-pair (org-agenda-entry-get-agenda-timestamp el)
ts-date (car ts-date-pair)
ts-date-type (cdr ts-date-pair)))
(catch :skip
(when (and
;; eval matcher only when the todo condition is OK
(and (or (not todo-only) (member todo org-todo-keywords-1))
(if (functionp matcher)
(let ((case-fold-search t) (org-trust-scanner-tags t))
(funcall matcher todo tags-list level))
matcher))
;; Call the skipper, but return t if it does not
;; skip, so that the `and' form continues evaluating.
(progn
(unless (eq action 'sparse-tree) (org-agenda-skip el))
t)
;; Check if timestamps are deselecting this entry
(or (not todo-only)
(and (member todo org-todo-keywords-1)
(or (not org-agenda-tags-todo-honor-ignore-options)
(not (org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item))))))
;; select this headline
(cond
((eq action 'sparse-tree)
(and org-highlight-sparse-tree-matches
(org-get-heading) (match-end 0)
(org-highlight-new-match
(match-beginning 1) (match-end 1)))
(org-fold-show-context 'tags-tree))
((eq action 'agenda)
(let* ((effort (org-entry-get (point) org-effort-property))
(effort-minutes (when effort (save-match-data (org-duration-to-minutes effort)))))
(setq txt (org-agenda-format-item
""
;; Add `effort' and `effort-minutes'
;; properties for prefix format.
(org-add-props
(concat
(if (eq org-tags-match-list-sublevels 'indented)
(make-string (1- level) ?.) "")
(org-get-heading))
nil
'effort effort
'effort-minutes effort-minutes)
(make-string level ?\s)
category
tags-list)
priority (org-get-priority txt))
;; Now add `effort' and `effort-minutes' to
;; full agenda line.
(setq txt (org-add-props txt nil
'effort effort
'effort-minutes effort-minutes)))
(goto-char (org-element-begin el))
(setq marker (org-agenda-new-marker))
(org-add-props txt props
'org-marker marker 'org-hd-marker marker 'org-category category
'todo-state todo
'ts-date ts-date
'priority priority
'urgency priority
'type (concat "tagsmatch" ts-date-type))
(push txt rtn))
((functionp action)
(setq org-map-continue-from nil)
(save-excursion
(setq rtn1 (funcall action))
(push rtn1 rtn)))
(t (user-error "Invalid action")))
;; if we are to skip sublevels, jump to end of subtree
(unless org-tags-match-list-sublevels
(goto-char (1- (org-element-end el))))))
;; Get the correct position from where to continue
(when org-map-continue-from
(setq org-element-cache-map-continue-from org-map-continue-from)
(goto-char org-map-continue-from))
;; Return nil.
nil)
:next-re heading-re
:fail-re heading-re
:narrow t))
(when (and (eq action 'sparse-tree)
(not org-sparse-tree-open-archived-trees))
(org-fold-hide-archived-subtrees (point-min) (point-max)))
(nreverse rtn)))
(defun org-remove-uninherited-tags (tags)
"Remove all tags that are not inherited from the list TAGS."
(cond
((eq org-use-tag-inheritance t)
(if org-tags-exclude-from-inheritance
(org-delete-all org-tags-exclude-from-inheritance tags)
tags))
((not org-use-tag-inheritance) nil)
((stringp org-use-tag-inheritance)
(delq nil (mapcar
(lambda (x)
(if (and (string-match org-use-tag-inheritance x)
(not (member x org-tags-exclude-from-inheritance)))
x nil))
tags)))
((listp org-use-tag-inheritance)
(delq nil (mapcar
(lambda (x)
(if (member x org-use-tag-inheritance) x nil))
tags)))))
(defun org-match-sparse-tree (&optional todo-only match)
"Create a sparse tree according to tags string MATCH.
MATCH is a string with match syntax. It can contain a selection
of tags (\"+work+urgent-boss\"), properties (\"LEVEL>3\"), and
TODO keywords (\"TODO=\\\"WAITING\\\"\") or a combination of
those. See the manual for details.
If optional argument TODO-ONLY is non-nil, only select lines that
are also TODO tasks."
(interactive "P")
(org-agenda-prepare-buffers (list (current-buffer)))
(let ((org--matcher-tags-todo-only todo-only))
(org-scan-tags 'sparse-tree (cdr (org-make-tags-matcher match t))
org--matcher-tags-todo-only)))
(defalias 'org-tags-sparse-tree 'org-match-sparse-tree)
(defun org-global-tags-completion-table (&optional files)
"Return the list of all tags in all agenda buffer/files.
Optional FILES argument is a list of files which can be used
instead of the agenda files."
(save-excursion
(org-uniquify
(delq nil
(apply #'append
(mapcar
(lambda (file)
(set-buffer (find-file-noselect file))
(org--tag-add-to-alist
(org-get-buffer-tags)
(mapcar (lambda (x)
(and (stringp (car-safe x))
(list (car-safe x))))
org-current-tag-alist)))
(if (car-safe files) files
(org-agenda-files))))))))
(defun org-make-tags-matcher (match &optional only-local-tags)
"Create the TAGS/TODO matcher form for the selection string MATCH.
Returns a cons of the selection string MATCH and a function
implementing the matcher.
The matcher is to be called at an Org entry, with point on the
headline, and returns non-nil if the entry matches the selection
string MATCH. It must be called with three arguments: the TODO
keyword at the entry (or nil if none), the list of all tags at
the entry including inherited ones and the reduced level of the
headline. Additionally, the category of the entry, if any, must
be specified as the text property `org-category' on the headline.
This function sets the variable `org--matcher-tags-todo-only' to
a non-nil value if the matcher restricts matching to TODO
entries, otherwise it is not touched.
When ONLY-LOCAL-TAGS is non-nil, ignore the global tag completion
table, only get buffer tags.
See also `org-scan-tags'."
(unless match
;; Get a new match request, with completion against the global
;; tags table and the local tags in current buffer.
(let ((org-last-tags-completion-table
(org--tag-add-to-alist
(when (derived-mode-p 'org-mode)
(org-get-buffer-tags))
(unless only-local-tags
(org-global-tags-completion-table)))))
(setq match
(completing-read
"Match: "
'org-tags-completion-function nil nil nil 'org-tags-history))))
(let* ((match0 match)
(opre "[<=>]=?\\|[!/]=\\|<>")
(re (concat
"^"
;; implicit AND operator (OR is done by global splitting)
"&?"
;; exclusion and inclusion (the latter being implicit)
"\\(?1:[-+:]\\)?"
;; query term
"\\(?2:"
;; tag regexp match
"{[^}]+}\\|"
;; property match. Try to keep this subre generic
;; and rather handle special properties like LEVEL
;; and CATEGORY further below. This ensures that
;; the same quoting mechanics can be used for all
;; property names.
"\\(?:"
;; property name [1]
"\\(?5:\\(?:[[:alnum:]_]+\\|\\\\[^[:space:]]\\)+\\)"
;; operator, optionally starred
"\\(?6:" opre "\\)\\(?7:\\*\\)?"
;; operand (regexp, double-quoted string,
;; number)
"\\(?8:"
"{[^}]+}\\|"
"\"[^\"]*\"\\|"
"-?[.0-9]+\\(?:[eE][-+]?[0-9]+\\)?"
"\\)"
"\\)\\|"
;; exact tag match
org-tag-re
"\\)"))
(start 0)
tagsmatch todomatch tagsmatcher todomatcher)
;; [1] The history of this particular subre:
;; - \\([[:alnum:]_]+\\) [pre-19b0e03]
;; Does not allow for minus characters in property names.
;; - "\\(\\(?:[[:alnum:]_]+\\(?:\\\\-\\)*\\)+\\)" [19b0e03]
;; Incomplete fix of above issue, still resulting in, e.g.,
;; https://orgmode.org/list/87jzv67k3p.fsf@localhost.
;; - "\\(?5:[[:alnum:]_-]+\\)" [f689eb4]
;; Allows for unquoted minus characters in property names, but
;; conflicts with searches like -TAG-PROP="VALUE". See
;; https://orgmode.org/list/87h6oq2nu1.fsf@gmail.com.
;; - current subre
;; Like second solution, but with proper unquoting and allowing
;; for all possible characters in property names to be quoted.
;; Expand group tags.
(setq match (org-tags-expand match))
;; Check if there is a TODO part of this match, which would be the
;; part after a "/". To make sure that this slash is not part of
;; a property value to be matched against, we also check that
;; there is no / after that slash. First, find the last slash.
(let ((s 0))
(while (string-match "/+" match s)
(setq start (match-beginning 0))
(setq s (match-end 0))))
(if (and (string-match "/+" match start)
(not (string-match-p "\"" match start)))
;; Match contains also a TODO-matching request.
(progn
(setq tagsmatch (substring match 0 (match-beginning 0)))
(setq todomatch (substring match (match-end 0)))
(when (string-prefix-p "!" todomatch)
(setq org--matcher-tags-todo-only t)
(setq todomatch (substring todomatch 1)))
(when (string-match "\\`\\s-*\\'" todomatch)
(setq todomatch nil)))
;; Only matching tags.
(setq tagsmatch match)
(setq todomatch nil))
;; Make the tags matcher.
(when (org-string-nw-p tagsmatch)
(let ((orlist nil)
(orterms (org-split-string tagsmatch "|"))
term)
(while (setq term (pop orterms))
(while (and (equal (substring term -1) "\\") orterms)
(setq term (concat term "|" (pop orterms)))) ;repair bad split.
(while (string-match re term)
(let* ((rest (substring term (match-end 0)))
(minus (and (match-end 1)
(equal (match-string 1 term) "-")))
;; Bind the whole query term to `tag' and use that
;; variable for a tag regexp match in [2] or as an
;; exact tag match in [3].
(tag (match-string 2 term))
(regexp (eq (string-to-char tag) ?{))
(propp (match-end 5))
(mm
(cond
(regexp ; [2]
`(with-syntax-table org-mode-tags-syntax-table
(org-match-any-p ,(substring tag 1 -1) tags-list)))
(propp
(let* (;; Determine property name.
(pn (upcase
(save-match-data
(replace-regexp-in-string
"\\\\\\(.\\)" "\\1"
(match-string 5 term)
t nil))))
;; Convert property name to an Elisp
;; accessor for that property (aka. as
;; getter value). Symbols LEVEL and TODO
;; referenced below get bound by the
;; matcher that this function returns.
(gv (pcase pn
("LEVEL"
'(number-to-string level))
("CATEGORY"
'(org-get-category (point)))
("TODO" 'todo)
(p `(org-entry-get (point) ,p 'selective))))
;; Determine operand (aka. property
;; value).
(pv (match-string 8 term))
;; Determine type of operand. Note that
;; these are not exclusive: Any TIMEP is
;; also STRP.
(regexp (eq (string-to-char pv) ?{))
(strp (eq (string-to-char pv) ?\"))
(timep (string-match-p "^\"[[<]\\(?:[0-9]+\\|now\\|today\\|tomorrow\\|[+-][0-9]+[dmwy]\\).*[]>]\"$" pv))
;; Massage operand. TIMEP must come
;; before STRP.
(pv (cond (regexp (substring pv 1 -1))
(timep (org-matcher-time
(substring pv 1 -1)))
(strp (substring pv 1 -1))
(t pv)))
;; Convert operator to Elisp.
(po (org-op-to-function (match-string 6 term)
(if timep 'time strp)))
;; Convert whole property term to Elisp.
(pt (cond ((and regexp (eq po '/=))
`(not (string-match ,pv (or ,gv ""))))
(regexp `(string-match ,pv (or ,gv "")))
(strp `(,po (or ,gv "") ,pv))
(t
`(,po
(string-to-number (or ,gv ""))
,(string-to-number pv)))))
;; Respect the star after the operand.
(pt (if (match-end 7) `(and ,gv ,pt) pt)))
pt))
(t `(member ,tag tags-list))))) ; [3]
(push (if minus `(not ,mm) mm) tagsmatcher)
(setq term rest)))
(push `(and ,@tagsmatcher) orlist)
(setq tagsmatcher nil))
(setq tagsmatcher `(or ,@orlist))))
;; Make the TODO matcher.
(when (org-string-nw-p todomatch)
(let ((orlist nil))
(dolist (term (org-split-string todomatch "|"))
(while (string-match re term)
(let* ((minus (and (match-end 1)
(equal (match-string 1 term) "-")))
(kwd (match-string 2 term))
(regexp (eq (string-to-char kwd) ?{))
(mm (if regexp `(string-match ,(substring kwd 1 -1) todo)
`(equal todo ,kwd))))
(push (if minus `(not ,mm) mm) todomatcher))
(setq term (substring term (match-end 0))))
(push (if (> (length todomatcher) 1)
(cons 'and todomatcher)
(car todomatcher))
orlist)
(setq todomatcher nil))
(setq todomatcher (cons 'or orlist))))
;; Return the string and function of the matcher. If no
;; tags-specific or todo-specific matcher exists, match
;; everything.
(let ((matcher (if (and tagsmatcher todomatcher)
`(and ,tagsmatcher ,todomatcher)
(or tagsmatcher todomatcher t))))
(when org--matcher-tags-todo-only
(setq matcher `(and (member todo org-not-done-keywords) ,matcher)))
(cons match0
(byte-compile
`(lambda (todo tags-list level)
;; Pacify byte-compiler.
(ignore todo) (ignore tags-list) (ignore level)
,matcher))))))
(defun org--tags-expand-group (group tag-groups expanded)
"Recursively expand all tags in GROUP, according to TAG-GROUPS.
TAG-GROUPS is the list of groups used for expansion. EXPANDED is
an accumulator used in recursive calls."
(dolist (tag group)
(unless (member tag expanded)
(let ((group (assoc tag tag-groups)))
(push tag expanded)
(when group
(setq expanded
(org--tags-expand-group (cdr group) tag-groups expanded))))))
expanded)
(defun org-tags-expand (match &optional single-as-list)
"Expand group tags in MATCH.
This replaces every group tag in MATCH with a regexp tag search.
For example, a group tag \"Work\" defined as { Work : Lab Conf }
will be replaced like this:
Work => {\\<\\(?:Work\\|Lab\\|Conf\\)\\>}
+Work => +{\\<\\(?:Work\\|Lab\\|Conf\\)\\>}
-Work => -{\\<\\(?:Work\\|Lab\\|Conf\\)\\>}
Replacing by a regexp preserves the structure of the match.
E.g., this expansion
Work|Home => {\\(?:Work\\|Lab\\|Conf\\}|Home
will match anything tagged with \"Lab\" and \"Home\", or tagged
with \"Conf\" and \"Home\" or tagged with \"Work\" and \"Home\".
A group tag in MATCH can contain regular expressions of its own.
For example, a group tag \"Proj\" defined as { Proj : {P@.+} }
will be replaced like this:
Proj => {\\<\\(?:Proj\\)\\>\\|P@.+}
When the optional argument SINGLE-AS-LIST is non-nil, MATCH is
assumed to be a single group tag, and the function will return
the list of tags in this group."
(unless (org-string-nw-p match) (error "Invalid match tag: %S" match))
(let ((tag-groups
(or org-tag-groups-alist-for-agenda org-tag-groups-alist)))
(cond
(single-as-list (org--tags-expand-group (list match) tag-groups nil))
(org-group-tags
(let* ((case-fold-search t)
(group-keys (mapcar #'car tag-groups))
(key-regexp (concat "\\([+-]?\\)" (regexp-opt group-keys 'words)))
(return-match match))
;; Mark regexp-expressions in the match-expression so that we
;; do not replace them later on.
(let ((s 0))
(while (string-match "{.+?}" return-match s)
(setq s (match-end 0))
(add-text-properties
(match-beginning 0) (match-end 0) '(regexp t) return-match)))
;; For each tag token found in MATCH, compute a regexp and it
(with-syntax-table org-mode-tags-syntax-table
(replace-regexp-in-string
key-regexp
(lambda (m)
(if (get-text-property (match-beginning 2) 'regexp m)
m ;regexp tag: ignore
(let* ((operator (match-string 1 m))
(tag-token (let ((tag (match-string 2 m)))
(list tag)))
regexp-tags regular-tags)
;; Partition tags between regexp and regular tags.
;; Remove curly bracket syntax from regexp tags.
(dolist (tag (org--tags-expand-group tag-token tag-groups nil))
(save-match-data
(if (string-match "{\\(.+?\\)}" tag)
(push (match-string 1 tag) regexp-tags)
(push tag regular-tags))))
;; Replace tag token by the appropriate regexp.
;; Regular tags need to be regexp-quoted, whereas
;; regexp-tags are inserted as-is.
(let ((regular (regexp-opt regular-tags))
(regexp (mapconcat #'identity regexp-tags "\\|")))
(concat operator
(cond
((null regular-tags) (format "{%s}" regexp))
((null regexp-tags) (format "{\\<%s\\>}" regular))
(t (format "{\\<%s\\>\\|%s}" regular regexp))))))))
return-match
t t))))
(t match))))
(defun org-op-to-function (op &optional stringp)
"Turn an operator into the appropriate function."
(setq op
(cond
((equal op "<" ) '(< org-string< org-time<))
((equal op ">" ) '(> org-string> org-time>))
((member op '("<=" "=<" )) '(<= org-string<= org-time<=))
((member op '(">=" "=>" )) '(>= org-string>= org-time>=))
((member op '("=" "==" )) '(= string= org-time=))
((member op '("<>" "!=" "/=")) '(/= org-string<> org-time<>))))
(nth (if (eq stringp 'time) 2 (if stringp 1 0)) op))
(defvar org-add-colon-after-tag-completion nil) ;; dynamically scoped param
(defvar org-tags-overlay (make-overlay 1 1))
(delete-overlay org-tags-overlay)
(defun org-add-prop-inherited (s)
(propertize s 'inherited t))
(defun org-toggle-tag (tag &optional onoff)
"Toggle the tag TAG for the current line.
If ONOFF is `on' or `off', don't toggle but set to this state."
(save-excursion
(org-back-to-heading t)
(let ((current
;; Reverse the tags list so any new tag is appended to the
;; current list of tags.
(nreverse (org-get-tags nil t)))
res)
(pcase onoff
(`off (setq current (delete tag current)))
((or `on (guard (not (member tag current))))
(setq res t)
(cl-pushnew tag current :test #'equal))
(_ (setq current (delete tag current))))
(org-set-tags (nreverse current))
res)))
(defun org--align-tags-here (to-col)
"Align tags on the current headline to TO-COL.
Assume point is on a headline. Preserve point when aligning
tags."
(when (org-match-line org-tag-line-re)
(let* ((tags-start (match-beginning 1))
(blank-start (save-excursion
(goto-char tags-start)
(skip-chars-backward " \t")
(point)))
(new (max (if (>= to-col 0) to-col
(- (abs to-col) (string-width (match-string 1))))
;; Introduce at least one space after the heading
;; or the stars.
(save-excursion
(goto-char blank-start)
(1+ (current-column)))))
(current
(save-excursion (goto-char tags-start) (current-column)))
(origin (point-marker))
(column (current-column))
(in-blank? (and (> origin blank-start) (<= origin tags-start))))
(when (/= new current)
(delete-region blank-start tags-start)
(goto-char blank-start)
(let ((indent-tabs-mode nil)) (indent-to new))
;; Try to move back to original position. If point was in the
;; blanks before the tags, ORIGIN marker is of no use because
;; it now points to BLANK-START. Use COLUMN instead.
(if in-blank? (org-move-to-column column) (goto-char origin))))))
(defun org-set-tags-command (&optional arg)
"Set the tags for the current visible entry.
When called with `\\[universal-argument]' prefix argument ARG, \
realign all tags
in the current buffer.
When called with `\\[universal-argument] \\[universal-argument]' prefix argument, \
unconditionally do not
offer the fast tag selection interface.
If a region is active, set tags in the region according to the
setting of `org-loop-over-headlines-in-active-region'.
This function is for interactive use only;
in Lisp code use `org-set-tags' instead."
(interactive "P")
(let ((org-use-fast-tag-selection
(unless (equal '(16) arg) org-use-fast-tag-selection)))
(cond
((equal '(4) arg) (org-align-tags t))
((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)
'region-start-level 'region))
org-loop-over-headlines-in-active-region) ; hint: infinite recursion.
(org-map-entries
#'org-set-tags-command
nil cl
(lambda () (when (org-invisible-p) (org-end-of-subtree nil t))))))
(t
(save-excursion
;; FIXME: We need to add support setting #+FILETAGS.
(when (org-before-first-heading-p)
(user-error "Setting file tags is not supported yet"))
(org-back-to-heading)
(let* ((all-tags (org-get-tags))
(local-table (or org-current-tag-alist (org-get-buffer-tags)))
(table (setq org-last-tags-completion-table
(append
;; Put local tags in front.
local-table
(cl-set-difference
(org--tag-add-to-alist
(and org-complete-tags-always-offer-all-agenda-tags
(org-global-tags-completion-table
(org-agenda-files)))
local-table)
local-table))))
(current-tags
(cl-remove-if (lambda (tag) (get-text-property 0 'inherited tag))
all-tags))
(inherited-tags
(cl-remove-if-not (lambda (tag) (get-text-property 0 'inherited tag))
all-tags))
(tags
(replace-regexp-in-string
;; Ignore all forbidden characters in tags.
"[^[:alnum:]_@#%]+" ":"
(if (or (eq t org-use-fast-tag-selection)
(and org-use-fast-tag-selection
(delq nil (mapcar #'cdr table))))
(org-fast-tag-selection
current-tags
inherited-tags
table
(and org-fast-tag-selection-include-todo org-todo-key-alist))
(let ((org-add-colon-after-tag-completion (< 1 (length table)))
(crm-separator "[ \t]*:[ \t]*"))
(mapconcat #'identity
(completing-read-multiple
"Tags: "
org-last-tags-completion-table
nil nil (org-make-tag-string current-tags)
'org-tags-history)
":"))))))
(org-set-tags tags)))))
;; `save-excursion' may not replace the point at the right
;; position.
(when (and (save-excursion (skip-chars-backward "*") (bolp))
(looking-at-p " "))
(forward-char))))
(defun org-align-tags (&optional all)
"Align tags in current entry.
When optional argument ALL is non-nil, align all tags in the
visible part of the buffer."
(let ((get-indent-column
(lambda ()
(let ((offset (if (bound-and-true-p org-indent-mode)
(save-excursion
(org-back-to-heading-or-point-min)
(length
(get-text-property
(line-end-position)
'line-prefix)))
0)))
(+ org-tags-column
(if (> org-tags-column 0) (- offset) offset))))))
(if (and (not all) (org-at-heading-p))
(org--align-tags-here (funcall get-indent-column))
(save-excursion
(if all
(progn
(goto-char (point-min))
(while (re-search-forward org-tag-line-re nil t)
(org--align-tags-here (funcall get-indent-column))))
(org-back-to-heading t)
(org--align-tags-here (funcall get-indent-column)))))))
(defun org-set-tags (tags)
"Set the tags of the current entry to TAGS, replacing current tags.
TAGS may be a tags string like \":aa:bb:cc:\", or a list of tags.
If TAGS is nil or the empty string, all tags are removed.
This function assumes point is on a headline."
(org-with-wide-buffer
(org-fold-core-ignore-modifications
(let ((tags (pcase tags
((pred listp) tags)
((pred stringp) (split-string (org-trim tags) ":" t))
(_ (error "Invalid tag specification: %S" tags))))
(old-tags (org-get-tags nil t))
(tags-change? nil))
(when (functionp org-tags-sort-function)
(setq tags (sort tags org-tags-sort-function)))
(setq tags-change? (not (equal tags old-tags)))
(when tags-change?
;; Delete previous tags and any trailing white space.
(goto-char (if (org-match-line org-tag-line-re) (match-beginning 1)
(line-end-position)))
(skip-chars-backward " \t")
(delete-region (point) (line-end-position))
;; Deleting white spaces may break an otherwise empty headline.
;; Re-introduce one space in this case.
(unless (org-at-heading-p) (insert " "))
(when tags
(save-excursion (insert-and-inherit " " (org-make-tag-string tags)))
;; When text is being inserted on an invisible region
;; boundary, it can be inadvertently sucked into
;; invisibility.
(unless (org-invisible-p (line-beginning-position))
(org-fold-region (point) (line-end-position) nil 'outline))))
;; Align tags, if any.
(when (and tags org-auto-align-tags) (org-align-tags))
(when tags-change? (run-hooks 'org-after-tags-change-hook))))))
(defun org-change-tag-in-region (beg end tag off)
"Add or remove TAG for each entry in the region.
This works in the agenda, and also in an Org buffer."
(interactive
(list (region-beginning) (region-end)
(let ((org-last-tags-completion-table
(if (derived-mode-p 'org-mode)
(org--tag-add-to-alist
(org-get-buffer-tags)
(org-global-tags-completion-table))
(org-global-tags-completion-table))))
(completing-read
"Tag: " org-last-tags-completion-table nil nil nil
'org-tags-history))
(progn
(message "[s]et or [r]emove? ")
(equal (read-char-exclusive) ?r))))
(deactivate-mark)
(let ((agendap (equal major-mode 'org-agenda-mode))
l1 l2 m buf pos newhead (cnt 0))
(goto-char end)
(setq l2 (1- (org-current-line)))
(goto-char beg)
(setq l1 (org-current-line))
(cl-loop for l from l1 to l2 do
(org-goto-line l)
(setq m (get-text-property (point) 'org-hd-marker))
(when (or (and (derived-mode-p 'org-mode) (org-at-heading-p))
(and agendap m))
(setq buf (if agendap (marker-buffer m) (current-buffer))
pos (if agendap m (point)))
(with-current-buffer buf
(save-excursion
(save-restriction
(goto-char pos)
(setq cnt (1+ cnt))
(org-toggle-tag tag (if off 'off 'on))
(setq newhead (org-get-heading)))))
(and agendap (org-agenda-change-all-lines newhead m))))
(message "Tag :%s: %s in %d headings" tag (if off "removed" "set") cnt)))
(defun org-tags-completion-function (string _predicate &optional flag)
"Complete tag STRING.
FLAG specifies the type of completion operation to perform. This
function is passed as a collection function to `completing-read',
which see."
(let ((completion-ignore-case nil) ;tags are case-sensitive
(confirm (lambda (x) (stringp (car x))))
(prefix "")
begin)
(when (string-match "^\\(.*[-+:&,|]\\)\\([^-+:&,|]*\\)$" string)
(setq prefix (match-string 1 string))
(setq begin (match-beginning 2))
(setq string (match-string 2 string)))
(pcase flag
(`t (all-completions string org-last-tags-completion-table confirm))
(`lambda (assoc string org-last-tags-completion-table)) ;exact match?
(`(boundaries . ,suffix)
(let ((end (if (string-match "[-+:&,|]" suffix)
(match-string 0 suffix)
(length suffix))))
`(boundaries ,(or begin 0) . ,end)))
(`nil
(pcase (try-completion string org-last-tags-completion-table confirm)
((and completion (pred stringp))
(concat prefix
completion
(if (and org-add-colon-after-tag-completion
(assoc completion org-last-tags-completion-table))
":"
"")))
(completion completion)))
(_ nil))))
(defun org-fast-tag-insert (kwd tags face &optional end)
"Insert KWD, and the TAGS, the latter with face FACE.
Also insert END."
(insert (format "%-12s" (concat kwd ":"))
(org-add-props (mapconcat 'identity tags " ") nil 'face face)
(or end "")))
(defun org-fast-tag-show-exit (flag)
(save-excursion
(org-goto-line 3)
(when (re-search-forward "[ \t]+Next change exits" (line-end-position) t)
(replace-match ""))
(when flag
(end-of-line 1)
(org-move-to-column (- (window-width) 19) t)
(insert (org-add-props " Next change exits" nil 'face 'org-warning)))))
(defun org-set-current-tags-overlay (current prefix)
"Add an overlay to CURRENT tag with PREFIX."
(let ((s (org-make-tag-string current)))
(put-text-property 0 (length s) 'face '(secondary-selection org-tag) s)
(org-overlay-display org-tags-overlay (concat prefix s))))
(defun org--add-or-remove-tag (tag current-tags &optional groups)
"Add or remove TAG entered by user to/from CURRENT-TAGS.
Return the modified CURRENT-TAGS.
When TAG is present in CURRENT-TAGS, remove it. Otherwise, add it.
When TAG is a part of a tag group from GROUPS, make sure that no
exclusive tags from the same group remain in CURRENT-TAGS.
CURRENT-TAGS may be modified by side effect."
(if (member tag current-tags)
;; Remove the tag.
(delete tag current-tags)
;; Add the tag. If the tag is from a tag
;; group, exclude selected alternative tags
;; from the group, if any.
(dolist (g groups)
(when (member tag g)
(dolist (x g) (setq current-tags (delete x current-tags)))))
(cons tag current-tags)))
(defvar org-last-tag-selection-key nil)
(defun org-fast-tag-selection (current-tags inherited-tags tag-table &optional todo-table)
"Fast tag selection with single keys.
CURRENT-TAGS is the current list of tags in the headline,
INHERITED-TAGS is the list of inherited tags, and TAG-TABLE is an
alist of tags and corresponding keys, possibly with grouping
information. TODO-TABLE is a similar table with TODO keywords, should
these have keys assigned to them.
If the keys are nil, a-z are automatically assigned.
Returns the new tags string, or nil to not change the current settings."
(let* (;; Combined alist of all the tags and todo keywords.
(tag-alist (append tag-table todo-table))
;; Max width occupied by a single tag record in the completion buffer.
(field-width
(+ 3 ; keep space for "[c]" binding.
1 ; ensure that there is at least one space between adjacent tag fields.
3 ; keep space for group tag " : " delimiter.
;; The longest tag.
(if (null tag-alist) 0
(apply #'max
(mapcar (lambda (x)
(if (stringp (car x)) (string-width (car x))
0))
tag-alist)))))
(origin-buffer (current-buffer))
(expert-interface (eq org-fast-tag-selection-single-key 'expert))
;; Tag completion table, for normal completion (<TAB>).
(tab-tags nil)
(inherited-face 'org-done)
(current-face 'org-todo)
;; Characters available for auto-assignment.
(tag-binding-char-list org--fast-tag-selection-keys)
(tag-binding-chars-left org-fast-tag-selection-maximum-tags)
field-number ; current tag column in the completion buffer.
tag-binding-spec ; Alist element.
current-tag current-tag-char auto-tag-char
tag-table-local ; table holding all the displayed tags together with auto-assigned bindings.
input-char rtn
ov-start ov-end ov-prefix
(exit-after-next org-fast-tag-selection-single-key)
(done-keywords org-done-keywords)
groups ingroup intaggroup)
;; Calculate the number of tags with explicit user bindings + tags in groups.
;; These tags will be displayed unconditionally. Other tags will
;; be displayed only when there are free bindings left according
;; to `org-fast-tag-selection-maximum-tags'.
(dolist (tag-binding-spec tag-alist)
(pcase tag-binding-spec
(`((or :startgroup :startgrouptag) . _)
(setq ingroup t))
(`((or :endgroup :endgrouptag) . _)
(setq ingroup nil))
((guard (cdr tag-binding-spec))
(cl-decf tag-binding-chars-left))
(`((or :newline :grouptags))) ; pass
((guard ingroup)
(cl-decf tag-binding-chars-left))))
(setq ingroup nil) ; It t, it means malformed tag alist. Reset just in case.
;; Move global `org-tags-overlay' overlay to current heading.
;; Calls to `org-set-current-tags-overlay' will take care about
;; updating the overlay text.
;; FIXME: What if we are setting file tags?
(save-excursion
(forward-line 0)
(if (looking-at org-tag-line-re)
(setq ov-start (match-beginning 1)
ov-end (match-end 1)
ov-prefix "")
(setq ov-start (1- (line-end-position))
ov-end (1+ ov-start))
(skip-chars-forward "^\n\r")
(setq ov-prefix
(concat
(buffer-substring (1- (point)) (point))
(if (> (current-column) org-tags-column)
" "
(make-string (- org-tags-column (current-column)) ?\ ))))))
(move-overlay org-tags-overlay ov-start ov-end)
;; Highlight tags overlay in Org buffer.
(org-set-current-tags-overlay current-tags ov-prefix)
;; Display tag selection dialog, read the user input, and return.
(save-excursion
(save-window-excursion
;; Select tag list buffer, and display it unless EXPERT-INTERFACE.
(if expert-interface
(set-buffer (get-buffer-create " *Org tags*"))
(pop-to-buffer
(get-buffer-create " *Org tags*")
'(org-display-buffer-split (direction . down))))
;; Fill text in *Org tags* buffer.
(erase-buffer)
(setq-local org-done-keywords done-keywords)
;; Insert current tags.
(org-fast-tag-insert "Inherited" inherited-tags inherited-face "\n")
(org-fast-tag-insert "Current" current-tags current-face "\n\n")
;; Display whether next change exits selection dialog.
(org-fast-tag-show-exit exit-after-next)
;; Show tags, tag groups, and bindings in a grid.
;; Each tag in the grid occupies FIELD-WIDTH characters.
;; The tags are filled up to `window-width'.
(setq field-number 0)
(while (setq tag-binding-spec (pop tag-alist))
(pcase tag-binding-spec
;; Display tag groups on starting from a new line.
(`(:startgroup . ,group-name)
(push '() groups) (setq ingroup t)
(unless (zerop field-number)
(setq field-number 0)
(insert "\n"))
(insert (if group-name (format "%s: " group-name) "") "{ "))
;; Tag group end is followed by newline.
(`(:endgroup . ,group-name)
(setq ingroup nil field-number 0)
(insert "}" (if group-name (format " (%s) " group-name) "") "\n"))
;; Group tags start at newline.
(`(:startgrouptag)
(setq intaggroup t)
(unless (zerop field-number)
(setq field-number 0)
(insert "\n"))
(insert "[ "))
;; Group tags end with a newline.
(`(:endgrouptag)
(setq intaggroup nil field-number 0)
(insert "]\n"))
(`(:newline)
(unless (zerop field-number)
(setq field-number 0)
(insert "\n")
(setq tag-binding-spec (car tag-alist))
(while (equal (car tag-alist) '(:newline))
(insert "\n")
(setq tag-alist (cdr tag-alist)))))
(`(:grouptags)
;; Previous tag is the tag representing the following group.
;; It was inserted as "[c] TAG " with spaces filling up
;; to the field width. Replace the trailing spaces with
;; " : ", keeping to total field width unchanged.
(delete-char -3)
(insert " : "))
(_
(setq current-tag (copy-sequence (car tag-binding-spec))) ; will be modified by side effect
;; Compute tag binding.
(if (cdr tag-binding-spec)
;; Custom binding.
(setq current-tag-char (cdr tag-binding-spec))
;; No auto-binding. Update `tag-binding-chars-left'.
(unless (or ingroup intaggroup) ; groups are always displayed.
(cl-decf tag-binding-chars-left))
;; Automatically assign a character according to the tag string.
(setq auto-tag-char
(string-to-char
(downcase (substring
current-tag (if (= (string-to-char current-tag) ?@) 1 0)))))
(if (or (rassoc auto-tag-char tag-table-local)
(rassoc auto-tag-char tag-table))
;; Already bound. Assign first unbound char instead.
(progn
(while (and tag-binding-char-list
(or (rassoc (car tag-binding-char-list) tag-table-local)
(rassoc (car tag-binding-char-list) tag-table)))
(pop tag-binding-char-list))
(setq current-tag-char (or (car tag-binding-char-list)
;; Fall back to display "[ ]".
?\s)))
;; Can safely use binding derived from the tag string.
(setq current-tag-char auto-tag-char)))
;; Record all the tags in the group. `:startgroup'
;; clause earlier added '() to `groups'.
;; `(car groups)' now contains the tag list for the
;; current group.
(when ingroup (push current-tag (car groups)))
;; Compute tag face.
(setq current-tag (org-add-props current-tag nil 'face
(cond
((not (assoc current-tag tag-table))
;; The tag is from TODO-TABLE.
(org-get-todo-face current-tag))
((member current-tag current-tags) current-face)
((member current-tag inherited-tags) inherited-face))))
(when (equal (caar tag-alist) :grouptags)
(org-add-props current-tag nil 'face 'org-tag-group))
;; Respect `org-fast-tag-selection-maximum-tags'.
(when (or ingroup intaggroup (cdr tag-binding-spec) (> tag-binding-chars-left 0))
;; Insert the tag.
(when (and (zerop field-number) (not ingroup) (not intaggroup)) (insert " "))
(insert "[" current-tag-char "] " current-tag
;; Fill spaces up to FIELD-WIDTH.
(make-string
(- field-width 4 (length current-tag)) ?\ ))
;; Record tag and the binding/auto-binding.
(push (cons current-tag current-tag-char) tag-table-local)
;; Last column in the row.
(when (= (cl-incf field-number) (/ (- (window-width) 4) field-width))
(unless (memq (caar tag-alist) '(:endgroup :endgrouptag))
(insert "\n")
(when (or ingroup intaggroup) (insert " ")))
(setq field-number 0))))))
(insert "\n")
;; Keep the tags in order displayed. Will be used later for sorting.
(setq tag-table-local (nreverse tag-table-local))
(goto-char (point-min))
(unless expert-interface (org-fit-window-to-buffer))
;; Read user input.
(setq rtn
(catch 'exit
(while t
(message "[a-z..]:toggle [SPC]:clear [RET]:accept [TAB]:edit [!] %sgroups%s"
(if (not groups) "no " "")
(if expert-interface " [C-c]:window" (if exit-after-next " [C-c]:single" " [C-c]:multi")))
(setq input-char
(let ((inhibit-quit t)) ; intercept C-g.
(read-char-exclusive)))
;; FIXME: Global variable used by `org-beamer-select-environment'.
;; Should factor it out.
(setq org-last-tag-selection-key input-char)
(pcase input-char
;; <RET>
(?\r (throw 'exit t))
;; Toggle tag groups.
(?!
(setq groups (not groups))
(goto-char (point-min))
(while (re-search-forward "[{}]" nil t) (replace-match " ")))
;; Toggle expert interface.
(?\C-c
(if (not expert-interface)
(org-fast-tag-show-exit
(setq exit-after-next (not exit-after-next)))
(setq expert-interface nil)
(pop-to-buffer
" *Org tags*"
'((org-display-buffer-split (direction down))))
(org-fit-window-to-buffer)))
;; Quit.
((or ?\C-g
(and ?q (guard (not (rassoc input-char tag-table-local)))))
(delete-overlay org-tags-overlay)
;; Quit as C-g does.
(keyboard-quit))
;; Clear tags.
(?\s
(setq current-tags nil)
(when exit-after-next (setq exit-after-next 'now)))
;; Use normal completion.
(?\t
;; Compute completion table, unless already computed.
(unless tab-tags
(setq tab-tags
(delq nil
(mapcar (lambda (x)
(let ((item (car-safe x)))
(and (stringp item)
(list item))))
;; Complete using all tags; tags from current buffer first.
(org--tag-add-to-alist
(with-current-buffer origin-buffer
(org-get-buffer-tags))
tag-table)))))
(setq current-tag (completing-read "Tag: " tab-tags))
(when (string-match "\\S-" current-tag)
(cl-pushnew (list current-tag) tab-tags :test #'equal)
(setq current-tags (org--add-or-remove-tag current-tag current-tags groups)))
(when exit-after-next (setq exit-after-next 'now)))
;; INPUT-CHAR is for a todo keyword.
((let (and todo-keyword (guard todo-keyword))
(car (rassoc input-char todo-table)))
(with-current-buffer origin-buffer
(save-excursion (org-todo todo-keyword)))
(when exit-after-next (setq exit-after-next 'now)))
;; INPUT-CHAR is for a tag.
((let (and tag (guard tag))
(car (rassoc input-char tag-table-local)))
(setq current-tags (org--add-or-remove-tag tag current-tags groups))
(when exit-after-next (setq exit-after-next 'now))))
;; Create a sorted tag list.
(setq current-tags
(sort current-tags
(lambda (a b)
;; b is after a.
;; `memq' returns tail of the list after the match + the match.
(assoc b (cdr (memq (assoc a tag-table-local) tag-table-local))))))
;; Exit when we are set to exit immediately.
(when (eq exit-after-next 'now) (throw 'exit t))
;; Continue setting tags in the loop.
;; Update the currently active tags indication in the completion buffer.
(goto-char (point-min))
(forward-line 1)
(delete-region (point) (line-end-position))
(org-fast-tag-insert "Current" current-tags current-face)
;; Update the active tags displayed in the overlay in Org buffer.
(org-set-current-tags-overlay current-tags ov-prefix)
;; Update tag faces in the displayed tag grid.
(let ((tag-re (concat "\\[.\\] \\(" org-tag-re "\\)")))
(while (re-search-forward tag-re nil t)
(let ((tag (match-string 1)))
(add-text-properties
(match-beginning 1) (match-end 1)
(list 'face
(cond
((member tag current-tags) current-face)
((member tag inherited-tags) inherited-face)
(t 'default)))))))
(goto-char (point-min)))))
;; Clear the tag overlay in Org buffer.
(delete-overlay org-tags-overlay)
;; Return the new tag list.
(if rtn
(mapconcat 'identity current-tags ":")
nil)))))
(defun org-make-tag-string (tags)
"Return string associated to TAGS.
TAGS is a list of strings."
(if (null tags) ""
(format ":%s:" (mapconcat #'identity tags ":"))))
(defun org--get-local-tags (&optional epom)
"Return list of tags for headline at EPOM.
When EPOM is non-nil, it should be a marker, point, or element
representing headline."
;; If we do not explicitly copy the result, reference would
;; be returned and cache element might be modified directly.
(mapcar
#'copy-sequence
(org-element-property
:tags
(org-element-lineage
(org-element-at-point epom)
'(headline inlinetask)
'with-self))))
(defun org-get-tags (&optional epom local)
"Get the list of tags specified in the headline at EPOM.
When argument EPOM is non-nil, it should be point, marker, or headline
element.
According to `org-use-tag-inheritance', tags may be inherited
from parent headlines, and from the whole document, through
`org-file-tags'. In this case, the returned list of tags
contains tags in this order: file tags, tags inherited from
parent headlines, local tags. If a tag appears multiple times,
only the most local tag is returned.
However, when optional argument LOCAL is non-nil, only return
tags specified at the headline.
Inherited tags have the `inherited' text property.
This function may modify the match data."
(if (and org-trust-scanner-tags
(or (not epom) (eq epom (point)))
(not local))
org-scanner-tags
(setq epom (org-element-lineage
(org-element-at-point epom)
'(headline inlinetask)
'with-self))
(let ((ltags (org--get-local-tags epom))
itags)
(if (or local (not org-use-tag-inheritance)) ltags
(setq
itags
(mapcar
#'org-add-prop-inherited
(org-element-property-inherited :tags epom nil 'acc)))
(setq itags (append org-file-tags itags))
(nreverse
(delete-dups
(nreverse (nconc (org-remove-uninherited-tags itags) ltags))))))))
(defun org-get-buffer-tags ()
"Get a table of all tags used in the buffer, for completion."
(let ((hashed (make-hash-table :test #'equal)))
(org-element-cache-map
(lambda (el)
(dolist (tag (org-element-property :tags el))
;; Do not carry over the text properties. They may look
;; ugly in the completion.
(puthash (list (substring-no-properties tag)) t hashed))))
(dolist (tag org-file-tags) (puthash (list tag) t hashed))
(hash-table-keys hashed)))
;;;; The mapping API
(defvar org-agenda-skip-comment-trees)
(defvar org-agenda-skip-function)
(defun org-map-entries (func &optional match scope &rest skip)
"Call FUNC at each headline selected by MATCH in SCOPE.
FUNC is a function or a Lisp form. The function will be called without
arguments, with the cursor positioned at the beginning of the headline.
The return values of all calls to the function will be collected and
returned as a list.
The call to FUNC will be wrapped into a `save-excursion' form, so FUNC
does not need to preserve point. After evaluation, the cursor will be
moved to the end of the line (presumably of the headline of the
processed entry) and search continues from there. Under some
circumstances, this may not produce the wanted results. For example,
if you have removed (e.g. archived) the current (sub)tree it could
mean that the next entry will be skipped entirely. In such cases, you
can specify the position from where search should continue by making
FUNC set the variable `org-map-continue-from' to the desired buffer
position.
MATCH is a tags/property/todo match as it is used in the agenda tags view.
Only headlines that are matched by this query will be considered during
the iteration. When MATCH is nil or t, all headlines will be
visited by the iteration.
SCOPE determines the scope of this command. It can be any of:
nil The current buffer, respecting the restriction if any
tree The subtree started with the entry at point
region The entries within the active region, if any
region-start-level
The entries within the active region, but only those at
the same level than the first one.
file The current buffer, without restriction
file-with-archives
The current buffer, and any archives associated with it
agenda All agenda files
agenda-with-archives
All agenda files with any archive files associated with them
\(file1 file2 ...)
If this is a list, all files in the list will be scanned
The remaining args are treated as settings for the skipping facilities of
the scanner. The following items can be given here:
archive skip trees with the archive tag
comment skip trees with the COMMENT keyword
function or Emacs Lisp form:
will be used as value for `org-agenda-skip-function', so
whenever the function returns a position, FUNC will not be
called for that entry and search will continue from the
position returned
If your function needs to retrieve the tags including inherited tags
at the *current* entry, you can use the value of the variable
`org-scanner-tags' which will be much faster than getting the value
with `org-get-tags'. If your function gets properties with
`org-entry-properties' at the *current* entry, bind `org-trust-scanner-tags'
to t around the call to `org-entry-properties' to get the same speedup.
Note that if your function moves around to retrieve tags and properties at
a *different* entry, you cannot use these techniques."
(unless (and (or (eq scope 'region) (eq scope 'region-start-level))
(not (org-region-active-p)))
(let* ((org-agenda-archives-mode nil) ; just to make sure
(org-agenda-skip-archived-trees (memq 'archive skip))
(org-agenda-skip-comment-trees (memq 'comment skip))
(org-agenda-skip-function
(car (org-delete-all '(comment archive) skip)))
(org-tags-match-list-sublevels t)
(start-level (eq scope 'region-start-level))
matcher res
org-todo-keywords-for-agenda
org-done-keywords-for-agenda
org-todo-keyword-alist-for-agenda
org-tag-alist-for-agenda
org--matcher-tags-todo-only)
(cond
((eq match t) (setq matcher t))
((eq match nil) (setq matcher t))
(t (setq matcher (if match (cdr (org-make-tags-matcher match)) t))))
(save-excursion
(save-restriction
(cond ((eq scope 'tree)
(org-back-to-heading t)
(org-narrow-to-subtree)
(setq scope nil))
((and (or (eq scope 'region) (eq scope 'region-start-level))
(org-region-active-p))
;; If needed, set start-level to a string like "2"
(when start-level
(save-excursion
(goto-char (region-beginning))
(unless (org-at-heading-p) (outline-next-heading))
(setq start-level (org-current-level))))
(narrow-to-region (region-beginning)
(save-excursion
(goto-char (region-end))
(unless (and (bolp) (org-at-heading-p))
(outline-next-heading))
(point)))
(setq scope nil)))
(if (not scope)
(progn
;; Agenda expects a file buffer. Skip over refreshing
;; agenda cache for non-file buffers.
(when buffer-file-name
(org-agenda-prepare-buffers
(and buffer-file-name (list (current-buffer)))))
(setq res
(org-scan-tags
func matcher org--matcher-tags-todo-only start-level)))
;; Get the right scope
(cond
((and scope (listp scope) (symbolp (car scope)))
(setq scope (eval scope t)))
((eq scope 'agenda)
(setq scope (org-agenda-files t)))
((eq scope 'agenda-with-archives)
(setq scope (org-agenda-files t))
(setq scope (org-add-archive-files scope)))
((eq scope 'file)
(setq scope (and buffer-file-name (list buffer-file-name))))
((eq scope 'file-with-archives)
(setq scope (org-add-archive-files (list (buffer-file-name))))))
(org-agenda-prepare-buffers scope)
(dolist (file scope)
(with-current-buffer (org-find-base-buffer-visiting file)
(org-with-wide-buffer
(goto-char (point-min))
(setq res
(append
res
(org-scan-tags
func matcher org--matcher-tags-todo-only)))))))))
res)))
;;; Properties API
(defconst org-special-properties
'("ALLTAGS" "BLOCKED" "CLOCKSUM" "CLOCKSUM_T" "CLOSED" "DEADLINE" "FILE"
"ITEM" "PRIORITY" "SCHEDULED" "TAGS" "TIMESTAMP" "TIMESTAMP_IA" "TODO")
"The special properties valid in Org mode.
These are properties that are not defined in the property drawer,
but in some other way.")
(defconst org-default-properties
'("ARCHIVE" "CATEGORY" "SUMMARY" "DESCRIPTION" "CUSTOM_ID"
"LOCATION" "LOGGING" "COLUMNS" "VISIBILITY"
"TABLE_EXPORT_FORMAT" "TABLE_EXPORT_FILE"
"EXPORT_OPTIONS" "EXPORT_TEXT" "EXPORT_FILE_NAME"
"EXPORT_TITLE" "EXPORT_AUTHOR" "EXPORT_DATE" "UNNUMBERED"
"ORDERED" "NOBLOCKING" "COOKIE_DATA" "LOG_INTO_DRAWER" "REPEAT_TO_STATE"
"CLOCK_MODELINE_TOTAL" "STYLE" "HTML_CONTAINER_CLASS"
"ORG-IMAGE-ACTUAL-WIDTH")
"Some properties that are used by Org mode for various purposes.
Being in this list makes sure that they are offered for completion.")
(defun org--valid-property-p (property)
"Non-nil when string PROPERTY is a valid property name."
(not
(or (equal property "")
(string-match-p "\\s-" property))))
(defun org--update-property-plist (key val props)
"Associate KEY to VAL in alist PROPS.
Modifications are made by side-effect. Return new alist."
(let* ((appending (string= (substring key -1) "+"))
(key (if appending (substring key 0 -1) key))
(old (assoc-string key props t)))
(if (not old) (cons (cons key val) props)
(setcdr old (if appending (concat (cdr old) " " val) val))
props)))
(defun org-get-property-block (&optional beg force)
"Return the (beg . end) range of the body of the property drawer.
BEG is the beginning of the current subtree or the beginning of
the document if before the first headline. If it is not given,
it will be found. If the drawer does not exist, create it if
FORCE is non-nil, or return nil."
(org-with-wide-buffer
(let ((beg (cond (beg (goto-char beg))
((or (not (featurep 'org-inlinetask))
(org-inlinetask-in-task-p))
(org-back-to-heading-or-point-min t) (point))
(t (org-with-limited-levels
(org-back-to-heading-or-point-min t))
(point)))))
;; Move point to its position according to its positional rules.
(cond ((org-before-first-heading-p)
(while (and (org-at-comment-p) (bolp)) (forward-line)))
(t (forward-line)
(when (looking-at-p org-planning-line-re) (forward-line))))
(cond ((looking-at org-property-drawer-re)
(forward-line)
(cons (point) (progn (goto-char (match-end 0))
(line-beginning-position))))
(force
(goto-char beg)
(org-insert-property-drawer)
(let ((pos (save-excursion (re-search-forward org-property-drawer-re)
(line-beginning-position))))
(cons pos pos)))))))
(defun org-at-property-drawer-p ()
"Non-nil when point is at the first line of a property drawer."
(org-with-wide-buffer
(forward-line 0)
(and (looking-at org-property-drawer-re)
(or (bobp)
(progn
(forward-line -1)
(cond ((org-at-heading-p))
((looking-at org-planning-line-re)
(forward-line -1)
(org-at-heading-p))
((looking-at org-comment-regexp)
(forward-line -1)
(while (and (not (bobp)) (looking-at org-comment-regexp))
(forward-line -1))
(looking-at org-comment-regexp))
(t nil)))))))
(defun org-at-property-p ()
"Non-nil when point is inside a property drawer.
See `org-property-re' for match data, if applicable."
(save-excursion
(forward-line 0)
(and (looking-at org-property-re)
(let ((property-drawer (save-match-data (org-get-property-block))))
(and property-drawer
(>= (point) (car property-drawer))
(< (point) (cdr property-drawer)))))))
(defun org-property-action ()
"Do an action on properties."
(interactive)
(message "Property Action: [s]et [d]elete [D]elete globally [c]ompute")
(let ((c (read-char-exclusive)))
(cl-case c
(?s (call-interactively #'org-set-property))
(?d (call-interactively #'org-delete-property))
(?D (call-interactively #'org-delete-property-globally))
(?c (call-interactively #'org-compute-property-at-point))
(otherwise (user-error "No such property action %c" c)))))
(defun org-inc-effort ()
"Increment the value of the effort property in the current entry."
(interactive)
(org-set-effort t))
(defvar org-clock-effort) ; Defined in org-clock.el.
(defvar org-clock-current-task) ; Defined in org-clock.el.
(defun org-set-effort (&optional increment value)
"Set the effort property of the current entry.
If INCREMENT is non-nil, set the property to the next allowed
value. Otherwise, if optional argument VALUE is provided, use
it. Eventually, prompt for the new value if none of the previous
variables is set."
(interactive "P")
(let* ((allowed (org-property-get-allowed-values nil org-effort-property t))
(current (org-entry-get nil org-effort-property))
(value
(cond
(increment
(unless allowed (user-error "Allowed effort values are not set"))
(or (cl-caadr (member (list current) allowed))
(user-error "Unknown value %S among allowed values" current)))
(value
(if (stringp value) value
(error "Invalid effort value: %S" value)))
(t
(let ((must-match
(and allowed
(not (get-text-property 0 'org-unrestricted
(caar allowed))))))
(completing-read "Effort: " allowed nil must-match))))))
;; Test whether the value can be interpreted as a duration before
;; inserting it in the buffer:
(org-duration-to-minutes value)
;; Maybe update the effort value:
(unless (equal current value)
(org-entry-put nil org-effort-property value))
(when (equal (org-get-heading t t t t)
(bound-and-true-p org-clock-current-task))
(setq org-clock-effort value)
(org-clock-update-mode-line))
(message "%s is now %s" org-effort-property value)))
(defun org-entry-properties (&optional epom which)
"Get all properties of the current entry.
When EPOM is a buffer position, marker, or element, get all properties
from the entry there instead.
This includes the TODO keyword, the tags, time strings for
deadline, scheduled, and clocking, and any additional properties
defined in the entry.
If WHICH is nil or `all', get all properties. If WHICH is
`special' or `standard', only get that subclass. If WHICH is
a string, only get that property.
Return value is an alist. Keys are properties, as upcased
strings."
(org-with-point-at epom
(when (and (derived-mode-p 'org-mode)
(org-back-to-heading-or-point-min t))
(catch 'exit
(let* ((beg (point))
(specific (and (stringp which) (upcase which)))
(which (cond ((not specific) which)
((member specific org-special-properties) 'special)
(t 'standard)))
props)
;; Get the special properties, like TODO and TAGS.
(when (memq which '(nil all special))
(when (or (not specific) (string= specific "CLOCKSUM"))
(let ((clocksum (get-text-property (point) :org-clock-minutes)))
(when clocksum
(push (cons "CLOCKSUM" (org-duration-from-minutes clocksum))
props)))
(when specific (throw 'exit props)))
(when (or (not specific) (string= specific "CLOCKSUM_T"))
(let ((clocksumt (get-text-property (point)
:org-clock-minutes-today)))
(when clocksumt
(push (cons "CLOCKSUM_T"
(org-duration-from-minutes clocksumt))
props)))
(when specific (throw 'exit props)))
(when (or (not specific) (string= specific "ITEM"))
(let ((case-fold-search nil))
(when (looking-at org-complex-heading-regexp)
(push (cons "ITEM"
(let ((title (match-string-no-properties 4)))
(if (org-string-nw-p title)
(org-remove-tabs title)
"")))
props)))
(when specific (throw 'exit props)))
(when (or (not specific) (string= specific "TODO"))
(let ((case-fold-search nil))
(when (and (looking-at org-todo-line-regexp) (match-end 2))
(push (cons "TODO" (match-string-no-properties 2)) props)))
(when specific (throw 'exit props)))
(when (or (not specific) (string= specific "PRIORITY"))
(push (cons "PRIORITY"
(if (looking-at org-priority-regexp)
(match-string-no-properties 2)
(char-to-string org-priority-default)))
props)
(when specific (throw 'exit props)))
(when (or (not specific) (string= specific "FILE"))
(push (cons "FILE" (buffer-file-name (buffer-base-buffer)))
props)
(when specific (throw 'exit props)))
(when (or (not specific) (string= specific "TAGS"))
(let ((tags (org-get-tags nil t)))
(when tags
(push (cons "TAGS" (org-make-tag-string tags))
props)))
(when specific (throw 'exit props)))
(when (or (not specific) (string= specific "ALLTAGS"))
(let ((tags (org-get-tags)))
(when tags
(push (cons "ALLTAGS" (org-make-tag-string tags))
props)))
(when specific (throw 'exit props)))
(when (or (not specific) (string= specific "BLOCKED"))
(push (cons "BLOCKED" (if (org-entry-blocked-p) "t" "")) props)
(when specific (throw 'exit props)))
(when (or (not specific)
(member specific '("CLOSED" "DEADLINE" "SCHEDULED")))
(forward-line)
(when (looking-at-p org-planning-line-re)
(end-of-line)
(let ((bol (line-beginning-position))
;; Backward compatibility: time keywords used to
;; be configurable (before 8.3). Make sure we
;; get the correct keyword.
(key-assoc `(("CLOSED" . ,org-closed-string)
("DEADLINE" . ,org-deadline-string)
("SCHEDULED" . ,org-scheduled-string))))
(dolist (pair (if specific (list (assoc specific key-assoc))
key-assoc))
(save-excursion
(when (search-backward (cdr pair) bol t)
(goto-char (match-end 0))
(skip-chars-forward " \t")
(and (looking-at org-ts-regexp-both)
(push (cons (car pair)
(match-string-no-properties 0))
props)))))))
(when specific (throw 'exit props)))
(when (or (not specific)
(member specific '("TIMESTAMP" "TIMESTAMP_IA")))
(let ((find-ts
(lambda (end ts)
;; Fix next timestamp before END. TS is the
;; list of timestamps found so far.
(let ((ts ts)
(regexp (cond
((string= specific "TIMESTAMP")
org-ts-regexp)
((string= specific "TIMESTAMP_IA")
org-ts-regexp-inactive)
((assoc "TIMESTAMP_IA" ts)
org-ts-regexp)
((assoc "TIMESTAMP" ts)
org-ts-regexp-inactive)
(t org-ts-regexp-both))))
(catch 'next
(while (re-search-forward regexp end t)
(backward-char)
(let ((object (org-element-context)))
;; Accept to match timestamps in node
;; properties, too.
(when (org-element-type-p
object '(node-property timestamp))
(let ((type
(org-element-property :type object)))
(cond
((and (memq type '(active active-range))
(not (equal specific "TIMESTAMP_IA")))
(unless (assoc "TIMESTAMP" ts)
(push (cons "TIMESTAMP"
(org-element-property
:raw-value object))
ts)
(when specific (throw 'exit ts))))
((and (memq type '(inactive inactive-range))
(not (string= specific "TIMESTAMP")))
(unless (assoc "TIMESTAMP_IA" ts)
(push (cons "TIMESTAMP_IA"
(org-element-property
:raw-value object))
ts)
(when specific (throw 'exit ts))))))
;; Both timestamp types are found,
;; move to next part.
(when (= (length ts) 2) (throw 'next ts)))))
ts)))))
(goto-char beg)
;; First look for timestamps within headline.
(let ((ts (funcall find-ts (line-end-position) nil)))
(if (= (length ts) 2) (setq props (nconc ts props))
;; Then find timestamps in the section, skipping
;; planning line.
(let ((end (save-excursion (outline-next-heading))))
(forward-line)
(when (looking-at-p org-planning-line-re) (forward-line))
(setq props (nconc (funcall find-ts end ts) props))))))))
;; Get the standard properties, like :PROP:.
(when (memq which '(nil all standard))
;; If we are looking after a specific property, delegate
;; to `org-entry-get', which is faster. However, make an
;; exception for "CATEGORY", since it can be also set
;; through keywords (i.e. #+CATEGORY).
(if (and specific (not (equal specific "CATEGORY")))
(let ((value (org-entry-get beg specific nil t)))
(throw 'exit (and value (list (cons specific value)))))
(let ((range (org-get-property-block beg)))
(when range
(let ((end (cdr range)) seen-base)
(goto-char (car range))
;; Unlike to `org--update-property-plist', we
;; handle the case where base values is found
;; after its extension. We also forbid standard
;; properties to be named as special properties.
(while (re-search-forward org-property-re end t)
(let* ((key (upcase (match-string-no-properties 2)))
(extendp (string-match-p "\\+\\'" key))
(key-base (if extendp (substring key 0 -1) key))
(value (match-string-no-properties 3)))
(cond
((member-ignore-case key-base org-special-properties))
(extendp
(setq props
(org--update-property-plist key value props)))
((member key seen-base))
(t (push key seen-base)
(let ((p (assoc-string key props t)))
(if p (setcdr p (concat value " " (cdr p)))
(push (cons key value) props))))))))))))
(unless (assoc "CATEGORY" props)
(push (cons "CATEGORY" (org-get-category beg)) props)
(when (string= specific "CATEGORY") (throw 'exit props)))
;; Return value.
props)))))
(defun org--property-local-values (property literal-nil &optional epom)
"Return value for PROPERTY in current entry or at EPOM.
EPOM can be point, marker, or syntax node.
Value is a list whose car is the base value for PROPERTY and cdr
a list of accumulated values. Return nil if neither is found in
the entry. Also return nil when PROPERTY is set to \"nil\",
unless LITERAL-NIL is non-nil."
(setq epom
(org-element-lineage
(org-element-at-point epom)
'(headline inlinetask org-data)
'with-self))
(let* ((base-value (org-element-property (intern (concat ":" (upcase property) )) epom))
(extra-value (org-element-property (intern (concat ":" (upcase property) "+")) epom))
(extra-value (if (listp extra-value) extra-value (list extra-value)))
(value (if literal-nil (cons base-value extra-value)
(cons (org-not-nil base-value) (org-not-nil extra-value)))))
(and (not (equal value '(nil))) value)))
(defun org--property-global-or-keyword-value (property literal-nil)
"Return value for PROPERTY as defined by global properties or by keyword.
Return value is a string. Return nil if property is not set
globally or by keyword. Also return nil when PROPERTY is set to
\"nil\", unless LITERAL-NIL is non-nil."
(let ((global
(cdr (or (assoc-string property org-keyword-properties t)
(assoc-string property org-global-properties t)
(assoc-string property org-global-properties-fixed t)))))
(if literal-nil global (org-not-nil global))))
(defun org-entry-get (epom property &optional inherit literal-nil)
"Get value of PROPERTY for entry or content at EPOM.
EPOM is an element, marker, or buffer position.
If INHERIT is non-nil and the entry does not have the property,
then also check higher levels of the hierarchy. If INHERIT is
the symbol `selective', use inheritance only if the setting in
`org-use-property-inheritance' selects PROPERTY for inheritance.
If the property is present but empty, the return value is the
empty string. If the property is not present at all, nil is
returned. In any other case, return the value as a string.
Search is case-insensitive.
If LITERAL-NIL is set, return the string value \"nil\" as
a string, do not interpret it as the list atom nil. This is used
for inheritance when a \"nil\" value can supersede a non-nil
value higher up the hierarchy."
(cond
((member-ignore-case property (cons "CATEGORY" org-special-properties))
;; We need a special property. Use `org-entry-properties' to
;; retrieve it, but specify the wanted property.
(cdr (assoc-string property (org-entry-properties epom property))))
((and inherit
(or (not (eq inherit 'selective)) (org-property-inherit-p property)))
(org-entry-get-with-inheritance property literal-nil epom))
(t
(let* ((local (org--property-local-values property literal-nil epom))
(value (and local (mapconcat #'identity
(delq nil local)
(org--property-get-separator property)))))
(if literal-nil value (org-not-nil value))))))
(defun org-property-or-variable-value (var &optional inherit)
"Check if there is a property fixing the value of VAR.
If yes, return this value. If not, return the current value of the variable."
(let ((prop (org-entry-get nil (symbol-name var) inherit)))
(if (and prop (stringp prop) (string-match "\\S-" prop))
(read prop)
(symbol-value var))))
(defun org-entry-delete (epom property)
"Delete PROPERTY from entry at element, point, or marker EPOM.
Accumulated properties, i.e. PROPERTY+, are also removed. Return
non-nil when a property was removed."
(org-with-point-at epom
(pcase (org-get-property-block)
(`(,begin . ,origin)
(let* ((end (copy-marker origin))
(re (org-re-property
(concat (regexp-quote property) "\\+?") t t)))
(goto-char begin)
(while (re-search-forward re end t)
(delete-region (match-beginning 0) (line-beginning-position 2)))
;; If drawer is empty, remove it altogether.
(when (= begin end)
(delete-region (line-beginning-position 0)
(line-beginning-position 2)))
;; Return non-nil if some property was removed.
(prog1 (/= end origin) (set-marker end nil))))
(_ nil))))
;; Multi-values properties are properties that contain multiple values
;; These values are assumed to be single words, separated by whitespace.
(defun org-entry-add-to-multivalued-property (epom property value)
"Add VALUE to the words in the PROPERTY in entry at EPOM.
EPOM is an element, marker, or buffer position."
(let* ((old (org-entry-get epom property))
(values (and old (split-string old))))
(setq value (org-entry-protect-space value))
(unless (member value values)
(setq values (append values (list value)))
(org-entry-put epom property (mapconcat #'identity values " ")))))
(defun org-entry-remove-from-multivalued-property (epom property value)
"Remove VALUE from words in the PROPERTY in entry at EPOM.
EPOM is an element, marker, or buffer position."
(let* ((old (org-entry-get epom property))
(values (and old (split-string old))))
(setq value (org-entry-protect-space value))
(when (member value values)
(setq values (delete value values))
(org-entry-put epom property (mapconcat #'identity values " ")))))
(defun org-entry-member-in-multivalued-property (epom property value)
"Is VALUE one of the words in the PROPERTY in EPOM?
EPOM is an element, marker, or buffer position."
(let* ((old (org-entry-get epom property))
(values (and old (split-string old))))
(setq value (org-entry-protect-space value))
(member value values)))
(defun org-entry-get-multivalued-property (pom property)
"Return a list of values in a multivalued property."
(let* ((value (org-entry-get pom property))
(values (and value (split-string value))))
(mapcar #'org-entry-restore-space values)))
(defun org-entry-put-multivalued-property (epom property &rest values)
"Set multivalued PROPERTY at EPOM to VALUES.
VALUES should be a list of strings. Spaces will be protected.
EPOM is an element, marker, or buffer position."
(org-entry-put epom property (mapconcat #'org-entry-protect-space values " "))
(let* ((value (org-entry-get epom property))
(values (and value (split-string value))))
(mapcar #'org-entry-restore-space values)))
(defun org-entry-protect-space (s)
"Protect spaces and newline in string S."
(while (string-match " " s)
(setq s (replace-match "%20" t t s)))
(while (string-match "\n" s)
(setq s (replace-match "%0A" t t s)))
s)
(defun org-entry-restore-space (s)
"Restore spaces and newline in string S."
(while (string-match "%20" s)
(setq s (replace-match " " t t s)))
(while (string-match "%0A" s)
(setq s (replace-match "\n" t t s)))
s)
(defvar org-entry-property-inherited-from (make-marker)
"Marker pointing to the entry from where a property was inherited.
Each call to `org-entry-get-with-inheritance' will set this marker to the
location of the entry where the inheritance search matched. If there was
no match, the marker will point nowhere.
Note that also `org-entry-get' calls this function, if the INHERIT flag
is set.")
(defun org-entry-get-with-inheritance (property &optional literal-nil epom)
"Get PROPERTY of entry or content at EPOM, search higher levels if needed.
EPOM can be a point, marker, or syntax node.
The search will stop at the first ancestor which has the property defined.
If the value found is \"nil\", return nil to show that the property
should be considered as undefined (this is the meaning of nil here).
However, if LITERAL-NIL is set, return the string value \"nil\" instead."
(move-marker org-entry-property-inherited-from nil)
(let (values found-inherited?)
(org-element-lineage-map
(org-element-at-point epom)
(lambda (el)
(pcase-let ((`(,val . ,val+)
;; Force LITERAL-NIL t.
(org--property-local-values property t el)))
(if (not val)
;; PROPERTY+
(prog1 nil ; keep looking for PROPERTY
(when val+ (setq values (nconc (delq nil val+) values))))
(setq values (cons val (nconc (delq nil val+) values)))
(move-marker
org-entry-property-inherited-from
(org-element-begin el)
(org-element-property :buffer el))
;; Found inherited direct PROPERTY.
(setq found-inherited? t))))
'(inlinetask headline org-data)
'with-self 'first-match)
;; Consider global properties, if we found no PROPERTY (or maybe
;; only PROPERTY+).
(unless found-inherited?
(when-let* ((global (org--property-global-or-keyword-value
property t)))
(setq values (cons global values))))
(when values
(setq values (mapconcat
#'identity values
(org--property-get-separator property))))
(if literal-nil values (org-not-nil values))))
(defvar org-property-changed-functions nil
"Hook called when the value of a property has changed.
Each hook function should accept two arguments, the name of the property
and the new value.")
(defun org-entry-put (epom property value)
"Set PROPERTY to VALUE for entry at EPOM.
EPOM is an element, marker, or buffer position.
If the value is nil, it is converted to the empty string. If it
is not a string, an error is raised. Also raise an error on
invalid property names.
PROPERTY can be any regular property (see
`org-special-properties'). It can also be \"TODO\",
\"PRIORITY\", \"SCHEDULED\" and \"DEADLINE\".
For the last two properties, VALUE may have any of the special
values \"earlier\" and \"later\". The function then increases or
decreases scheduled or deadline date by one day."
(cond ((null value) (setq value ""))
((not (stringp value)) (error "Properties values should be strings"))
((not (org--valid-property-p property))
(user-error "Invalid property name: \"%s\"" property)))
(org-no-read-only
(org-with-point-at epom
(if (or (not (featurep 'org-inlinetask)) (org-inlinetask-in-task-p))
(org-back-to-heading-or-point-min t)
(org-with-limited-levels (org-back-to-heading-or-point-min t)))
(let ((beg (point)))
(cond
((equal property "TODO")
(cond ((not (org-string-nw-p value)) (setq value 'none))
((not (member value org-todo-keywords-1))
(user-error "\"%s\" is not a valid TODO state" value)))
(org-todo value)
(when org-auto-align-tags (org-align-tags)))
((equal property "PRIORITY")
(org-priority (if (org-string-nw-p value) (string-to-char value) ?\s))
(when org-auto-align-tags (org-align-tags)))
((equal property "SCHEDULED")
(forward-line)
(if (and (looking-at-p org-planning-line-re)
(re-search-forward
org-scheduled-time-regexp (line-end-position) t))
(cond ((string= value "earlier") (org-timestamp-change -1 'day))
((string= value "later") (org-timestamp-change 1 'day))
((string= value "") (org-schedule '(4)))
(t (org-schedule nil value)))
(if (member value '("earlier" "later" ""))
(call-interactively #'org-schedule)
(org-schedule nil value))))
((equal property "DEADLINE")
(forward-line)
(if (and (looking-at-p org-planning-line-re)
(re-search-forward
org-deadline-time-regexp (line-end-position) t))
(cond ((string= value "earlier") (org-timestamp-change -1 'day))
((string= value "later") (org-timestamp-change 1 'day))
((string= value "") (org-deadline '(4)))
(t (org-deadline nil value)))
(if (member value '("earlier" "later" ""))
(call-interactively #'org-deadline)
(org-deadline nil value))))
((member property org-special-properties)
(error "The %s property cannot be set with `org-entry-put'" property))
(t
(org-fold-core-ignore-modifications
(let* ((range (org-get-property-block beg 'force))
(end (cdr range))
(case-fold-search t))
(goto-char (car range))
(if (re-search-forward (org-re-property property nil t) end t)
(progn (delete-region (match-beginning 0) (match-end 0))
(goto-char (match-beginning 0)))
(goto-char end)
(insert-and-inherit "\n")
(backward-char))
(insert-and-inherit ":" property ":")
(when value (insert-and-inherit " " value))
(org-indent-line))))))
(run-hook-with-args 'org-property-changed-functions property value))))
(defun org-buffer-property-keys (&optional specials defaults columns)
"Get all property keys in the current buffer.
When SPECIALS is non-nil, also list the special properties that
reflect things like tags and TODO state.
When DEFAULTS is non-nil, also include properties that has
special meaning internally: ARCHIVE, CATEGORY, SUMMARY,
DESCRIPTION, LOCATION, and LOGGING and others.
When COLUMNS in non-nil, also include property names given in
COLUMN formats in the current buffer."
(let ((case-fold-search t)
(props (append
(and specials org-special-properties)
(and defaults (cons org-effort-property org-default-properties))
;; Get property names from #+PROPERTY keywords as well
(mapcar (lambda (s)
(nth 0 (split-string s)))
(cdar (org-collect-keywords '("PROPERTY")))))))
(org-with-wide-buffer
(goto-char (point-min))
(while (re-search-forward org-property-start-re nil t)
(catch :skip
(let ((range (org-get-property-block)))
(unless range (throw :skip nil))
(goto-char (car range))
(let ((begin (car range))
(end (cdr range)))
;; Make sure that found property block is not located
;; before current point, as it would generate an infloop.
;; It can happen, for example, in the following
;; situation:
;;
;; * Headline
;; :PROPERTIES:
;; ...
;; :END:
;; *************** Inlinetask
;; #+BEGIN_EXAMPLE
;; :PROPERTIES:
;; #+END_EXAMPLE
;;
(if (< begin (point)) (throw :skip nil) (goto-char begin))
(while (< (point) end)
(let ((p (progn (looking-at org-property-re)
(match-string-no-properties 2))))
;; Only add true property name, not extension symbol.
(push (if (not (string-match-p "\\+\\'" p)) p
(substring p 0 -1))
props))
(forward-line))))
(outline-next-heading)))
(when columns
(goto-char (point-min))
(while (re-search-forward "^[ \t]*\\(?:#\\+\\|:\\)COLUMNS:" nil t)
(let ((element (org-element-at-point)))
(when (org-element-type-p element '(keyword node-property))
(let ((value (org-element-property :value element))
(start 0))
(while (string-match "%[0-9]*\\([[:alnum:]_-]+\\)\\(([^)]+)\\)?\
\\(?:{[^}]+}\\)?"
value start)
(setq start (match-end 0))
(let ((p (match-string-no-properties 1 value)))
(unless (member-ignore-case p org-special-properties)
(push p props))))))))))
(sort (delete-dups
(append props
;; for each xxx_ALL property, make sure the bare
;; xxx property is also included
(delq nil (mapcar (lambda (p)
(and (string-match-p "._ALL\\'" p)
(substring p 0 -4)))
props))))
(lambda (a b) (string< (upcase a) (upcase b))))))
(defun org-property-values (key)
"List all non-nil values of property KEY in current buffer."
(org-with-wide-buffer
(goto-char (point-min))
(let ((case-fold-search t)
(re (org-re-property key))
values)
(while (re-search-forward re nil t)
(push (org-entry-get (point) key) values))
(delete-dups values))))
(defun org-insert-property-drawer ()
"Insert a property drawer into the current entry.
Do nothing if the drawer already exists. The newly created
drawer is immediately hidden."
(org-with-wide-buffer
;; Set point to the position where the drawer should be inserted.
(if (or (not (featurep 'org-inlinetask)) (org-inlinetask-in-task-p))
(org-back-to-heading-or-point-min t)
(org-with-limited-levels (org-back-to-heading-or-point-min t)))
(if (org-before-first-heading-p)
(while (and (org-at-comment-p) (bolp)) (forward-line))
(forward-line)
(when (looking-at-p org-planning-line-re) (forward-line)))
(unless (looking-at-p org-property-drawer-re)
;; Make sure we start editing a line from current entry, not from
;; next one. It prevents extending text properties or overlays
;; belonging to the latter.
(when (and (bolp) (> (point) (point-min))) (backward-char))
(let ((begin (if (bobp) (point) (1+ (point))))
(inhibit-read-only t))
(unless (bobp) (insert "\n"))
(insert ":PROPERTIES:\n:END:")
(org-fold-region (line-end-position 0) (point) t 'drawer)
(when (or (eobp) (= begin (point-min))) (insert "\n"))
(org-indent-region begin (point))))))
(defun org-insert-drawer (&optional arg drawer)
"Insert a drawer at point.
When optional argument ARG is non-nil, insert a property drawer.
Optional argument DRAWER, when non-nil, is a string representing
drawer's name. Otherwise, the user is prompted for a name.
If a region is active, insert the drawer around that region
instead.
Point is left between drawer's boundaries."
(interactive "P")
(let* ((drawer (if arg "PROPERTIES"
(or drawer (read-from-minibuffer "Drawer: ")))))
(cond
;; With C-u, fall back on `org-insert-property-drawer'
(arg
(org-insert-property-drawer)
(org-back-to-heading-or-point-min t)
;; Move inside.
(re-search-forward org-property-end-re)
(forward-line 0)
(unless (org-element-contents-begin (org-element-at-point))
;; Empty drawer.
(insert "\n")
(forward-char -1))
(org-reveal))
;; Check validity of suggested drawer's name.
((not (string-match-p org-drawer-regexp (format ":%s:" drawer)))
(user-error "Invalid drawer name"))
;; With an active region, insert a drawer at point.
((not (org-region-active-p))
(progn
(unless (bolp) (insert "\n"))
(insert (format ":%s:\n\n:END:\n" drawer))
(forward-line -2)))
;; Otherwise, insert the drawer at point
(t
(let ((rbeg (region-beginning))
(rend (copy-marker (region-end))))
(unwind-protect
(progn
(goto-char rbeg)
(forward-line 0)
(when (save-excursion
(re-search-forward org-outline-regexp-bol rend t))
(user-error "Drawers cannot contain headlines"))
;; Position point at the beginning of the first
;; non-blank line in region. Insert drawer's opening
;; there, then indent it.
(org-skip-whitespace)
(forward-line 0)
(insert ":" drawer ":\n")
(forward-line -1)
(indent-for-tab-command)
;; Move point to the beginning of the first blank line
;; after the last non-blank line in region. Insert
;; drawer's closing, then indent it.
(goto-char rend)
(skip-chars-backward " \r\t\n")
(insert "\n:END:")
(deactivate-mark t)
(indent-for-tab-command)
(unless (eolp) (insert "\n"))
;; Leave point inside drawer boundaries.
(search-backward ":END:")
(forward-char -1))
;; Clear marker, whatever the outcome of insertion is.
(set-marker rend nil)))))))
(defvar org-property-set-functions-alist nil
"Property set function alist.
Each entry should have the following format:
(PROPERTY . READ-FUNCTION)
The read function will be called with the same argument as
`org-completing-read'.")
(defun org-set-property-function (property)
"Get the function that should be used to set PROPERTY.
This is computed according to `org-property-set-functions-alist'."
(or (cdr (assoc property org-property-set-functions-alist))
'org-completing-read))
(defun org-read-property-value (property &optional epom default)
"Read value for PROPERTY, as a string.
When optional argument EPOM is non-nil, completion uses additional
information, i.e., allowed or existing values at element, point, or
marker EPOM.
Optional argument DEFAULT provides a default value for PROPERTY."
(let* ((completion-ignore-case t)
(allowed
(or (org-property-get-allowed-values nil property 'table)
(and epom (org-property-get-allowed-values epom property 'table))))
(current (org-entry-get nil property))
(prompt (format "%s value%s: "
property
(if (org-string-nw-p current)
(format " [%s]" current)
"")))
(set-function (org-set-property-function property))
(default (cond
((not allowed) default)
((member default allowed) default)
(t nil))))
(org-trim
(if allowed
(funcall set-function
prompt allowed nil
(not (get-text-property 0 'org-unrestricted (caar allowed)))
default nil default)
(let ((all (mapcar #'list
(append (org-property-values property)
(and epom
(org-with-point-at epom
(org-property-values property)))))))
(funcall set-function prompt all nil nil default nil current))))))
(defvar org-last-set-property nil)
(defvar org-last-set-property-value nil)
(defun org-read-property-name ()
"Read a property name."
(let ((completion-ignore-case t)
(default-prop (or (and (org-at-property-p)
(match-string-no-properties 2))
org-last-set-property)))
(org-completing-read
(concat "Property"
(if default-prop (concat " [" default-prop "]") "")
": ")
(mapcar #'list (org-buffer-property-keys nil t t))
nil nil nil nil default-prop)))
(defun org-set-property-and-value (use-last)
"Allow setting [PROPERTY]: [value] direction from prompt.
When use-default, don't even ask, just use the last
\"[PROPERTY]: [value]\" string from the history."
(interactive "P")
(let* ((completion-ignore-case t)
(pv (or (and use-last org-last-set-property-value)
(org-completing-read
"Enter a \"[Property]: [value]\" pair: "
nil nil nil nil nil
org-last-set-property-value)))
prop val)
(when (string-match "^[ \t]*\\([^:]+\\):[ \t]*\\(.*\\)[ \t]*$" pv)
(setq prop (match-string 1 pv)
val (match-string 2 pv))
(org-set-property prop val))))
(defun org-set-property (property value)
"In the current entry, set PROPERTY to VALUE.
When called interactively, this will prompt for a property name, offering
completion on existing and default properties. And then it will prompt
for a value, offering completion either on allowed values (via an inherited
xxx_ALL property) or on existing values in other instances of this property
in the current file.
Throw an error when trying to set a property with an invalid name."
(interactive (list nil nil))
(let ((property (or property (org-read-property-name))))
;; `org-entry-put' also makes the following check, but this one
;; avoids polluting `org-last-set-property' and
;; `org-last-set-property-value' needlessly.
(unless (org--valid-property-p property)
(user-error "Invalid property name: \"%s\"" property))
(let ((value (or value (org-read-property-value property)))
(fn (cdr (assoc-string property org-properties-postprocess-alist t))))
(setq org-last-set-property property)
(setq org-last-set-property-value (concat property ": " value))
;; Possibly postprocess the inserted value:
(when fn (setq value (funcall fn value)))
(unless (equal (org-entry-get nil property) value)
(org-entry-put nil property value)))))
(defun org-find-property (property &optional value)
"Find first entry in buffer that sets PROPERTY.
When optional argument VALUE is non-nil, only consider an entry
if it contains PROPERTY set to this value. If PROPERTY should be
explicitly set to nil, use string \"nil\" for VALUE.
Return position where the entry begins, or nil if there is no
such entry. If narrowing is in effect, only search the visible
part of the buffer."
(save-excursion
(goto-char (point-min))
(let ((case-fold-search t)
(re (org-re-property property nil (not value) value)))
(catch 'exit
(while (re-search-forward re nil t)
(when (if value (org-at-property-p)
(org-entry-get (point) property nil t))
(throw 'exit (progn (org-back-to-heading-or-point-min t)
(point)))))))))
(defun org-delete-property (property)
"In the current entry, delete PROPERTY."
(interactive
(let* ((completion-ignore-case t)
(cat (org-entry-get (point) "CATEGORY"))
(props0 (org-entry-properties nil 'standard))
(props (if cat props0
(delete `("CATEGORY" . ,(org-get-category)) props0)))
(prop (if (< 1 (length props))
(completing-read "Property: " props nil t)
(caar props))))
(list prop)))
(if (not property)
(message "No property to delete in this entry")
(org-entry-delete nil property)
(message "Property \"%s\" deleted" property)))
(defun org-delete-property-globally (property)
"Remove PROPERTY globally, from all entries.
This function ignores narrowing, if any."
(interactive
(let* ((completion-ignore-case t)
(prop (completing-read
"Globally remove property: "
(mapcar #'list (org-buffer-property-keys)))))
(list prop)))
(org-with-wide-buffer
(goto-char (point-min))
(let ((count 0)
(re (org-re-property (concat (regexp-quote property) "\\+?") t t)))
(while (re-search-forward re nil t)
(when (org-entry-delete (point) property) (cl-incf count)))
(message "Property \"%s\" removed from %d entries" property count))))
(defvar org-columns-current-fmt-compiled) ; defined in org-colview.el
(defun org-compute-property-at-point ()
"Compute the property at point.
This looks for an enclosing column format, extracts the operator and
then applies it to the property in the column format's scope."
(interactive)
(unless (org-at-property-p)
(user-error "Not at a property"))
(let ((prop (match-string-no-properties 2)))
(org-columns-get-format-and-top-level)
(unless (nth 3 (assoc-string prop org-columns-current-fmt-compiled t))
(user-error "No operator defined for property %s" prop))
(org-columns-compute prop)))
(defvar org-property-allowed-value-functions nil
"Hook for functions supplying allowed values for a specific property.
The functions must take a single argument, the name of the property, and
return a flat list of allowed values. If \":ETC\" is one of
the values, this means that these values are intended as defaults for
completion, but that other values should be allowed too.
The functions must return nil if they are not responsible for this
property.")
(defun org-property-get-allowed-values (epom property &optional table)
"Get allowed values at EPOM for the property PROPERTY.
EPOM can be an element, marker, or buffer position.
When TABLE is non-nil, return an alist that can directly be used for
completion."
(let (vals)
(cond
((equal property "TODO")
(setq vals (org-with-point-at epom
(append org-todo-keywords-1 '("")))))
((equal property "PRIORITY")
(let ((n org-priority-lowest))
(while (>= n org-priority-highest)
(push (char-to-string n) vals)
(setq n (1- n)))))
((equal property "CATEGORY"))
((member property org-special-properties))
((setq vals (run-hook-with-args-until-success
'org-property-allowed-value-functions property)))
(t
(setq vals (org-entry-get epom (concat property "_ALL") 'inherit))
(when (and vals (string-match "\\S-" vals))
(setq vals (car (read-from-string (concat "(" vals ")"))))
(setq vals (mapcar (lambda (x)
(cond ((stringp x) x)
((numberp x) (number-to-string x))
((symbolp x) (symbol-name x))
(t "???")))
vals)))))
(when (member ":ETC" vals)
(setq vals (remove ":ETC" vals))
(org-add-props (car vals) '(org-unrestricted t)))
(if table (mapcar 'list vals) vals)))
(defun org-property-previous-allowed-value (&optional _previous)
"Switch to the next allowed value for this property."
(interactive)
(org-property-next-allowed-value t))
(defun org-property-next-allowed-value (&optional previous)
"Switch to the next allowed value for this property."
(interactive)
(unless (org-at-property-p)
(user-error "Not at a property"))
(let* ((prop (car (save-match-data (org-split-string (match-string 1) ":"))))
(key (match-string 2))
(value (match-string 3))
(allowed (or (org-property-get-allowed-values (point) key)
(and (member value '("[ ]" "[-]" "[X]"))
'("[ ]" "[X]"))))
(heading (save-match-data (nth 4 (org-heading-components))))
nval)
(unless allowed
(user-error "Allowed values for this property have not been defined"))
(when previous (setq allowed (reverse allowed)))
(when (member value allowed)
(setq nval (car (cdr (member value allowed)))))
(setq nval (or nval (car allowed)))
(when (equal nval value)
(user-error "Only one allowed value for this property"))
(org-at-property-p)
(replace-match (concat " :" key ": " nval) t t)
(org-indent-line)
(forward-line 0)
(skip-chars-forward " \t")
(when (equal prop org-effort-property)
(when (string= org-clock-current-task heading)
(setq org-clock-effort nval)
(org-clock-update-mode-line)))
(run-hook-with-args 'org-property-changed-functions key nval)))
(defun org-find-olp (path &optional this-buffer)
"Return a marker pointing to the entry at outline path OLP.
If anything goes wrong, throw an error, and if you need to do
something based on this error, you can catch it with
`condition-case'.
If THIS-BUFFER is set, the outline path does not contain a file,
only headings."
(let* ((file (if this-buffer buffer-file-name (pop path)))
(buffer (if this-buffer (current-buffer) (find-file-noselect file)))
(level 1)
(lmin 1)
(lmax 1)
end found flevel)
(unless buffer (error "File not found :%s" file))
(with-current-buffer buffer
(unless (derived-mode-p 'org-mode)
(error "Buffer %s needs to be in Org mode" buffer))
(org-with-wide-buffer
(goto-char (point-min))
(dolist (heading path)
(let ((re (format org-complex-heading-regexp-format
(regexp-quote heading)))
(cnt 0))
(while (re-search-forward re end t)
(setq level (- (match-end 1) (match-beginning 1)))
(when (and (>= level lmin) (<= level lmax))
(setq found (match-beginning 0) flevel level cnt (1+ cnt))))
(when (= cnt 0)
(error "Heading not found on level %d: %s" lmax heading))
(when (> cnt 1)
(error "Heading not unique on level %d: %s" lmax heading))
(goto-char found)
(setq lmin (1+ flevel) lmax (+ lmin (if org-odd-levels-only 1 0)))
(setq end (save-excursion (org-end-of-subtree t t)))))
(when (org-at-heading-p)
(point-marker))))))
(defun org-find-exact-headline-in-buffer (heading &optional buffer pos-only)
"Find node HEADING in BUFFER.
Return a marker to the heading if it was found, or nil if not.
If POS-ONLY is set, return just the position instead of a marker.
The heading text must match exact, but it may have a TODO keyword,
a priority cookie and tags in the standard locations."
(with-current-buffer (or buffer (current-buffer))
(org-with-wide-buffer
(goto-char (point-min))
(let (case-fold-search)
(when (re-search-forward
(format org-complex-heading-regexp-format
(regexp-quote heading)) nil t)
(if pos-only
(match-beginning 0)
(move-marker (make-marker) (match-beginning 0))))))))
(defun org-find-exact-heading-in-directory (heading &optional dir)
"Find Org node headline HEADING in all \".org\" files in directory DIR.
When the target headline is found, return a marker to this location."
(let ((files (directory-files (or dir default-directory)
t "\\`[^.#].*\\.org\\'"))
visiting m buffer)
(catch 'found
(dolist (file files)
(message "trying %s" file)
(setq visiting (org-find-base-buffer-visiting file))
(setq buffer (or visiting (find-file-noselect file)))
(setq m (org-find-exact-headline-in-buffer
heading buffer))
(when (and (not m) (not visiting)) (kill-buffer buffer))
(and m (throw 'found m))))))
(defun org-find-entry-with-id (ident)
"Locate the entry that contains the ID property with exact value IDENT.
IDENT can be a string, a symbol or a number, this function will search for
the string representation of it.
Return the position where this entry starts, or nil if there is no such entry."
(interactive "sID: ")
(let ((id (cond
((stringp ident) ident)
((symbolp ident) (symbol-name ident))
((numberp ident) (number-to-string ident))
(t (error "IDENT %s must be a string, symbol or number" ident)))))
(org-with-wide-buffer (org-find-property "ID" id))))
;;;; Timestamps
(defvar org-last-changed-timestamp nil)
(defvar org-last-inserted-timestamp nil
"The last time stamp inserted with `org-insert-timestamp'.")
(defalias 'org-time-stamp #'org-timestamp)
(defun org-timestamp (arg &optional inactive)
"Prompt for a date/time and insert a time stamp.
If the user specifies a time like HH:MM or if this command is
called with at least one prefix argument, the time stamp contains
the date and the time. Otherwise, only the date is included.
All parts of a date not specified by the user are filled in from
the timestamp at point, if any, or the current date/time
otherwise.
If there is already a timestamp at the cursor, it is replaced.
With two universal prefix arguments, insert an active timestamp
with the current time without prompting the user.
When called from Lisp, the timestamp is inactive if INACTIVE is
non-nil."
(interactive "P")
(let* ((ts (cond
((org-at-date-range-p t)
(match-string (if (< (point) (- (match-beginning 2) 2)) 1 2)))
((org-at-timestamp-p 'lax) (match-string 0))))
;; Default time is either the timestamp at point or today.
;; When entering a range, only the range start is considered.
(default-time (and ts (org-time-string-to-time ts)))
(default-input (and ts (org-get-compact-tod ts)))
(repeater (and ts
(string-match "\\([.+-]+[0-9]+[hdwmy] ?\\)+" ts)
(match-string 0 ts)))
org-time-was-given
org-end-time-was-given
(time
(if (equal arg '(16)) (current-time)
;; Preserve `this-command' and `last-command'.
(let ((this-command this-command)
(last-command last-command))
(org-read-date
arg 'totime nil nil default-time default-input
inactive)))))
(cond
((and ts
(memq last-command '( org-time-stamp org-time-stamp-inactive
org-timestamp org-timestamp-inactive))
(memq this-command '( org-time-stamp org-time-stamp-inactive
org-timestamp org-timestamp-inactive)))
(insert "--")
(org-insert-timestamp time (or org-time-was-given arg) inactive))
(ts
;; Make sure we're on a timestamp. When in the middle of a date
;; range, move arbitrarily to range end.
(unless (org-at-timestamp-p 'lax)
(skip-chars-forward "-")
(org-at-timestamp-p 'lax))
(replace-match "")
(setq org-last-changed-timestamp
(org-insert-timestamp
time (or org-time-was-given arg)
inactive nil nil (list org-end-time-was-given)))
(when repeater
(backward-char)
(insert " " repeater)
(setq org-last-changed-timestamp
(concat (substring org-last-inserted-timestamp 0 -1)
" " repeater ">")))
(message "Timestamp updated"))
((equal arg '(16)) (org-insert-timestamp time t inactive))
(t (org-insert-timestamp
time (or org-time-was-given arg) inactive nil nil
(list org-end-time-was-given))))))
;; FIXME: can we use this for something else, like computing time differences?
(defun org-get-compact-tod (s)
(when (string-match "\\(\\([012]?[0-9]\\):\\([0-5][0-9]\\)\\)\\(-\\(\\([012]?[0-9]\\):\\([0-5][0-9]\\)\\)\\)?" s)
(let* ((t1 (match-string 1 s))
(h1 (string-to-number (match-string 2 s)))
(m1 (string-to-number (match-string 3 s)))
(t2 (and (match-end 4) (match-string 5 s)))
(h2 (and t2 (string-to-number (match-string 6 s))))
(m2 (and t2 (string-to-number (match-string 7 s))))
dh dm)
(if (not t2)
t1
(setq dh (- h2 h1) dm (- m2 m1))
(when (< dm 0) (setq dm (+ dm 60) dh (1- dh)))
(concat t1 "+" (number-to-string dh)
(and (/= 0 dm) (format ":%02d" dm)))))))
(defalias 'org-time-stamp-inactive #'org-timestamp-inactive)
(defun org-timestamp-inactive (&optional arg)
"Insert an inactive time stamp.
An inactive time stamp is enclosed in square brackets instead of
angle brackets. It is inactive in the sense that it does not
trigger agenda entries. So these are more for recording a
certain time/date.
If the user specifies a time like HH:MM or if this command is called with
at least one prefix argument, the time stamp contains the date and the time.
Otherwise, only the date is included.
When called with two universal prefix arguments, insert an inactive time stamp
with the current time without prompting the user."
(interactive "P")
(org-timestamp arg 'inactive))
(defvar org-date-ovl (make-overlay 1 1))
(overlay-put org-date-ovl 'face 'org-date-selected)
(delete-overlay org-date-ovl)
(defvar org-ans1) ; dynamically scoped parameter
(defvar org-ans2) ; dynamically scoped parameter
(defvar org-plain-time-of-day-regexp) ; defined below
(defvar org-overriding-default-time nil) ; dynamically scoped
(defvar org-read-date-overlay nil)
(defvar org-read-date-history nil)
(defvar org-read-date-final-answer nil)
(defvar org-read-date-analyze-futurep nil)
(defvar org-read-date-analyze-forced-year nil)
(defvar org-read-date-inactive)
(defvar org-def)
(defvar org-defdecode)
(defvar org-with-time)
(defvar calendar-setup) ; Dynamically scoped.
(defun org-read-date (&optional with-time to-time from-string prompt
default-time default-input inactive)
"Read a date, possibly a time, and make things smooth for the user.
The prompt will suggest to enter an ISO date, but you can also enter anything
which will at least partially be understood by `parse-time-string'.
Unrecognized parts of the date will default to the current day, month, year,
hour and minute. If this command is called to replace a timestamp at point,
or to enter the second timestamp of a range, the default time is taken
from the existing stamp. Furthermore, the command prefers the future,
so if you are giving a date where the year is not given, and the day-month
combination is already past in the current year, it will assume you
mean next year. For details, see the manual. A few examples:
3-2-5 --> 2003-02-05
feb 15 --> currentyear-02-15
2/15 --> currentyear-02-15
sep 12 9 --> 2009-09-12
12:45 --> today 12:45
22 sept 0:34 --> currentyear-09-22 0:34
12 --> currentyear-currentmonth-12
Fri --> nearest Friday after today
-Tue --> last Tuesday
etc.
Furthermore you can specify a relative date by giving, as the *first* thing
in the input: a plus/minus sign, a number and a letter [hdwmy] to indicate
change in days weeks, months, years.
With a single plus or minus, the date is relative to today. With a double
plus or minus, it is relative to the date in DEFAULT-TIME. E.g.
+4d --> four days from today
+4 --> same as above
+2w --> two weeks from today
++5 --> five days from default date
The function understands only English month and weekday abbreviations.
While prompting, a calendar is popped up - you can also select the
date with the mouse (button 1). The calendar shows a period of three
months. To scroll it to other months, use the keys `>' and `<'.
There are many other calendar navigation commands available, see
Info node `(org) The date/time prompt' for a full list.
If you don't like the calendar, turn it off with
(setq org-read-date-popup-calendar nil)
With optional argument TO-TIME, the date will immediately be converted
to an internal time.
With an optional argument WITH-TIME, the prompt will suggest to
also insert a time. Note that when WITH-TIME is not set, you can
still enter a time, and this function will inform the calling routine
about this change. The calling routine may then choose to change the
format used to insert the time stamp into the buffer to include the time.
With optional argument FROM-STRING, read from this string instead from
the user. PROMPT can overwrite the default prompt. DEFAULT-TIME is
the time/date that is used for everything that is not specified by the
user."
(require 'parse-time)
(let* ((org-with-time with-time)
(org-timestamp-rounding-minutes
(if (equal org-with-time '(16))
'(0 0)
org-timestamp-rounding-minutes))
(ct (org-current-time))
(org-def (or org-overriding-default-time default-time ct))
(org-defdecode (decode-time org-def))
(cur-frame (selected-frame))
(mouse-autoselect-window nil) ; Don't let the mouse jump
(calendar-setup
(and (eq calendar-setup 'calendar-only) 'calendar-only))
(calendar-move-hook nil)
(calendar-view-diary-initially-flag nil)
(calendar-view-holidays-initially-flag nil)
ans (org-ans0 "") org-ans1 org-ans2 final cal-frame)
;; Rationalize `org-def' and `org-defdecode', if required.
;; Only consider `org-extend-today-until' when explicit reference
;; time is not given.
(when (and (not default-time)
(not org-overriding-default-time)
(< (nth 2 org-defdecode) org-extend-today-until))
(setf (nth 2 org-defdecode) -1)
(setf (nth 1 org-defdecode) 59)
(setq org-def (org-encode-time org-defdecode))
(setq org-defdecode (decode-time org-def)))
(let* ((timestr (format-time-string
(if org-with-time "%Y-%m-%d %H:%M" "%Y-%m-%d")
org-def))
(prompt (concat (if prompt (concat prompt " ") "")
(format "Date+time [%s]: " timestr))))
(cond
(from-string (setq ans from-string))
(org-read-date-popup-calendar
(save-excursion
(save-window-excursion
(calendar)
(when (eq calendar-setup 'calendar-only)
(setq cal-frame
(window-frame (get-buffer-window calendar-buffer 'visible)))
(select-frame cal-frame))
(org-eval-in-calendar '(setq cursor-type nil) t)
(unwind-protect
(progn
(calendar-forward-day (- (time-to-days org-def)
(calendar-absolute-from-gregorian
(calendar-current-date))))
(org-eval-in-calendar nil t)
(let* ((old-map (current-local-map))
(map (copy-keymap calendar-mode-map))
(minibuffer-local-map
(copy-keymap org-read-date-minibuffer-local-map)))
(org-defkey map (kbd "RET") 'org-calendar-select)
(org-defkey map [mouse-1] 'org-calendar-select-mouse)
(org-defkey map [mouse-2] 'org-calendar-select-mouse)
(unwind-protect
(progn
(use-local-map map)
(setq org-read-date-inactive inactive)
(add-hook 'post-command-hook 'org-read-date-display)
(setq org-ans0
(read-string prompt
default-input
'org-read-date-history
nil))
;; org-ans0: from prompt
;; org-ans1: from mouse click
;; org-ans2: from calendar motion
(setq ans
(concat org-ans0 " " (or org-ans1 org-ans2))))
(remove-hook 'post-command-hook 'org-read-date-display)
(use-local-map old-map)
(when org-read-date-overlay
(delete-overlay org-read-date-overlay)
(setq org-read-date-overlay nil)))))
(bury-buffer calendar-buffer)
(when cal-frame
(delete-frame cal-frame)
(select-frame-set-input-focus cur-frame))))))
(t ; Naked prompt only
(unwind-protect
(setq ans (read-string prompt default-input
'org-read-date-history timestr))
(when org-read-date-overlay
(delete-overlay org-read-date-overlay)
(setq org-read-date-overlay nil))))))
(setq final (org-read-date-analyze ans org-def org-defdecode))
(when org-read-date-analyze-forced-year
(message "Year was forced into %s"
(if org-read-date-force-compatible-dates
"compatible range (1970-2037)"
"range representable on this machine"))
(ding))
(setq final (org-encode-time final))
(setq org-read-date-final-answer ans)
(if to-time
final
;; This round-trip gets rid of 34th of August and stuff like that....
(setq final (decode-time final))
(if (and (boundp 'org-time-was-given) org-time-was-given)
(format "%04d-%02d-%02d %02d:%02d"
(nth 5 final) (nth 4 final) (nth 3 final)
(nth 2 final) (nth 1 final))
(format "%04d-%02d-%02d" (nth 5 final) (nth 4 final) (nth 3 final))))))
(defun org-read-date-display ()
"Display the current date prompt interpretation in the minibuffer."
(when org-read-date-display-live
(when org-read-date-overlay
(delete-overlay org-read-date-overlay))
(when (minibufferp (current-buffer))
(save-excursion
(end-of-line 1)
(while (not (equal (buffer-substring
(max (point-min) (- (point) 4)) (point))
" "))
(insert " ")))
(let* ((ans (concat (buffer-substring (line-beginning-position)
(point-max))
" " (or org-ans1 org-ans2)))
(org-end-time-was-given nil)
(f (org-read-date-analyze ans org-def org-defdecode))
(fmt (org-time-stamp-format
(or org-with-time
(and (boundp 'org-time-was-given) org-time-was-given))
org-read-date-inactive
org-display-custom-times))
(txt (format-time-string fmt (org-encode-time f)))
(txt (concat "=> " txt)))
(when (and org-end-time-was-given
(string-match org-plain-time-of-day-regexp txt))
(setq txt (concat (substring txt 0 (match-end 0)) "-"
org-end-time-was-given
(substring txt (match-end 0)))))
(when org-read-date-analyze-futurep
(setq txt (concat txt " (=>F)")))
(setq org-read-date-overlay
(make-overlay (1- (line-end-position)) (line-end-position)))
;; Avoid priority race with overlay used by calendar.el.
;; See bug#69271.
(overlay-put org-read-date-overlay 'priority 1)
(org-overlay-display org-read-date-overlay txt 'secondary-selection)))))
(defun org-read-date-analyze (ans def defdecode)
"Analyze the combined answer of the date prompt."
;; FIXME: cleanup and comment
(let ((org-def def)
(org-defdecode defdecode)
(nowdecode (decode-time))
delta deltan deltaw deltadef year month day
hour minute second wday pm h2 m2 tl wday1
iso-year iso-weekday iso-week iso-date futurep kill-year)
(setq org-read-date-analyze-futurep nil
org-read-date-analyze-forced-year nil)
(when (string-match "\\`[ \t]*\\.[ \t]*\\'" ans)
(setq ans "+0"))
(when (setq delta (org-read-date-get-relative ans nil org-def))
(setq ans (replace-match "" t t ans)
deltan (car delta)
deltaw (nth 1 delta)
deltadef (nth 2 delta)))
;; Check if there is an iso week date in there. If yes, store the
;; info and postpone interpreting it until the rest of the parsing
;; is done.
(when (string-match "\\<\\(?:\\([0-9]+\\)-\\)?[wW]\\([0-9]\\{1,2\\}\\)\\(?:-\\([0-6]\\)\\)?\\([ \t]\\|$\\)" ans)
(setq iso-year (when (match-end 1)
(org-small-year-to-year
(string-to-number (match-string 1 ans))))
iso-weekday (when (match-end 3)
(string-to-number (match-string 3 ans)))
iso-week (string-to-number (match-string 2 ans)))
(setq ans (replace-match "" t t ans)))
;; Help matching ISO dates with single digit month or day, like 2006-8-11.
(when (string-match
"^ *\\(\\([0-9]+\\)-\\)?\\([0-1]?[0-9]\\)-\\([0-3]?[0-9]\\)\\([^-0-9]\\|$\\)" ans)
(setq year (if (match-end 2)
(string-to-number (match-string 2 ans))
(progn (setq kill-year t)
(string-to-number (format-time-string "%Y"))))
month (string-to-number (match-string 3 ans))
day (string-to-number (match-string 4 ans)))
(setq year (org-small-year-to-year year))
(setq ans (replace-match (format "%04d-%02d-%02d\\5" year month day)
t nil ans)))
;; Help matching dotted european dates
(when (string-match
"^ *\\(3[01]\\|0?[1-9]\\|[12][0-9]\\)\\. ?\\(0?[1-9]\\|1[012]\\)\\.\\( ?[1-9][0-9]\\{3\\}\\)?" ans)
(setq year (if (match-end 3) (string-to-number (match-string 3 ans))
(setq kill-year t)
(string-to-number (format-time-string "%Y")))
day (string-to-number (match-string 1 ans))
month (string-to-number (match-string 2 ans))
ans (replace-match (format "%04d-%02d-%02d" year month day)
t nil ans)))
;; Help matching american dates, like 5/30 or 5/30/7
(when (string-match
"^ *\\(0?[1-9]\\|1[012]\\)/\\(0?[1-9]\\|[12][0-9]\\|3[01]\\)\\(/\\([0-9]+\\)\\)?\\([^/0-9]\\|$\\)" ans)
(setq year (if (match-end 4)
(string-to-number (match-string 4 ans))
(progn (setq kill-year t)
(string-to-number (format-time-string "%Y"))))
month (string-to-number (match-string 1 ans))
day (string-to-number (match-string 2 ans)))
(setq year (org-small-year-to-year year))
(setq ans (replace-match (format "%04d-%02d-%02d\\5" year month day)
t nil ans)))
;; Help matching am/pm times, because `parse-time-string' does not do that.
;; If there is a time with am/pm, and *no* time without it, we convert
;; so that matching will be successful.
(cl-loop for i from 1 to 2 do ; twice, for end time as well
(when (and (not (string-match "\\(\\`\\|[^+]\\)[012]?[0-9]:[0-9][0-9]\\([ \t\n]\\|$\\)" ans))
(string-match "\\([012]?[0-9]\\)\\(:\\([0-5][0-9]\\)\\)?\\(am\\|AM\\|pm\\|PM\\)\\>" ans))
(setq hour (string-to-number (match-string 1 ans))
minute (if (match-end 3)
(string-to-number (match-string 3 ans))
0)
pm (equal ?p
(string-to-char (downcase (match-string 4 ans)))))
(if (and (= hour 12) (not pm))
(setq hour 0)
(when (and pm (< hour 12)) (setq hour (+ 12 hour))))
(setq ans (replace-match (format "%02d:%02d" hour minute)
t t ans))))
;; Help matching HHhMM times, similarly as for am/pm times.
(cl-loop for i from 1 to 2 do ; twice, for end time as well
(when (and (not (string-match "\\(\\`\\|[^+]\\)[012]?[0-9]:[0-9][0-9]\\([ \t\n]\\|$\\)" ans))
(string-match "\\(?:\\(?1:[012]?[0-9]\\)?h\\(?2:[0-5][0-9]\\)\\)\\|\\(?:\\(?1:[012]?[0-9]\\)h\\(?2:[0-5][0-9]\\)?\\)\\>" ans))
(setq hour (if (match-end 1)
(string-to-number (match-string 1 ans))
0)
minute (if (match-end 2)
(string-to-number (match-string 2 ans))
0))
(setq ans (replace-match (format "%02d:%02d" hour minute)
t t ans))))
;; Check if a time range is given as a duration
(when (string-match "\\([012]?[0-9]\\):\\([0-6][0-9]\\)\\+\\([012]?[0-9]\\)\\(:\\([0-5][0-9]\\)\\)?" ans)
(setq hour (string-to-number (match-string 1 ans))
h2 (+ hour (string-to-number (match-string 3 ans)))
minute (string-to-number (match-string 2 ans))
m2 (+ minute (if (match-end 5) (string-to-number
(match-string 5 ans))0)))
(when (>= m2 60) (setq h2 (1+ h2) m2 (- m2 60)))
(setq ans (replace-match (format "%02d:%02d-%02d:%02d" hour minute h2 m2)
t t ans)))
;; Check if there is a time range
(when (boundp 'org-end-time-was-given)
(setq org-time-was-given nil)
(when (and (string-match org-plain-time-of-day-regexp ans)
(match-end 8))
(setq org-end-time-was-given (match-string 8 ans))
(setq ans (concat (substring ans 0 (match-beginning 7))
(substring ans (match-end 7))))))
(setq tl (parse-time-string ans)
day (or (nth 3 tl) (nth 3 org-defdecode))
month
(cond ((nth 4 tl))
((not org-read-date-prefer-future) (nth 4 org-defdecode))
;; Day was specified. Make sure DAY+MONTH
;; combination happens in the future.
((nth 3 tl)
(setq futurep t)
(if (< day (nth 3 nowdecode)) (1+ (nth 4 nowdecode))
(nth 4 nowdecode)))
(t (nth 4 org-defdecode)))
year
(cond ((and (not kill-year) (nth 5 tl)))
((not org-read-date-prefer-future) (nth 5 org-defdecode))
;; Month was guessed in the future and is at least
;; equal to NOWDECODE's. Fix year accordingly.
(futurep
(if (or (> month (nth 4 nowdecode))
(>= day (nth 3 nowdecode)))
(nth 5 nowdecode)
(1+ (nth 5 nowdecode))))
;; Month was specified. Make sure MONTH+YEAR
;; combination happens in the future.
((nth 4 tl)
(setq futurep t)
(cond ((> month (nth 4 nowdecode)) (nth 5 nowdecode))
((< month (nth 4 nowdecode)) (1+ (nth 5 nowdecode)))
((< day (nth 3 nowdecode)) (1+ (nth 5 nowdecode)))
(t (nth 5 nowdecode))))
(t (nth 5 org-defdecode)))
hour (or (nth 2 tl) (nth 2 org-defdecode))
minute (or (nth 1 tl) (nth 1 org-defdecode))
second (or (nth 0 tl) 0)
wday (nth 6 tl))
(when (and (eq org-read-date-prefer-future 'time)
(not (nth 3 tl)) (not (nth 4 tl)) (not (nth 5 tl))
(equal day (nth 3 nowdecode))
(equal month (nth 4 nowdecode))
(equal year (nth 5 nowdecode))
(nth 2 tl)
(or (< (nth 2 tl) (nth 2 nowdecode))
(and (= (nth 2 tl) (nth 2 nowdecode))
(nth 1 tl)
(< (nth 1 tl) (nth 1 nowdecode)))))
(setq day (1+ day)
futurep t))
;; Special date definitions below
(cond
(iso-week
;; There was an iso week
(require 'cal-iso)
(setq futurep nil)
(setq year (or iso-year year)
day (or iso-weekday wday 1)
wday nil ; to make sure that the trigger below does not match
iso-date (calendar-gregorian-from-absolute
(calendar-iso-to-absolute
(list iso-week day year))))
; FIXME: Should we also push ISO weeks into the future?
; (when (and org-read-date-prefer-future
; (not iso-year)
; (< (calendar-absolute-from-gregorian iso-date)
; (time-to-days nil)))
; (setq year (1+ year)
; iso-date (calendar-gregorian-from-absolute
; (calendar-iso-to-absolute
; (list iso-week day year)))))
(setq month (car iso-date)
year (nth 2 iso-date)
day (nth 1 iso-date)))
(deltan
(setq futurep nil)
(unless deltadef
(let ((now (decode-time)))
(setq day (nth 3 now) month (nth 4 now) year (nth 5 now))))
;; FIXME: Duplicated value in ‘cond’: ""
(cond ((member deltaw '("h" ""))
(when (boundp 'org-time-was-given)
(setq org-time-was-given t))
(setq hour (+ hour deltan)))
((member deltaw '("d" "")) (setq day (+ day deltan)))
((equal deltaw "w") (setq day (+ day (* 7 deltan))))
((equal deltaw "m") (setq month (+ month deltan)))
((equal deltaw "y") (setq year (+ year deltan)))))
((and wday (not (nth 3 tl)))
;; Weekday was given, but no day, so pick that day in the week
;; on or after the derived date.
(setq wday1 (nth 6 (decode-time (org-encode-time 0 0 0 day month year))))
(unless (equal wday wday1)
(setq day (+ day (% (- wday wday1 -7) 7))))))
(when (and (boundp 'org-time-was-given)
(nth 2 tl))
(setq org-time-was-given t))
(when (< year 100) (setq year (+ 2000 year)))
;; Check of the date is representable
(if org-read-date-force-compatible-dates
(progn
(when (< year 1970)
(setq year 1970 org-read-date-analyze-forced-year t))
(when (> year 2037)
(setq year 2037 org-read-date-analyze-forced-year t)))
(condition-case nil
(ignore (org-encode-time second minute hour day month year))
(error
(setq year (nth 5 org-defdecode))
(setq org-read-date-analyze-forced-year t))))
(setq org-read-date-analyze-futurep futurep)
(list second minute hour day month year nil -1 nil)))
(defvar parse-time-weekdays)
(defun org-read-date-get-relative (s today default)
"Check string S for special relative date string.
TODAY and DEFAULT are internal times, for today and for a default.
Return shift list (N what def-flag)
WHAT is \"d\", \"w\", \"m\", or \"y\" for day, week, month, year.
N is the number of WHATs to shift.
DEF-FLAG is t when a double ++ or -- indicates shift relative to
the DEFAULT date rather than TODAY."
(require 'parse-time)
(when (and
;; Force case-insensitive.
(let ((case-fold-search t))
(string-match
(concat
"\\`[ \t]*\\([-+]\\{0,2\\}\\)"
"\\([0-9]+\\)?"
"\\([hdwmy]\\|\\(" (mapconcat 'car parse-time-weekdays "\\|") "\\)\\)?"
"\\([ \t]\\|$\\)") s))
(or (> (match-end 1) (match-beginning 1)) (match-end 4)))
(let* ((dir (if (> (match-end 1) (match-beginning 1))
(string-to-char (substring (match-string 1 s) -1))
?+))
(rel (and (match-end 1) (= 2 (- (match-end 1) (match-beginning 1)))))
(n (if (match-end 2) (string-to-number (match-string 2 s)) 1))
(what (if (match-end 3) (match-string 3 s) "d"))
(wday1 (cdr (assoc (downcase what) parse-time-weekdays)))
(date (if rel default today))
(wday (nth 6 (decode-time date)))
delta)
(if wday1
(progn
(setq delta (mod (+ 7 (- wday1 wday)) 7))
(when (= delta 0) (setq delta 7))
(when (= dir ?-)
(setq delta (- delta 7))
(when (= delta 0) (setq delta -7)))
(when (> n 1) (setq delta (+ delta (* (1- n) (if (= dir ?-) -7 7)))))
(list delta "d" rel))
(list (* n (if (= dir ?-) -1 1)) what rel)))))
(defun org-order-calendar-date-args (arg1 arg2 arg3)
"Turn a user-specified date into the internal representation.
The internal representation needed by the calendar is (month day year).
This is a wrapper to handle the brain-dead convention in calendar that
user function argument order change dependent on argument order."
(pcase calendar-date-style
(`american (list arg1 arg2 arg3))
(`european (list arg2 arg1 arg3))
(`iso (list arg2 arg3 arg1))))
(defun org-eval-in-calendar (form &optional keepdate)
"Eval FORM in the calendar window and return to current window.
Unless KEEPDATE is non-nil, update `org-ans2' to the cursor date."
(let ((sf (selected-frame))
(sw (selected-window)))
(select-window (get-buffer-window calendar-buffer t))
(eval form t)
(when (and (not keepdate) (calendar-cursor-to-date))
(let* ((date (calendar-cursor-to-date))
(time (org-encode-time 0 0 0 (nth 1 date) (nth 0 date) (nth 2 date))))
(setq org-ans2 (format-time-string "%Y-%m-%d" time))))
(move-overlay org-date-ovl (1- (point)) (1+ (point)) (current-buffer))
(select-window sw)
(select-frame-set-input-focus sf)))
(defun org-calendar-goto-today-or-insert-dot ()
"Go to the current date, or insert a dot.
If at the beginning of the prompt, behave as `org-calendar-goto-today' else
insert \".\"."
(interactive)
;; Are we at the beginning of the prompt?
(if (looking-back "^[^:]+: "
(let ((inhibit-field-text-motion t))
(line-beginning-position)))
(org-eval-in-calendar '(calendar-goto-today))
(insert ".")))
(defun org-calendar-goto-today ()
"Reposition the calendar window so the current date is visible."
(interactive)
(org-eval-in-calendar '(calendar-goto-today)))
(defun org-calendar-backward-month ()
"Move the cursor backward by one month."
(interactive)
(org-eval-in-calendar '(calendar-backward-month 1)))
(defun org-calendar-forward-month ()
"Move the cursor forward by one month."
(interactive)
(org-eval-in-calendar '(calendar-forward-month 1)))
(defun org-calendar-backward-year ()
"Move the cursor backward by one year."
(interactive)
(org-eval-in-calendar '(calendar-backward-year 1)))
(defun org-calendar-forward-year ()
"Move the cursor forward by one year."
(interactive)
(org-eval-in-calendar '(calendar-forward-year 1)))
(defun org-calendar-backward-week ()
"Move the cursor backward by one week."
(interactive)
(org-eval-in-calendar '(calendar-backward-week 1)))
(defun org-calendar-forward-week ()
"Move the cursor forward by one week."
(interactive)
(org-eval-in-calendar '(calendar-forward-week 1)))
(defun org-calendar-backward-day ()
"Move the cursor backward by one day."
(interactive)
(org-eval-in-calendar '(calendar-backward-day 1)))
(defun org-calendar-forward-day ()
"Move the cursor forward by one day."
(interactive)
(org-eval-in-calendar '(calendar-forward-day 1)))
(defun org-calendar-view-entries ()
"Prepare and display a buffer with diary entries."
(interactive)
(org-eval-in-calendar '(diary-view-entries))
(message ""))
(defun org-calendar-scroll-month-left ()
"Scroll the displayed calendar left by one month."
(interactive)
(org-eval-in-calendar '(calendar-scroll-left 1)))
(defun org-calendar-scroll-month-right ()
"Scroll the displayed calendar right by one month."
(interactive)
(org-eval-in-calendar '(calendar-scroll-right 1)))
(defun org-calendar-scroll-three-months-left ()
"Scroll the displayed calendar left by three months."
(interactive)
(org-eval-in-calendar
'(calendar-scroll-left-three-months 1)))
(defun org-calendar-scroll-three-months-right ()
"Scroll the displayed calendar right by three months."
(interactive)
(org-eval-in-calendar
'(calendar-scroll-right-three-months 1)))
(defun org-calendar-select ()
"Return to `org-read-date' with the date currently selected.
This is used by `org-read-date' in a temporary keymap for the calendar buffer."
(interactive)
(when (calendar-cursor-to-date)
(let* ((date (calendar-cursor-to-date))
(time (org-encode-time 0 0 0 (nth 1 date) (nth 0 date) (nth 2 date))))
(setq org-ans1 (format-time-string "%Y-%m-%d" time)))
(when (active-minibuffer-window) (exit-minibuffer))))
(defalias 'org-insert-time-stamp #'org-insert-timestamp)
(defun org-insert-timestamp (time &optional with-hm inactive pre post extra)
"Insert a date stamp for the date given by the internal TIME.
See `format-time-string' for the format of TIME.
WITH-HM means use the stamp format that includes the time of the day.
INACTIVE means use square brackets instead of angular ones, so that the
stamp will not contribute to the agenda.
PRE and POST are optional strings to be inserted before and after the
stamp.
The command returns the inserted time stamp."
(org-fold-core-ignore-modifications
(let ((fmt (org-time-stamp-format with-hm inactive))
stamp)
(insert-before-markers-and-inherit (or pre ""))
(when (listp extra)
(setq extra (car extra))
(if (and (stringp extra)
(string-match "\\([0-9]+\\):\\([0-9]+\\)" extra))
(setq extra (format "-%02d:%02d"
(string-to-number (match-string 1 extra))
(string-to-number (match-string 2 extra))))
(setq extra nil)))
(when extra
(setq fmt (concat (substring fmt 0 -1) extra (substring fmt -1))))
(insert-before-markers-and-inherit (setq stamp (format-time-string fmt time)))
(insert-before-markers-and-inherit (or post ""))
(setq org-last-inserted-timestamp stamp))))
(defalias 'org-toggle-time-stamp-overlays #'org-toggle-timestamp-overlays)
(defun org-toggle-timestamp-overlays ()
"Toggle the use of custom time stamp formats."
(interactive)
(setq org-display-custom-times (not org-display-custom-times))
(unless org-display-custom-times
(let ((p (point-min)) (bmp (buffer-modified-p)))
(while (setq p (next-single-property-change p 'display))
(when (and (get-text-property p 'display)
(eq (get-text-property p 'face) 'org-date))
(remove-text-properties
p (setq p (next-single-property-change p 'display))
'(display t))))
(set-buffer-modified-p bmp)))
(org-restart-font-lock)
(setq org-table-may-need-update t)
(if org-display-custom-times
(message "Time stamps are overlaid with custom format")
(message "Time stamp overlays removed")))
(defun org-display-custom-time (beg end)
"Overlay modified time stamp format over timestamp between BEG and END."
(let* ((ts (buffer-substring beg end))
t1 with-hm tf time str (off 0))
(save-match-data
(setq t1 (org-parse-time-string ts t))
(when (string-match "\\(-[0-9]+:[0-9]+\\)?\\( [.+]?\\+[0-9]+[hdwmy]\\(/[0-9]+[hdwmy]\\)?\\)?\\'" ts)
(setq off (- (match-end 0) (match-beginning 0)))))
(setq end (- end off))
(setq with-hm (and (nth 1 t1) (nth 2 t1))
tf (org-time-stamp-format with-hm 'no-brackets 'custom)
time (org-fix-decoded-time t1)
str (org-add-props
(format-time-string tf (org-encode-time time))
nil 'mouse-face 'highlight))
(put-text-property beg end 'display str)))
(defun org-fix-decoded-time (time)
"Set 0 instead of nil for the first 6 elements of time.
Don't touch the rest."
(let ((n 0))
(mapcar (lambda (x) (if (< (setq n (1+ n)) 7) (or x 0) x)) time)))
(defalias 'org-time-stamp-to-now #'org-timestamp-to-now)
(defun org-timestamp-to-now (timestamp-string &optional seconds)
"Difference between TIMESTAMP-STRING and now in days.
If SECONDS is non-nil, return the difference in seconds."
(let ((fdiff (if seconds #'float-time #'time-to-days)))
(- (funcall fdiff (org-time-string-to-time timestamp-string))
(funcall fdiff nil))))
(defun org-deadline-close-p (timestamp-string &optional ndays)
"Is the time in TIMESTAMP-STRING close to the current date?"
(setq ndays (or ndays (org-get-wdays timestamp-string)))
(and (<= (org-timestamp-to-now timestamp-string) ndays)
(not (org-entry-is-done-p))))
(defun org-get-wdays (ts &optional delay zero-delay)
"Get the deadline lead time appropriate for timestring TS.
When DELAY is non-nil, get the delay time for scheduled items
instead of the deadline lead time. When ZERO-DELAY is non-nil
and `org-scheduled-delay-days' is 0, enforce 0 as the delay,
don't try to find the delay cookie in the scheduled timestamp."
(let ((tv (if delay org-scheduled-delay-days
org-deadline-warning-days)))
(cond
((or (and delay (< tv 0))
(and delay zero-delay (<= tv 0))
(and (not delay) (<= tv 0)))
;; Enforce this value no matter what
(- tv))
((string-match "-\\([0-9]+\\)\\([hdwmy]\\)\\(\\'\\|>\\| \\)" ts)
;; lead time is specified.
(floor (* (string-to-number (match-string 1 ts))
(cdr (assoc (match-string 2 ts)
'(("d" . 1) ("w" . 7)
("m" . 30.4) ("y" . 365.25)
("h" . 0.041667)))))))
;; go for the default.
(t tv))))
(defun org-calendar-select-mouse (ev)
"Return to `org-read-date' with the date currently selected.
This is used by `org-read-date' in a temporary keymap for the calendar buffer."
(interactive "e")
(mouse-set-point ev)
(when (calendar-cursor-to-date)
(let* ((date (calendar-cursor-to-date))
(time (org-encode-time 0 0 0 (nth 1 date) (nth 0 date) (nth 2 date))))
(setq org-ans1 (format-time-string "%Y-%m-%d" time)))
(when (active-minibuffer-window) (exit-minibuffer))))
(defun org-check-deadlines (ndays)
"Check if there are any deadlines due or past due.
A deadline is considered due if it happens within `org-deadline-warning-days'
days from today's date. If the deadline appears in an entry marked DONE,
it is not shown. A numeric prefix argument NDAYS can be used to test that
many days. If the prefix is a raw `\\[universal-argument]', all deadlines \
are shown."
(interactive "P")
(let* ((org-warn-days
(cond
((equal ndays '(4)) 100000)
(ndays (prefix-numeric-value ndays))
(t (abs org-deadline-warning-days))))
(case-fold-search nil)
(regexp (concat "\\<" org-deadline-string " *<\\([^>]+\\)>"))
(callback
(lambda () (org-deadline-close-p (match-string 1) org-warn-days))))
(message "%d deadlines past-due or due within %d days"
(org-occur regexp nil callback)
org-warn-days)))
(defsubst org-re-timestamp (type)
"Return a regexp for timestamp TYPE.
Allowed values for TYPE are:
all: all timestamps
active: only active timestamps (<...>)
inactive: only inactive timestamps ([...])
scheduled: only scheduled timestamps
deadline: only deadline timestamps
closed: only closed timestamps
When TYPE is nil, fall back on returning a regexp that matches
both scheduled and deadline timestamps."
(cl-case type
(all org-ts-regexp-both)
(active org-ts-regexp)
(inactive org-ts-regexp-inactive)
(scheduled org-scheduled-time-regexp)
(deadline org-deadline-time-regexp)
(closed org-closed-time-regexp)
(otherwise
(concat "\\<"
(regexp-opt (list org-deadline-string org-scheduled-string))
" *<\\([^>]+\\)>"))))
(defun org-check-before-date (d)
"Check if there are deadlines or scheduled entries before date D."
(interactive (list (org-read-date)))
(let* ((case-fold-search nil)
(regexp (org-re-timestamp org-ts-type))
(ts-type org-ts-type)
(callback
(lambda ()
(let ((match (match-string 1)))
(and (if (memq ts-type '(active inactive all))
(org-element-type-p
(save-excursion
(backward-char)
(org-element-context))
'timestamp)
(org-at-planning-p))
(time-less-p
(org-time-string-to-time match)
(org-time-string-to-time d)))))))
(message "%d entries before %s"
(org-occur regexp nil callback)
d)))
(defun org-check-after-date (d)
"Check if there are deadlines or scheduled entries after date D."
(interactive (list (org-read-date)))
(let* ((case-fold-search nil)
(regexp (org-re-timestamp org-ts-type))
(ts-type org-ts-type)
(callback
(lambda ()
(let ((match (match-string 1)))
(and (if (memq ts-type '(active inactive all))
(org-element-type-p
(save-excursion
(backward-char)
(org-element-context))
'timestamp)
(org-at-planning-p))
(not (time-less-p
(org-time-string-to-time match)
(org-time-string-to-time d))))))))
(message "%d entries after %s"
(org-occur regexp nil callback)
d)))
(defun org-check-dates-range (start-date end-date)
"Check for deadlines/scheduled entries between START-DATE and END-DATE."
(interactive (list (org-read-date nil nil nil "Range starts")
(org-read-date nil nil nil "Range end")))
(let ((case-fold-search nil)
(regexp (org-re-timestamp org-ts-type))
(callback
(let ((type org-ts-type))
(lambda ()
(let ((match (match-string 1)))
(and
(if (memq type '(active inactive all))
(org-element-type-p
(save-excursion
(backward-char)
(org-element-context))
'timestamp)
(org-at-planning-p))
(not (time-less-p
(org-time-string-to-time match)
(org-time-string-to-time start-date)))
(time-less-p
(org-time-string-to-time match)
(org-time-string-to-time end-date))))))))
(message "%d entries between %s and %s"
(org-occur regexp nil callback) start-date end-date)))
(defun org-evaluate-time-range (&optional to-buffer)
"Evaluate a time range by computing the difference between start and end.
Normally the result is just printed in the echo area, but with prefix arg
TO-BUFFER, the result is inserted just after the date stamp into the buffer.
If the time range is actually in a table, the result is inserted into the
next column.
For time difference computation, a year is assumed to be exactly 365
days in order to avoid rounding problems."
(interactive "P")
(or
(org-clock-update-time-maybe)
(save-excursion
(unless (org-at-date-range-p t)
(goto-char (line-beginning-position))
(re-search-forward org-tr-regexp-both (line-end-position) t))
(unless (org-at-date-range-p t)
(user-error "Not at a timestamp range, and none found in current line")))
(let* ((ts1 (match-string 1))
(ts2 (match-string 2))
(havetime (or (> (length ts1) 15) (> (length ts2) 15)))
(match-end (match-end 0))
(time1 (org-time-string-to-time ts1))
(time2 (org-time-string-to-time ts2))
(diff (abs (float-time (time-subtract time2 time1))))
(negative (time-less-p time2 time1))
;; (ys (floor (* 365 24 60 60)))
(ds (* 24 60 60))
(hs (* 60 60))
(fy "%dy %dd %02d:%02d")
(fy1 "%dy %dd")
(fd "%dd %02d:%02d")
(fd1 "%dd")
(fh "%02d:%02d")
y d h m align)
(if havetime
(setq ; y (floor diff ys) diff (mod diff ys)
y 0
d (floor diff ds) diff (mod diff ds)
h (floor diff hs) diff (mod diff hs)
m (floor diff 60))
(setq ; y (floor diff ys) diff (mod diff ys)
y 0
d (round diff ds)
h 0 m 0))
(if (not to-buffer)
(message "%s" (org-make-tdiff-string y d h m))
(if (org-at-table-p)
(progn
(goto-char match-end)
(setq align t)
(and (looking-at " *|") (goto-char (match-end 0))))
(goto-char match-end))
(when (looking-at
"\\( *-? *[0-9]+y\\)?\\( *[0-9]+d\\)? *[0-9][0-9]:[0-9][0-9]")
(replace-match ""))
(when negative (insert " -"))
(if (> y 0) (insert " " (format (if havetime fy fy1) y d h m))
(if (> d 0) (insert " " (format (if havetime fd fd1) d h m))
(insert " " (format fh h m))))
(when align (org-table-align))
(message "Time difference inserted")))))
(defun org-make-tdiff-string (y d h m)
(let ((fmt "")
(l nil))
(when (> y 0)
(setq fmt (concat fmt "%d year" (if (> y 1) "s" "") " "))
(push y l))
(when (> d 0)
(setq fmt (concat fmt "%d day" (if (> d 1) "s" "") " "))
(push d l))
(when (> h 0)
(setq fmt (concat fmt "%d hour" (if (> h 1) "s" "") " "))
(push h l))
(when (> m 0)
(setq fmt (concat fmt "%d minute" (if (> m 1) "s" "") " "))
(push m l))
(apply 'format fmt (nreverse l))))
(defun org-time-string-to-time (s)
"Convert timestamp string S into internal time."
(org-encode-time (org-parse-time-string s)))
(defun org-time-string-to-seconds (s)
"Convert a timestamp string S into a number of seconds."
(float-time (org-time-string-to-time s)))
(define-error 'org-diary-sexp-no-match "Unable to match diary sexp")
(defun org-time-string-to-absolute (s &optional daynr prefer buffer pos)
"Convert time stamp S to an absolute day number.
If DAYNR in non-nil, and there is a specifier for a cyclic time
stamp, get the closest date to DAYNR. If PREFER is
`past' (respectively `future') return a date past (respectively
after) or equal to DAYNR.
POS is the location of time stamp S, as a buffer position in
BUFFER.
Diary sexp timestamps are matched against DAYNR, when non-nil.
If matching fails or DAYNR is nil, `org-diary-sexp-no-match' is
signaled."
(cond
((string-match "\\`%%\\((.*)\\)" s)
;; Sexp timestamp: try to match DAYNR, if available, since we're
;; only able to match individual dates. If it fails, raise an
;; error.
(if (and daynr
(org-diary-sexp-entry
(match-string 1 s) "" (calendar-gregorian-from-absolute daynr)))
daynr
(signal 'org-diary-sexp-no-match (list s))))
(daynr (org-closest-date s daynr prefer))
(t (time-to-days
(condition-case errdata
(org-time-string-to-time s)
(error (error "Bad timestamp `%s'%s\nError was: %s"
s
(if (not (and buffer pos)) ""
(format-message " at %d in buffer `%s'" pos buffer))
(cdr errdata))))))))
(defun org-days-to-iso-week (days)
"Return the ISO week number."
(require 'cal-iso)
(car (calendar-iso-from-absolute days)))
(defun org-small-year-to-year (year)
"Convert 2-digit years into 4-digit years.
YEAR is expanded into one of the 30 next years, if possible, or
into a past one. Any year larger than 99 is returned unchanged."
(if (>= year 100) year
(let* ((current (string-to-number (format-time-string "%Y")))
(century (/ current 100))
(offset (- year (% current 100))))
(cond ((> offset 30) (+ (* (1- century) 100) year))
((> offset -70) (+ (* century 100) year))
(t (+ (* (1+ century) 100) year))))))
(defun org-time-from-absolute (d)
"Return the time corresponding to date D.
D may be an absolute day number, or a calendar-type list (month day year)."
(when (numberp d) (setq d (calendar-gregorian-from-absolute d)))
(org-encode-time 0 0 0 (nth 1 d) (car d) (nth 2 d)))
(defvar org-agenda-current-date)
(defun org-calendar-holiday ()
"List of holidays, for Diary display in Org mode."
(require 'holidays)
(let ((hl (calendar-check-holidays org-agenda-current-date)))
(and hl (mapconcat #'identity hl "; "))))
(defvar org--diary-sexp-entry-cache (make-hash-table :test #'equal)
"Hash table holding return values of `org-diary-sexp-entry'.")
(defun org-diary-sexp-entry (sexp entry d)
"Process a SEXP diary ENTRY for date D."
(require 'diary-lib)
;; `org-anniversary' and alike expect ENTRY and DATE to be bound
;; dynamically.
(let ((cached (gethash (list sexp entry d) org--diary-sexp-entry-cache 'none)))
(if (not (eq 'none cached)) cached
(puthash (list sexp entry d)
(let* ((sexp `(let ((entry ,entry)
(date ',d))
,(car (read-from-string sexp))))
;; FIXME: Do not use (eval ... t) in the following sexp as
;; diary vars are still using dynamic scope.
(result (if calendar-debug-sexp (eval sexp)
(condition-case nil
(eval sexp)
(error
(beep)
(message "Bad sexp at line %d in %s: %s"
(org-current-line)
(buffer-file-name) sexp)
(sleep-for 2))))))
(cond ((stringp result) (split-string result "; "))
((and (consp result)
(not (consp (cdr result)))
(stringp (cdr result)))
(cdr result))
((and (consp result)
(stringp (car result)))
result)
(result entry)))
org--diary-sexp-entry-cache))))
(defun org-diary-to-ical-string (frombuf)
"Get iCalendar entries from diary entries in buffer FROMBUF.
This uses the icalendar.el library."
(let* ((tmpdir temporary-file-directory)
(tmpfile (make-temp-name
(expand-file-name "orgics" tmpdir)))
buf rtn b e)
(unwind-protect
(with-current-buffer frombuf
(icalendar-export-region (point-min) (point-max) tmpfile)
(setq buf (find-buffer-visiting tmpfile))
(set-buffer buf)
(goto-char (point-min))
(when (re-search-forward "^BEGIN:VEVENT" nil t)
(setq b (match-beginning 0)))
(goto-char (point-max))
(when (re-search-backward "^END:VEVENT" nil t)
(setq e (match-end 0)))
(setq rtn (if (and b e) (concat (buffer-substring b e) "\n") "")))
(when (and buf (buffer-live-p buf)) (kill-buffer buf))
(delete-file tmpfile))
rtn))
(defun org-closest-date (start current prefer)
"Return closest date to CURRENT starting from START.
CURRENT and START are both time stamps.
When PREFER is `past', return a date that is either CURRENT or
past. When PREFER is `future', return a date that is either
CURRENT or future.
Only time stamps with a repeater are modified. Any other time
stamp stay unchanged. In any case, return value is an absolute
day number."
(if (not (string-match "\\+\\([0-9]+\\)\\([hdwmy]\\)" start))
;; No repeater. Do not shift time stamp.
(time-to-days (org-time-string-to-time start))
(let ((value (string-to-number (match-string 1 start)))
(type (match-string 2 start)))
(if (= 0 value)
;; Repeater with a 0-value is considered as void.
(time-to-days (org-time-string-to-time start))
(let* ((base (org-date-to-gregorian start))
(target (org-date-to-gregorian current))
(sday (calendar-absolute-from-gregorian base))
(cday (calendar-absolute-from-gregorian target))
n1 n2)
;; If START is already past CURRENT, just return START.
(if (<= cday sday) sday
;; Compute closest date before (N1) and closest date past
;; (N2) CURRENT.
(pcase type
("h"
(let ((missing-hours
(mod (+ (- (* 24 (- cday sday))
(nth 2 (org-parse-time-string start)))
org-extend-today-until)
value)))
(setf n1 (if (= missing-hours 0) cday
(- cday (1+ (/ missing-hours 24)))))
(setf n2 (+ cday (/ (- value missing-hours) 24)))))
((or "d" "w")
(let ((value (if (equal type "w") (* 7 value) value)))
(setf n1 (+ sday (* value (/ (- cday sday) value))))
(setf n2 (+ n1 value))))
("m"
(let* ((add-months
(lambda (d n)
;; Add N months to gregorian date D, i.e.,
;; a list (MONTH DAY YEAR). Return a valid
;; gregorian date.
(let ((m (+ (nth 0 d) n)))
(list (mod m 12)
(nth 1 d)
(+ (/ m 12) (nth 2 d))))))
(months ; Complete months to TARGET.
(* (/ (+ (* 12 (- (nth 2 target) (nth 2 base)))
(- (nth 0 target) (nth 0 base))
;; If START's day is greater than
;; TARGET's, remove incomplete month.
(if (> (nth 1 target) (nth 1 base)) 0 -1))
value)
value))
(before (funcall add-months base months)))
(setf n1 (calendar-absolute-from-gregorian before))
(setf n2
(calendar-absolute-from-gregorian
(funcall add-months before value)))))
(_
(let* ((d (nth 1 base))
(m (nth 0 base))
(y (nth 2 base))
(years ; Complete years to TARGET.
(* (/ (- (nth 2 target)
y
;; If START's month and day are
;; greater than TARGET's, remove
;; incomplete year.
(if (or (> (nth 0 target) m)
(and (= (nth 0 target) m)
(> (nth 1 target) d)))
0
1))
value)
value))
(before (list m d (+ y years))))
(setf n1 (calendar-absolute-from-gregorian before))
(setf n2 (calendar-absolute-from-gregorian
(list m d (+ (nth 2 before) value)))))))
;; Handle PREFER parameter, if any.
(cond
((eq prefer 'past) (if (= cday n2) n2 n1))
((eq prefer 'future) (if (= cday n1) n1 n2))
(t (if (> (abs (- cday n1)) (abs (- cday n2))) n2 n1)))))))))
(defun org-date-to-gregorian (d)
"Turn any specification of date D into a Gregorian date for the calendar."
(cond ((integerp d) (calendar-gregorian-from-absolute d))
((and (listp d) (= (length d) 3)) d)
((stringp d)
(let ((d (org-parse-time-string d)))
(list (nth 4 d) (nth 3 d) (nth 5 d))))
((listp d) (list (nth 4 d) (nth 3 d) (nth 5 d)))))
(defun org-timestamp-up (&optional arg)
"Increase the date item at the cursor by one.
If the cursor is on the year, change the year. If it is on the month,
the day or the time, change that. If the cursor is on the enclosing
bracket, change the timestamp type.
With prefix ARG, change by that many units."
(interactive "p")
(org-timestamp-change (prefix-numeric-value arg) nil 'updown))
(defun org-timestamp-down (&optional arg)
"Decrease the date item at the cursor by one.
If the cursor is on the year, change the year. If it is on the month,
the day or the time, change that. If the cursor is on the enclosing
bracket, change the timestamp type.
With prefix ARG, change by that many units."
(interactive "p")
(org-timestamp-change (- (prefix-numeric-value arg)) nil 'updown))
(defun org-timestamp-up-day (&optional arg)
"Increase the date in the time stamp by one day.
With prefix ARG, change that many days."
(interactive "p")
(if (and (not (org-at-timestamp-p 'lax))
(org-at-heading-p))
(org-todo 'up)
(org-timestamp-change (prefix-numeric-value arg) 'day 'updown)))
(defun org-timestamp-down-day (&optional arg)
"Decrease the date in the time stamp by one day.
With prefix ARG, change that many days."
(interactive "p")
(if (and (not (org-at-timestamp-p 'lax))
(org-at-heading-p))
(org-todo 'down)
(org-timestamp-change (- (prefix-numeric-value arg)) 'day) 'updown))
(defun org-at-timestamp-p (&optional extended)
"Non-nil if point is inside a timestamp.
By default, the function only consider syntactically valid active
timestamps. However, the caller may have a broader definition
for timestamps. As a consequence, optional argument EXTENDED can
be set to the following values
`inactive'
Include also syntactically valid inactive timestamps.
`agenda'
Include timestamps allowed in Agenda, i.e., those in
properties drawers, planning lines and clock lines.
`lax'
Ignore context. The function matches any part of the
document looking like a timestamp. This includes comments,
example blocks...
For backward-compatibility with Org 9.0, every other non-nil
value is equivalent to `inactive'.
When at a timestamp, return the position of the point as a symbol
among `bracket', `after', `year', `month', `hour', `minute',
`day' or a number of character from the last know part of the
time stamp. If diary sexp timestamps, any point inside the timestamp
is considered `day' (i.e. only `bracket', `day', and `after' return
values are possible).
When matching, the match groups are the following:
group 2: year, if any
group 3: month, if any
group 4: day number, if any
group 5: day name, if any
group 7: hours, if any
group 8: minutes, if any"
(let* ((regexp
(if extended
(if (eq extended 'agenda)
(rx-to-string
`(or (regexp ,org-ts-regexp3)
(regexp ,org-element--timestamp-regexp)))
org-ts-regexp3)
org-ts-regexp2))
(pos (point))
(match?
(let ((boundaries (org-in-regexp regexp)))
(save-match-data
(cond ((null boundaries) nil)
((eq extended 'lax) t)
(t
(or (and (eq extended 'agenda)
(or (org-at-planning-p)
(org-at-property-p)
(and (bound-and-true-p
org-agenda-include-inactive-timestamps)
(org-at-clock-log-p))))
(eq 'timestamp
(save-excursion
(when (= pos (cdr boundaries)) (forward-char -1))
(org-element-type (org-element-context)))))))))))
(cond
((not match?) nil)
((= pos (match-beginning 0)) 'bracket)
;; Distinguish location right before the closing bracket from
;; right after it.
((= pos (1- (match-end 0))) 'bracket)
((= pos (match-end 0)) 'after)
((org-pos-in-match-range pos 2) 'year)
((org-pos-in-match-range pos 3) 'month)
((org-pos-in-match-range pos 7) 'hour)
((org-pos-in-match-range pos 8) 'minute)
((or (org-pos-in-match-range pos 4)
(org-pos-in-match-range pos 5)) 'day)
((and (or (match-end 8) (match-end 5))
(> pos (or (match-end 8) (match-end 5)))
(< pos (match-end 0)))
(- pos (or (match-end 8) (match-end 5))))
(t 'day))))
(defun org-toggle-timestamp-type ()
"Toggle the type (<active> or [inactive]) of a time stamp."
(interactive)
(when (org-at-timestamp-p 'lax)
(let ((beg (match-beginning 0)) (end (match-end 0))
(map '((?\[ . "<") (?\] . ">") (?< . "[") (?> . "]"))))
(save-excursion
(goto-char beg)
(while (re-search-forward "[][<>]" end t)
(replace-match (cdr (assoc (char-after (match-beginning 0)) map))
t t)))
(message "Timestamp is now %sactive"
(if (equal (char-after beg) ?<) "" "in")))))
(defun org-at-clock-log-p ()
"Non-nil if point is on a clock log line."
(and (org-match-line org-clock-line-re)
(org-element-type-p
(save-match-data (org-element-at-point))
'clock)))
(defvar org-clock-history) ; defined in org-clock.el
(defvar org-clock-adjust-closest nil) ; defined in org-clock.el
(defun org-timestamp-change (n &optional what updown suppress-tmp-delay)
"Change the date in the time stamp at point.
The date is changed by N times WHAT. WHAT can be `day', `month',
`year', `hour', or `minute'. If WHAT is not given, the cursor
position in the timestamp determines what is changed.
When optional argument UPDOWN is non-nil, minutes are rounded
according to `org-timestamp-rounding-minutes'.
When SUPPRESS-TMP-DELAY is non-nil, suppress delays like
\"--2d\"."
(let ((origin (point))
(timestamp? (org-at-timestamp-p 'lax))
origin-cat
with-hm inactive
(dm (max (nth 1 org-timestamp-rounding-minutes) 1))
extra rem
ts time time0 fixnext clrgx)
(unless timestamp? (user-error "Not at a timestamp"))
(if (and (not what) (eq timestamp? 'bracket))
(org-toggle-timestamp-type)
;; Point isn't on brackets. Remember the part of the timestamp
;; the point was in. Indeed, size of timestamps may change,
;; but point must be kept in the same category nonetheless.
(setq origin-cat timestamp?)
(when (and (not what) (not (eq timestamp? 'day))
org-display-custom-times
(get-text-property (point) 'display)
(not (get-text-property (1- (point)) 'display)))
(setq timestamp? 'day))
(setq timestamp? (or what timestamp?)
inactive (= (char-after (match-beginning 0)) ?\[)
ts (match-string 0))
;; FIXME: Instead of deleting everything and then inserting
;; later, we should make use of `replace-match', which preserves
;; markers. The current implementation suffers from
;; `save-excursion' not preserving point inside the timestamp
;; once we delete the timestamp here. The point moves to the
;; updated timestamp end.
(replace-match "")
(when (string-match
"\\(\\(-[012][0-9]:[0-5][0-9]\\)?\\( +[.+]?-?[-+][0-9]+[hdwmy]\\(/[0-9]+[hdwmy]\\)?\\)*\\)[]>]"
ts)
(setq extra (match-string 1 ts))
(when suppress-tmp-delay
(setq extra (replace-regexp-in-string " --[0-9]+[hdwmy]" "" extra))))
(when (string-match "^.\\{10\\}.*?[0-9]+:[0-9][0-9]" ts)
(setq with-hm t))
(setq time0 (org-parse-time-string ts))
(let ((increment n))
(if (and updown
(eq timestamp? 'minute)
(not current-prefix-arg))
;; This looks like s-up and s-down. Change by one rounding step.
(progn
(setq increment (* dm (cond ((> n 0) 1) ((< n 0) -1) (t 0))))
(unless (= 0 (setq rem (% (nth 1 time0) dm)))
(setcar (cdr time0) (+ (nth 1 time0)
(if (> n 0) (- rem) (- dm rem))))))
;; Do not round anything in `org-modify-ts-extra' when prefix
;; argument is supplied - just use whatever is provided by the
;; prefix argument.
(setq dm 1))
(setq time
(org-encode-time
(apply #'list
(or (car time0) 0)
(+ (if (eq timestamp? 'minute) increment 0) (nth 1 time0))
(+ (if (eq timestamp? 'hour) increment 0) (nth 2 time0))
(+ (if (eq timestamp? 'day) increment 0) (nth 3 time0))
(+ (if (eq timestamp? 'month) increment 0) (nth 4 time0))
(+ (if (eq timestamp? 'year) increment 0) (nth 5 time0))
(nthcdr 6 time0)))))
(when (and (memq timestamp? '(hour minute))
extra
(string-match "-\\([012][0-9]\\):\\([0-5][0-9]\\)" extra))
;; When modifying the start time in HH:MM-HH:MM range, update
;; end time as well.
(setq extra (org-modify-ts-extra
extra ;; -HH:MM ...
;; Fake position in EXTRA to force changing hours
;; or minutes as needed.
(if (eq timestamp? 'hour)
2 ;; -H<H>:MM
5) ;; -HH:M<M>
n dm)))
(when (integerp timestamp?)
(setq extra (org-modify-ts-extra extra timestamp? n dm)))
(when (eq what 'calendar)
(let ((cal-date (org-get-date-from-calendar)))
(setcar (nthcdr 4 time0) (nth 0 cal-date)) ; month
(setcar (nthcdr 3 time0) (nth 1 cal-date)) ; day
(setcar (nthcdr 5 time0) (nth 2 cal-date)) ; year
(setcar time0 (or (car time0) 0))
(setcar (nthcdr 1 time0) (or (nth 1 time0) 0))
(setcar (nthcdr 2 time0) (or (nth 2 time0) 0))
(setq time (org-encode-time time0))))
;; Insert the new timestamp, and ensure point stays in the same
;; category as before (i.e. not after the last position in that
;; category).
(let ((pos (point)))
;; Stay before inserted string. `save-excursion' is of no use.
(setq org-last-changed-timestamp
(org-insert-timestamp time with-hm inactive nil nil extra))
(goto-char pos))
(save-match-data
(looking-at org-ts-regexp3)
(goto-char
(pcase origin-cat
;; `day' category ends before `hour' if any, or at the end
;; of the day name.
(`day (min (or (match-beginning 7) (1- (match-end 5))) origin))
(`hour (min (match-end 7) origin))
(`minute (min (1- (match-end 8)) origin))
((pred integerp) (min (1- (match-end 0)) origin))
;; Point was right after the timestamp. However, the
;; timestamp length might have changed, so refer to
;; (match-end 0) instead.
(`after (match-end 0))
;; `year' and `month' have both fixed size: point couldn't
;; have moved into another part.
(_ origin))))
;; Update clock if on a CLOCK line.
(org-clock-update-time-maybe)
;; Maybe adjust the closest clock in `org-clock-history'
(when org-clock-adjust-closest
(if (not (and (org-at-clock-log-p)
(< 1 (length (delq nil (mapcar 'marker-position
org-clock-history))))))
(message "No clock to adjust")
(cond ((save-excursion ; fix previous clock?
(re-search-backward org-ts-regexp0 nil t)
(looking-back (concat org-clock-string " \\[")
(line-beginning-position)))
(setq fixnext 1 clrgx (concat org-ts-regexp0 "\\] =>.*$")))
((save-excursion ; fix next clock?
(re-search-backward org-ts-regexp0 nil t)
(looking-at (concat org-ts-regexp0 "\\] =>")))
(setq fixnext -1 clrgx (concat org-clock-string " \\[" org-ts-regexp0))))
(save-window-excursion
;; Find closest clock to point, adjust the previous/next one in history
(let* ((p (save-excursion (org-back-to-heading t)))
(cl (mapcar (lambda(c) (abs (- (marker-position c) p))) org-clock-history))
(clfixnth
(+ fixnext (- (length cl) (or (length (member (apply 'min cl) cl)) 100))))
(clfixpos (unless (> 0 clfixnth) (nth clfixnth org-clock-history))))
(if (not clfixpos)
(message "No clock to adjust")
(save-excursion
(org-goto-marker-or-bmk clfixpos)
(org-fold-show-subtree)
(when (re-search-forward clrgx nil t)
(goto-char (match-beginning 1))
(let (org-clock-adjust-closest)
(org-timestamp-change n timestamp? updown))
(message "Clock adjusted in %s for heading: %s"
(file-name-nondirectory (buffer-file-name))
(org-get-heading t t)))))))))
;; Try to recenter the calendar window, if any.
(when (and org-calendar-follow-timestamp-change
(get-buffer-window calendar-buffer t)
(memq timestamp? '(day month year)))
(org-recenter-calendar (time-to-days time))))))
(defun org-modify-ts-extra (ts-string pos nincrements increment-step)
"Change the lead-time/repeat fields at POS in timestamp string TS-STRING.
POS is the position in the timestamp string to be changed.
NINCREMENTS is the number of increments/decrements.
INCREMENT-STEP is step used for a single increment when POS in on
minutes. Before incrementing minutes, they are rounded to
INCREMENT-STEP divisor."
(let (;; increment order for dwmy: d-1=d; d+1=w; w+1=m; m+1=y; y+1=y.
(idx '(("d" . 0) ("w" . 1) ("m" . 2) ("y" . 3) ("d" . -1) ("y" . 4)))
pos-match-group hour minute new rem)
(when (string-match "\\(-\\([012][0-9]\\):\\([0-5][0-9]\\)\\)?\\( +\\+\\([0-9]+\\)\\([dmwy]\\)\\)?\\( +-\\([0-9]+\\)\\([dmwy]\\)\\)?" ts-string)
(cond
((or (org-pos-in-match-range pos 2) ;; POS in end hours
(org-pos-in-match-range pos 3)) ;; POS in end minutes
(setq minute (string-to-number (match-string 3 ts-string))
hour (string-to-number (match-string 2 ts-string)))
(if (org-pos-in-match-range pos 2) ;; POS in end hours
;; INCREMENT-STEP is only applicable to MINUTE.
(setq hour (+ hour nincrements))
(setq nincrements (* increment-step nincrements))
(unless (= 0 (setq rem (% minute increment-step)))
;; Round the MINUTE to INCREMENT-STEP.
(setq minute (+ minute (if (> nincrements 0) (- rem) (- increment-step rem)))))
(setq minute (+ minute nincrements)))
(when (< minute 0) (setq minute (+ minute 60) hour (1- hour)))
(when (> minute 59) (setq minute (- minute 60) hour (1+ hour)))
(setq hour (mod hour 24))
(setq pos-match-group 1
new (format "-%02d:%02d" hour minute)))
((org-pos-in-match-range pos 6) ;; POS on "dmwy" repeater char.
(setq pos-match-group 6
new (car (rassoc (+ nincrements (cdr (assoc (match-string 6 ts-string) idx))) idx))))
((org-pos-in-match-range pos 5) ;; POS on X in "Xd" repeater.
(setq pos-match-group 5
;; Never drop below X=1.
new (format "%d" (max 1 (+ nincrements (string-to-number (match-string 5 ts-string)))))))
((org-pos-in-match-range pos 9) ;; POS on "dmwy" repeater in warning interval.
(setq pos-match-group 9
new (car (rassoc (+ nincrements (cdr (assoc (match-string 9 ts-string) idx))) idx))))
((org-pos-in-match-range pos 8) ;; POS on X in "Xd" in warning interval.
(setq pos-match-group 8
;; Never drop below X=0.
new (format "%d" (max 0 (+ nincrements (string-to-number (match-string 8 ts-string))))))))
(when pos-match-group
(setq ts-string (concat
(substring ts-string 0 (match-beginning pos-match-group))
new
(substring ts-string (match-end pos-match-group))))))
ts-string))
(defun org-recenter-calendar (d)
"If the calendar is visible, recenter it to date D."
(let ((cwin (get-buffer-window calendar-buffer t)))
(when cwin
(let ((calendar-move-hook nil))
(with-selected-window cwin
(calendar-goto-date
(if (listp d) d (calendar-gregorian-from-absolute d))))))))
(defun org-goto-calendar (&optional arg)
"Go to the Emacs calendar at the current date.
If there is a time stamp in the current line, go to that date.
A prefix ARG can be used to force the current date."
(interactive "P")
(let ((calendar-move-hook nil)
(calendar-view-holidays-initially-flag nil)
(calendar-view-diary-initially-flag nil)
diff)
(when (or (org-at-timestamp-p 'lax)
(org-match-line (concat ".*" org-ts-regexp)))
(let ((d1 (time-to-days nil))
(d2 (time-to-days (org-time-string-to-time (match-string 1)))))
(setq diff (- d2 d1))))
(calendar)
(calendar-goto-today)
(when (and diff (not arg)) (calendar-forward-day diff))))
(defun org-get-date-from-calendar ()
"Return a list (month day year) of date at point in calendar."
(with-current-buffer calendar-buffer
(save-match-data
(calendar-cursor-to-date))))
(defun org-date-from-calendar ()
"Insert time stamp corresponding to cursor date in *Calendar* buffer.
If there is already a time stamp at the cursor position, update it."
(interactive)
(if (org-at-timestamp-p 'lax)
(org-timestamp-change 0 'calendar)
(let ((cal-date (org-get-date-from-calendar)))
(org-insert-timestamp
(org-encode-time 0 0 0 (nth 1 cal-date) (car cal-date) (nth 2 cal-date))))))
(defcustom org-image-actual-width t
"When non-nil, use the actual width of images when inlining them.
When set to a number, use imagemagick (when available) to set the
image's width to this value.
When set to a number in a list, try to get the width from any
#+ATTR.* keyword if it matches a width specification like
#+ATTR_HTML: :width 300px
and fall back on that number if none is found.
When set to nil, first try to get the width from #+ATTR_ORG. If
that is not found, use the first #+ATTR_xxx :width specification.
If that is also not found, fall back on the original image width.
Finally, Org mode is quite flexible in the width specifications it
supports and intelligently interprets width specifications for other
backends when rendering an image in an org buffer. This behavior is
described presently.
1. A floating point value between 0 and 2 is interpreted as the
percentage of the text area that should be taken up by the image.
2. A number followed by a percent sign is divided by 100 and then
interpreted as a floating point value.
3. If a number is followed by other text, extract the number and
discard the remaining text. That number is then interpreted as a
floating-point value. For example,
#+ATTR_LATEX: :width 0.7\\linewidth
would be interpreted as 70% of the text width.
4. If t is provided the original image width is used. This is useful
when you want to specify a width for a backend, but still want to
use the original image width in the org buffer.
This requires Emacs >= 24.1, built with imagemagick support."
:group 'org-appearance
:version "24.4"
:package-version '(Org . "8.0")
:type '(choice
(const :tag "Use the image width" t)
(integer :tag "Use a number of pixels")
(list :tag "Use #+ATTR* or a number of pixels" (integer))
(const :tag "Use #+ATTR* or don't resize" nil)))
(defcustom org-image-max-width 'fill-column
"When non-nil, limit the displayed image width.
This setting only takes effect when `org-image-actual-width' is set to
t or when #+ATTR* is set to t.
Possible values:
- `fill-column' :: limit width to `fill-column'
- `window' :: limit width to window width
- integer :: limit width to number in pixels
- float :: limit width to that fraction of window width
- nil :: do not limit image width"
:group 'org-appearance
:package-version '(Org . "9.7")
:type '(choice
(const :tag "Do not limit image width" nil)
(const :tag "Limit to `fill-column'" fill-column)
(const :tag "Limit to window width" window)
(integer :tag "Limit to a number of pixels")
(float :tag "Limit to a fraction of window width")))
(defcustom org-agenda-inhibit-startup nil
"Inhibit startup when preparing agenda buffers.
When this variable is t, the initialization of the Org agenda
buffers is inhibited: e.g. the visibility state is not set, the
tables are not re-aligned, etc."
:type 'boolean
:version "24.3"
:group 'org-agenda)
(defcustom org-agenda-ignore-properties nil
"Avoid updating text properties when building the agenda.
Properties are used to prepare buffers for effort estimates,
appointments, statistics and subtree-local categories.
If you don't use these in the agenda, you can add them to this
list and agenda building will be a bit faster.
The value is a list, with symbol `stats'."
:type '(set :greedy t
(const stats))
:package-version '(Org . "9.7")
:group 'org-agenda)
;;;; Files
(defun org-save-all-org-buffers ()
"Save all Org buffers without user confirmation."
(interactive)
(message "Saving all Org buffers...")
(save-some-buffers t (lambda () (and (derived-mode-p 'org-mode) t)))
(when (featurep 'org-id) (org-id-locations-save))
(message "Saving all Org buffers... done"))
(defun org-revert-all-org-buffers ()
"Revert all Org buffers.
Prompt for confirmation when there are unsaved changes.
Be sure you know what you are doing before letting this function
overwrite your changes.
This function is useful in a setup where one tracks Org files
with a version control system, to revert on one machine after pulling
changes from another. I believe the procedure must be like this:
1. \\[org-save-all-org-buffers]
2. Pull changes from the other machine, resolve conflicts
3. \\[org-revert-all-org-buffers]"
(interactive)
(unless (yes-or-no-p "Revert all Org buffers from their files? ")
(user-error "Abort"))
(save-excursion
(save-window-excursion
(dolist (b (buffer-list))
(when (and (with-current-buffer b (derived-mode-p 'org-mode))
(with-current-buffer b buffer-file-name))
(pop-to-buffer-same-window b)
(revert-buffer t 'no-confirm)))
(when (and (featurep 'org-id) org-id-track-globally)
(org-id-locations-load)))))
;;;; Agenda files
;;;###autoload
(defun org-switchb (&optional arg)
"Switch between Org buffers.
With `\\[universal-argument]' prefix, restrict available buffers to files.
With `\\[universal-argument] \\[universal-argument]' \
prefix, restrict available buffers to agenda files."
(interactive "P")
(let ((blist (org-buffer-list
(cond ((equal arg '(4)) 'files)
((equal arg '(16)) 'agenda)))))
(pop-to-buffer-same-window
(completing-read "Org buffer: "
(mapcar #'list (mapcar #'buffer-name blist))
nil t))))
(defun org-agenda-files (&optional unrestricted archives)
"Get the list of agenda files.
Optional UNRESTRICTED means return the full list even if a restriction
is currently in place.
When ARCHIVES is t, include all archive files that are really being
used by the agenda files. If ARCHIVE is `ifmode', do this only if
`org-agenda-archives-mode' is t."
(let ((files
(cond
((and (not unrestricted) (get 'org-agenda-files 'org-restrict)))
((stringp org-agenda-files) (org-read-agenda-file-list))
((listp org-agenda-files) org-agenda-files)
(t (error "Invalid value of `org-agenda-files'")))))
(setq files (apply 'append
(mapcar (lambda (f)
(if (file-directory-p f)
(directory-files
f t org-agenda-file-regexp)
(list (expand-file-name f org-directory))))
files)))
(when org-agenda-skip-unavailable-files
(setq files (delq nil
(mapcar (lambda (file)
(and (file-readable-p file) file))
files))))
(when (or (eq archives t)
(and (eq archives 'ifmode) (eq org-agenda-archives-mode t)))
(setq files (org-add-archive-files files)))
(delete-dups files)))
(defun org-agenda-file-p (&optional file)
"Return non-nil, if FILE is an agenda file.
If FILE is omitted, use the file associated with the current
buffer."
(let ((fname (or file (buffer-file-name))))
(and fname
(member (file-truename fname)
(mapcar #'file-truename (org-agenda-files t))))))
(defun org-edit-agenda-file-list ()
"Edit the list of agenda files.
Depending on setup, this either uses customize to edit the variable
`org-agenda-files', or it visits the file that is holding the list. In the
latter case, the buffer is set up in a way that saving it automatically kills
the buffer and restores the previous window configuration."
(interactive)
(if (stringp org-agenda-files)
(let ((cw (current-window-configuration)))
(find-file org-agenda-files)
(setq-local org-window-configuration cw)
(add-hook 'after-save-hook
(lambda ()
(set-window-configuration
(prog1 org-window-configuration
(kill-buffer (current-buffer))))
(org-install-agenda-files-menu)
(message "New agenda file list installed"))
nil 'local)
(message "%s" (substitute-command-keys
"Edit list and finish with \\[save-buffer]")))
(customize-variable 'org-agenda-files)))
(defun org-store-new-agenda-file-list (list)
"Set new value for the agenda file list and save it correctly."
(if (stringp org-agenda-files)
(let ((fe (org-read-agenda-file-list t)) b u)
(while (setq b (find-buffer-visiting org-agenda-files))
(kill-buffer b))
(with-temp-file org-agenda-files
(insert
(mapconcat
(lambda (f) ;; Keep un-expanded entries.
(if (setq u (assoc f fe))
(cdr u)
f))
list "\n")
"\n")))
(let ((org-mode-hook nil) (org-inhibit-startup t)
(org-insert-mode-line-in-empty-file nil))
(setq org-agenda-files list)
(customize-save-variable 'org-agenda-files org-agenda-files))))
(defun org-read-agenda-file-list (&optional pair-with-expansion)
"Read the list of agenda files from a file.
If PAIR-WITH-EXPANSION is t return pairs with un-expanded
filenames, used by `org-store-new-agenda-file-list' to write back
un-expanded file names."
(when (file-directory-p org-agenda-files)
(error "`org-agenda-files' cannot be a single directory"))
(when (stringp org-agenda-files)
(with-temp-buffer
(insert-file-contents org-agenda-files)
(mapcar
(lambda (f)
(let ((e (expand-file-name (substitute-in-file-name f)
org-directory)))
(if pair-with-expansion
(cons e f)
e)))
(org-split-string (buffer-string) "[ \t\r\n]*?[\r\n][ \t\r\n]*")))))
;;;###autoload
(defun org-cycle-agenda-files ()
"Cycle through the files in `org-agenda-files'.
If the current buffer visits an agenda file, find the next one in the list.
If the current buffer does not, find the first agenda file."
(interactive)
(let* ((fs (or (org-agenda-files t)
(user-error "No agenda files")))
(files (copy-sequence fs))
(tcf (and buffer-file-name (file-truename buffer-file-name)))
file)
(when tcf
(while (and (setq file (pop files))
(not (equal (file-truename file) tcf)))))
(find-file (car (or files fs)))
(when (buffer-base-buffer) (pop-to-buffer-same-window (buffer-base-buffer)))))
(defun org-agenda-file-to-front (&optional to-end)
"Move/add the current file to the top of the agenda file list.
If the file is not present in the list, it is added to the front. If it is
present, it is moved there. With optional argument TO-END, add/move to the
end of the list."
(interactive "P")
(let ((org-agenda-skip-unavailable-files nil)
(file-alist (mapcar (lambda (x)
(cons (file-truename x) x))
(org-agenda-files t)))
(ctf (file-truename
(or buffer-file-name
(user-error "Please save the current buffer to a file"))))
x had)
(setq x (assoc ctf file-alist) had x)
(unless x (setq x (cons ctf (abbreviate-file-name buffer-file-name))))
(if to-end
(setq file-alist (append (delq x file-alist) (list x)))
(setq file-alist (cons x (delq x file-alist))))
(org-store-new-agenda-file-list (mapcar 'cdr file-alist))
(org-install-agenda-files-menu)
(message "File %s to %s of agenda file list"
(if had "moved" "added") (if to-end "end" "front"))))
(defun org-remove-file (&optional file)
"Remove current file from the list of files in variable `org-agenda-files'.
These are the files which are being checked for agenda entries.
Optional argument FILE means use this file instead of the current."
(interactive)
(let* ((org-agenda-skip-unavailable-files nil)
(file (or file buffer-file-name
(user-error "Current buffer does not visit a file")))
(true-file (file-truename file))
(afile (abbreviate-file-name file))
(files (delq nil (mapcar
(lambda (x)
(unless (equal true-file
(file-truename x))
x))
(org-agenda-files t)))))
(if (not (= (length files) (length (org-agenda-files t))))
(progn
(org-store-new-agenda-file-list files)
(org-install-agenda-files-menu)
(message "Removed from Org Agenda list: %s" afile))
(message "File was not in list: %s (not removed)" afile))))
(defun org-file-menu-entry (file)
(vector file (list 'find-file file) t))
(defun org-check-agenda-file (file)
"Make sure FILE exists. If not, ask user what to do."
(unless (file-exists-p file)
(message "Non-existent agenda file %s. [R]emove from list or [A]bort?"
(abbreviate-file-name file))
(let ((r (downcase (read-char-exclusive))))
(cond
((equal r ?r)
(org-remove-file file)
(throw 'nextfile t))
(t (user-error "Abort"))))))
(defun org-get-agenda-file-buffer (file)
"Get an agenda buffer visiting FILE.
If the buffer needs to be created, add it to the list of buffers
which might be released later."
(let ((buf (org-find-base-buffer-visiting file)))
(if buf
buf ; just return it
;; Make a new buffer and remember it
(setq buf (find-file-noselect file))
(when buf (push buf org-agenda-new-buffers))
buf)))
(defun org-release-buffers (blist)
"Release all buffers in list, asking the user for confirmation when needed.
When a buffer is unmodified, it is just killed. When modified, it is saved
\(if the user agrees) and then killed."
(let (file)
(dolist (buf blist)
(setq file (buffer-file-name buf))
(when (and (buffer-modified-p buf)
file
(y-or-n-p (format "Save file %s? " file)))
(with-current-buffer buf (save-buffer)))
(kill-buffer buf))))
(defun org-agenda-prepare-buffers (files)
"Create buffers for all agenda files, protect archived trees and comments."
(interactive)
(let ((inhibit-read-only t)
(org-inhibit-startup org-agenda-inhibit-startup)
;; Do not refresh list of agenda files in the menu when
;; opening every new file.
(org-agenda-file-menu-enabled nil))
(setq org-tag-alist-for-agenda nil
org-tag-groups-alist-for-agenda nil)
(dolist (file files)
(catch 'nextfile
(with-current-buffer
(if (bufferp file)
file
(org-check-agenda-file file)
(org-get-agenda-file-buffer file))
(org-with-wide-buffer
(org-set-regexps-and-options 'tags-only)
(or (memq 'stats org-agenda-ignore-properties)
(org-refresh-stats-properties))
(dolist (el org-todo-keywords-1)
(unless (member el org-todo-keywords-for-agenda)
(push el org-todo-keywords-for-agenda)))
(dolist (el org-done-keywords)
(unless (member el org-done-keywords-for-agenda)
(push el org-done-keywords-for-agenda)))
(setq org-todo-keyword-alist-for-agenda
(org--tag-add-to-alist
org-todo-key-alist
org-todo-keyword-alist-for-agenda))
(setq org-tag-alist-for-agenda
(org--tag-add-to-alist
org-current-tag-alist
org-tag-alist-for-agenda))
;; Merge current file's tag groups into global
;; `org-tag-groups-alist-for-agenda'.
(when org-group-tags
(dolist (alist org-tag-groups-alist)
(let ((old (assoc (car alist) org-tag-groups-alist-for-agenda)))
(if old
(setcdr old (org-uniquify (append (cdr old) (cdr alist))))
(push alist org-tag-groups-alist-for-agenda)))))))))
;; Refresh the menu once after loading all the agenda buffers.
(when org-agenda-file-menu-enabled
(org-install-agenda-files-menu))))
;;;; CDLaTeX minor mode
(defvar org-cdlatex-mode-map (make-sparse-keymap)
"Keymap for the minor `org-cdlatex-mode'.")
(org-defkey org-cdlatex-mode-map (kbd "_") #'org-cdlatex-underscore-caret)
(org-defkey org-cdlatex-mode-map (kbd "^") #'org-cdlatex-underscore-caret)
(org-defkey org-cdlatex-mode-map (kbd "`") #'cdlatex-math-symbol)
(org-defkey org-cdlatex-mode-map (kbd "'") #'org-cdlatex-math-modify)
(org-defkey org-cdlatex-mode-map (kbd "C-c {") #'org-cdlatex-environment-indent)
(defvar org-cdlatex-texmathp-advice-is-done nil
"Flag remembering if we have applied the advice to texmathp already.")
(define-minor-mode org-cdlatex-mode
"Toggle the minor `org-cdlatex-mode'.
This mode supports entering LaTeX environment and math in LaTeX fragments
in Org mode.
\\{org-cdlatex-mode-map}"
:lighter " OCDL"
(when org-cdlatex-mode
;; Try to load texmathp before cdlatex. Otherwise, cdlatex can
;; bind `cdlatex--texmathp' to `ignore', not using `texmathp' at
;; all.
(org-require-package 'texmathp "Auctex")
(org-require-package 'cdlatex)
(run-hooks 'cdlatex-mode-hook)
(cdlatex-compute-tables))
(unless org-cdlatex-texmathp-advice-is-done
(setq org-cdlatex-texmathp-advice-is-done t)
(advice-add 'texmathp :around #'org--math-p)))
(defun org--math-p (orig-fun &rest args)
"Return t inside math fragments or running `cdlatex-math-symbol'.
This function is intended to be an :around advice for `texmathp'.
If Org mode thinks that point is actually inside
an embedded LaTeX environment, return t when the environment is math
or let `texmathp' do its job otherwise.
`\\[org-cdlatex-mode-map]'"
(cond
((not (derived-mode-p 'org-mode)) (apply orig-fun args))
((eq this-command 'cdlatex-math-symbol)
(setq texmathp-why '("cdlatex-math-symbol in org-mode" . 0))
t)
(t
(let ((element (org-element-context)))
(when (org-inside-LaTeX-fragment-p element)
(pcase (substring-no-properties
(org-element-property :value element)
0 2)
((or "\\(" "\\[" (pred (string-match-p (rx string-start "$"))))
(setq texmathp-why '("Org mode embedded math" . 0))
t)
(_ (apply orig-fun args))))))))
(defun turn-on-org-cdlatex ()
"Unconditionally turn on `org-cdlatex-mode'."
(org-cdlatex-mode 1))
(defun org-try-cdlatex-tab ()
"Check if it makes sense to execute `cdlatex-tab', and do it if yes.
It makes sense to do so if `org-cdlatex-mode' is active and if the cursor is
- inside a LaTeX fragment, or
- after the first word in a line, where an abbreviation expansion could
insert a LaTeX environment."
(when org-cdlatex-mode
(cond
;; Before any word on the line: No expansion possible.
((save-excursion (skip-chars-backward " \t") (bolp)) nil)
;; Just after first word on the line: Expand it. Make sure it
;; cannot happen on headlines, though.
((save-excursion
(skip-chars-backward "a-zA-Z0-9*")
(skip-chars-backward " \t")
(and (bolp) (not (org-at-heading-p))))
(cdlatex-tab) t)
((org-inside-LaTeX-fragment-p) (cdlatex-tab) t))))
(defun org-cdlatex-underscore-caret (&optional _arg)
"Execute `cdlatex-sub-superscript' in LaTeX fragments.
Revert to the normal definition outside of these fragments."
(interactive "P")
(if (org-inside-LaTeX-fragment-p)
(call-interactively 'cdlatex-sub-superscript)
(let (org-cdlatex-mode)
(call-interactively (key-binding (vector last-input-event))))))
(defun org-cdlatex-math-modify (&optional _arg)
"Execute `cdlatex-math-modify' in LaTeX fragments.
Revert to the normal definition outside of these fragments."
(interactive "P")
(if (org-inside-LaTeX-fragment-p)
(call-interactively 'cdlatex-math-modify)
(let (org-cdlatex-mode)
(call-interactively (key-binding (vector last-input-event))))))
(defun org-cdlatex-environment-indent (&optional environment item)
"Execute `cdlatex-environment' and indent the inserted environment.
ENVIRONMENT and ITEM are passed to `cdlatex-environment'.
The inserted environment is indented to current indentation
unless point is at the beginning of the line, in which the
environment remains unintended."
(interactive)
;; cdlatex-environment always return nil. Therefore, capture output
;; first and determine if an environment was selected.
(let* ((beg (point-marker))
(end (copy-marker (point) t))
(inserted (progn
(ignore-errors (cdlatex-environment environment item))
(< beg end)))
;; Figure out how many lines to move forward after the
;; environment has been inserted.
(lines (when inserted
(save-excursion
(- (cl-loop while (< beg (point))
with x = 0
do (forward-line -1)
(cl-incf x)
finally return x)
(if (progn (goto-char beg)
(and (progn (skip-chars-forward " \t") (eolp))
(progn (skip-chars-backward " \t") (bolp))))
1 0)))))
(env (org-trim (delete-and-extract-region beg end))))
(when inserted
;; Get indentation of next line unless at column 0.
(let ((ind (if (bolp) 0
(save-excursion
(org-return t)
(prog1 (current-indentation)
(when (progn (skip-chars-forward " \t") (eolp))
(delete-region beg (point)))))))
(bol (progn (skip-chars-backward " \t") (bolp))))
;; Insert a newline before environment unless at column zero
;; to "escape" the current line. Insert a newline if
;; something is one the same line as \end{ENVIRONMENT}.
(insert
(concat (unless bol "\n") env
(when (and (skip-chars-forward " \t") (not (eolp))) "\n")))
(unless (zerop ind)
(save-excursion
(goto-char beg)
(while (< (point) end)
(unless (eolp) (indent-line-to ind))
(forward-line))))
(goto-char beg)
(forward-line lines)
(indent-line-to ind)))
(set-marker beg nil)
(set-marker end nil)))
;;;; LaTeX fragments
(defun org-inside-LaTeX-fragment-p (&optional element)
"Test if point is inside a LaTeX fragment or environment.
When optional argument ELEMENT is non-nil, it should be element/object
at point."
(org-element-type-p
(or element (org-element-context))
'(latex-fragment latex-environment)))
(defun org-inside-latex-macro-p ()
"Is point inside a LaTeX macro or its arguments?"
(save-match-data
(org-in-regexp
"\\\\[a-zA-Z]+\\*?\\(\\(\\[[^][\n{}]*\\]\\)\\|\\({[^{}\n]*}\\)\\)*")))
(defun org--make-preview-overlay (beg end image &optional imagetype)
"Build an overlay between BEG and END using IMAGE file.
Argument IMAGETYPE is the extension of the displayed image,
as a string. It defaults to \"png\"."
(let ((ov (make-overlay beg end))
(imagetype (or (intern imagetype) 'png)))
(overlay-put ov 'org-overlay-type 'org-latex-overlay)
(overlay-put ov 'evaporate t)
(overlay-put ov
'modification-hooks
(list (lambda (o _flag _beg _end &optional _l)
(delete-overlay o))))
(overlay-put ov
'display
(list 'image :type imagetype :file image :ascent 'center))))
(defun org-clear-latex-preview (&optional beg end)
"Remove all overlays with LaTeX fragment images in current buffer.
When optional arguments BEG and END are non-nil, remove all
overlays between them instead. Return a non-nil value when some
overlays were removed, nil otherwise."
(let ((overlays
(cl-remove-if-not
(lambda (o) (eq (overlay-get o 'org-overlay-type) 'org-latex-overlay))
(overlays-in (or beg (point-min)) (or end (point-max))))))
(mapc #'delete-overlay overlays)
overlays))
(defun org--latex-preview-region (beg end)
"Preview LaTeX fragments between BEG and END.
BEG and END are buffer positions."
(let ((file (buffer-file-name (buffer-base-buffer))))
(save-excursion
(org-format-latex
(concat org-preview-latex-image-directory "org-ltximg")
beg end
;; Emacs cannot overlay images from remote hosts. Create it in
;; `temporary-file-directory' instead.
(if (or (not file) (file-remote-p file))
temporary-file-directory
default-directory)
'overlays nil 'forbuffer org-preview-latex-default-process))))
(defun org-latex-preview (&optional arg)
"Toggle preview of the LaTeX fragment at point.
If the cursor is on a LaTeX fragment, create the image and
overlay it over the source code, if there is none. Remove it
otherwise. If there is no fragment at point, display images for
all fragments in the current section. With an active region,
display images for all fragments in the region.
With a `\\[universal-argument]' prefix argument ARG, clear images \
for all fragments
in the current section.
With a `\\[universal-argument] \\[universal-argument]' prefix \
argument ARG, display image for all
fragments in the buffer.
With a `\\[universal-argument] \\[universal-argument] \
\\[universal-argument]' prefix argument ARG, clear image for all
fragments in the buffer."
(interactive "P")
(cond
((not (display-graphic-p)) nil)
((and untrusted-content (not org--latex-preview-when-risky)) nil)
;; Clear whole buffer.
((equal arg '(64))
(org-clear-latex-preview (point-min) (point-max))
(message "LaTeX previews removed from buffer"))
;; Preview whole buffer.
((equal arg '(16))
(message "Creating LaTeX previews in buffer...")
(org--latex-preview-region (point-min) (point-max))
(message "Creating LaTeX previews in buffer... done."))
;; Clear current section.
((equal arg '(4))
(org-clear-latex-preview
(if (use-region-p)
(region-beginning)
(if (org-before-first-heading-p) (point-min)
(save-excursion
(org-with-limited-levels (org-back-to-heading t) (point)))))
(if (use-region-p)
(region-end)
(org-with-limited-levels (org-entry-end-position)))))
((use-region-p)
(message "Creating LaTeX previews in region...")
(org--latex-preview-region (region-beginning) (region-end))
(message "Creating LaTeX previews in region... done."))
;; Toggle preview on LaTeX code at point.
((let ((datum (org-element-context)))
(and (org-element-type-p datum '(latex-environment latex-fragment))
(let ((beg (org-element-begin datum))
(end (org-element-end datum)))
(if (org-clear-latex-preview beg end)
(message "LaTeX preview removed")
(message "Creating LaTeX preview...")
(org--latex-preview-region beg end)
(message "Creating LaTeX preview... done."))
t))))
;; Preview current section.
(t
(let ((beg (if (org-before-first-heading-p) (point-min)
(save-excursion
(org-with-limited-levels (org-back-to-heading t) (point)))))
(end (org-with-limited-levels (org-entry-end-position))))
(message "Creating LaTeX previews in section...")
(org--latex-preview-region beg end)
(message "Creating LaTeX previews in section... done.")))))
(defun org-format-latex
(prefix &optional beg end dir overlays msg forbuffer processing-type)
"Replace LaTeX fragments with links to an image.
The function takes care of creating the replacement image.
Only consider fragments between BEG and END when those are
provided.
When optional argument OVERLAYS is non-nil, display the image on
top of the fragment instead of replacing it.
PROCESSING-TYPE is the conversion method to use, as a symbol.
Some of the options can be changed using the variable
`org-format-latex-options', which see."
(when (and overlays (fboundp 'clear-image-cache)) (clear-image-cache))
(unless (eq processing-type 'verbatim)
(let* ((math-regexp "\\$\\|\\\\[([]\\|^[ \t]*\\\\begin{[A-Za-z0-9*]+}")
(cnt 0)
checkdir-flag)
(goto-char (or beg (point-min)))
;; FIXME: `overlay-recenter' is not needed (and has no effect)
;; since Emacs 29.
;; Optimize overlay creation: (info "(elisp) Managing Overlays").
(when (and overlays (memq processing-type '(dvipng imagemagick)))
(overlay-recenter (or end (point-max))))
(while (re-search-forward math-regexp end t)
(unless (and overlays
(eq (get-char-property (point) 'org-overlay-type)
'org-latex-overlay))
(let* ((context (org-element-context))
(type (org-element-type context)))
(when (memq type '(latex-environment latex-fragment))
(let ((block-type (eq type 'latex-environment))
(value (org-element-property :value context))
(beg (org-element-begin context))
(end (save-excursion
(goto-char (org-element-end context))
(skip-chars-backward " \r\t\n")
(point))))
(cond
((eq processing-type 'mathjax)
;; Prepare for MathJax processing.
(if (not (string-match "\\`\\$\\$?" value))
(goto-char end)
(delete-region beg end)
(if (string= (match-string 0 value) "$$")
(insert "\\[" (substring value 2 -2) "\\]")
(insert "\\(" (substring value 1 -1) "\\)"))))
((eq processing-type 'html)
(goto-char beg)
(delete-region beg end)
(insert (org-format-latex-as-html value)))
((assq processing-type org-preview-latex-process-alist)
;; Process to an image.
(cl-incf cnt)
(goto-char beg)
(let* ((processing-info
(cdr (assq processing-type org-preview-latex-process-alist)))
(face (face-at-point))
;; Get the colors from the face at point.
(fg
(let ((color (plist-get org-format-latex-options
:foreground)))
(if forbuffer
(cond
((eq color 'auto)
(face-attribute face :foreground nil 'default))
((eq color 'default)
(face-attribute 'default :foreground nil))
(t color))
color)))
(bg
(let ((color (plist-get org-format-latex-options
:background)))
(if forbuffer
(cond
((eq color 'auto)
(face-attribute face :background nil 'default))
((eq color 'default)
(face-attribute 'default :background nil))
(t color))
color)))
(hash (sha1 (prin1-to-string
(list org-format-latex-header
org-latex-default-packages-alist
org-latex-packages-alist
org-format-latex-options
forbuffer value fg bg))))
(imagetype (or (plist-get processing-info :image-output-type) "png"))
(absprefix (expand-file-name prefix dir))
(linkfile (format "%s_%s.%s" prefix hash imagetype))
(movefile (format "%s_%s.%s" absprefix hash imagetype))
(sep (and block-type "\n\n"))
(link (concat sep "[[file:" linkfile "]]" sep))
(options
(org-combine-plists
org-format-latex-options
`(:foreground ,fg :background ,bg))))
(when msg (message msg cnt))
(unless checkdir-flag ; Ensure the directory exists.
(setq checkdir-flag t)
(let ((todir (file-name-directory absprefix)))
(unless (file-directory-p todir)
(make-directory todir t))))
(unless (file-exists-p movefile)
(org-create-formula-image
value movefile options forbuffer processing-type))
(org-place-formula-image link block-type beg end value overlays movefile imagetype)))
((eq processing-type 'mathml)
;; Process to MathML.
(unless (org-format-latex-mathml-available-p)
(user-error "LaTeX to MathML converter not configured"))
(cl-incf cnt)
(when msg (message msg cnt))
(goto-char beg)
(delete-region beg end)
(insert (org-format-latex-as-mathml
value block-type prefix dir)))
(t
(error "Unknown conversion process %s for LaTeX fragments"
processing-type)))))))))))
(defun org-place-formula-image (link block-type beg end value overlays movefile imagetype)
"Place an overlay from BEG to END showing MOVEFILE.
The overlay will be above BEG if OVERLAYS is non-nil."
(if overlays
(progn
(dolist (o (overlays-in beg end))
(when (eq (overlay-get o 'org-overlay-type)
'org-latex-overlay)
(delete-overlay o)))
(org--make-preview-overlay beg end movefile imagetype)
(goto-char end))
(delete-region beg end)
(insert
(org-add-props link
(list 'org-latex-src
(replace-regexp-in-string "\"" "" value)
'org-latex-src-embed-type
(if block-type 'paragraph 'character))))))
(defun org-create-math-formula (latex-frag &optional mathml-file)
"Convert LATEX-FRAG to MathML and store it in MATHML-FILE.
Use `org-latex-to-mathml-convert-command'. If the conversion is
successful, return the portion between \"<math...> </math>\"
elements otherwise return nil. When MATHML-FILE is specified,
write the results in to that file. When invoked as an
interactive command, prompt for LATEX-FRAG, with initial value
set to the current active region and echo the results for user
inspection."
(interactive (list (let ((frag (when (org-region-active-p)
(buffer-substring-no-properties
(region-beginning) (region-end)))))
(read-string "LaTeX Fragment: " frag nil frag))))
(unless latex-frag (user-error "Invalid LaTeX fragment"))
(let* ((tmp-in-file
(let ((file (file-relative-name
(make-temp-name (expand-file-name "ltxmathml-in")))))
(write-region latex-frag nil file)
file))
(tmp-out-file (file-relative-name
(make-temp-name (expand-file-name "ltxmathml-out"))))
(cmd (format-spec
org-latex-to-mathml-convert-command
`((?j . ,(and org-latex-to-mathml-jar-file
(shell-quote-argument
(expand-file-name
org-latex-to-mathml-jar-file))))
(?I . ,(shell-quote-argument tmp-in-file))
(?i . ,(shell-quote-argument latex-frag))
(?o . ,(shell-quote-argument tmp-out-file)))))
mathml shell-command-output)
(when (called-interactively-p 'any)
(unless (org-format-latex-mathml-available-p)
(user-error "LaTeX to MathML converter not configured")))
(message "Running %s" cmd)
(setq shell-command-output (shell-command-to-string cmd))
(setq mathml
(when (file-readable-p tmp-out-file)
(with-temp-buffer
(insert-file-contents tmp-out-file)
(goto-char (point-min))
(when (re-search-forward
(format "<math[^>]*?%s[^>]*?>\\(.\\|\n\\)*</math>"
(regexp-quote
"xmlns=\"http://www.w3.org/1998/Math/MathML\""))
nil t)
(match-string 0)))))
(cond
(mathml
(setq mathml
(concat "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" mathml))
(when mathml-file
(write-region mathml nil mathml-file))
(when (called-interactively-p 'any)
(message mathml)))
((warn "LaTeX to MathML conversion failed")
(message shell-command-output)))
(delete-file tmp-in-file)
(when (file-exists-p tmp-out-file)
(delete-file tmp-out-file))
mathml))
(defun org-format-latex-as-mathml (latex-frag latex-frag-type
prefix &optional dir)
"Use `org-create-math-formula' but check local cache first."
(let* ((absprefix (expand-file-name prefix dir))
(print-length nil) (print-level nil)
(formula-id (concat
"formula-"
(sha1
(prin1-to-string
(list latex-frag
org-latex-to-mathml-convert-command)))))
(formula-cache (format "%s-%s.mathml" absprefix formula-id))
(formula-cache-dir (file-name-directory formula-cache)))
(unless (file-directory-p formula-cache-dir)
(make-directory formula-cache-dir t))
(unless (file-exists-p formula-cache)
(org-create-math-formula latex-frag formula-cache))
(if (file-exists-p formula-cache)
;; Successful conversion. Return the link to MathML file.
(org-add-props
(format "[[file:%s]]" (file-relative-name formula-cache dir))
(list 'org-latex-src (replace-regexp-in-string "\"" "" latex-frag)
'org-latex-src-embed-type (if latex-frag-type
'paragraph 'character)))
;; Failed conversion. Return the LaTeX fragment verbatim
latex-frag)))
(defun org-format-latex-as-html (latex-fragment)
"Convert LATEX-FRAGMENT to HTML.
This uses `org-latex-to-html-convert-command', which see."
(let ((cmd (format-spec org-latex-to-html-convert-command
`((?i . ,(shell-quote-argument latex-fragment))))))
(message "Running %s" cmd)
(shell-command-to-string cmd)))
(defun org--get-display-dpi ()
"Get the DPI of the display.
The function assumes that the display has the same pixel width in
the horizontal and vertical directions."
(if (display-graphic-p)
(round (/ (display-pixel-height)
(/ (display-mm-height) 25.4)))
(error "Attempt to calculate the dpi of a non-graphic display")))
(defun org-create-formula-image
(string tofile options buffer &optional processing-type)
"Create an image from LaTeX source using external processes.
The LaTeX STRING is saved to a temporary LaTeX file, then
converted to an image file by process PROCESSING-TYPE defined in
`org-preview-latex-process-alist'. A nil value defaults to
`org-preview-latex-default-process'.
The generated image file is eventually moved to TOFILE.
The OPTIONS argument controls the size, foreground color and
background color of the generated image.
When BUFFER non-nil, this function is used for LaTeX previewing.
Otherwise, it is used to deal with LaTeX snippets showed in
a HTML file."
(let* ((processing-type (or processing-type
org-preview-latex-default-process))
(processing-info
(cdr (assq processing-type org-preview-latex-process-alist)))
(programs (plist-get processing-info :programs))
(error-message (or (plist-get processing-info :message) ""))
(image-input-type (plist-get processing-info :image-input-type))
(image-output-type (plist-get processing-info :image-output-type))
(post-clean (or (plist-get processing-info :post-clean)
'(".dvi" ".xdv" ".pdf" ".tex" ".aux" ".log"
".svg" ".png" ".jpg" ".jpeg" ".out")))
(latex-header
(or (plist-get processing-info :latex-header)
(org-latex-make-preamble
(org-export-get-environment (org-export-get-backend 'latex))
org-format-latex-header
'snippet)))
(latex-compiler (plist-get processing-info :latex-compiler))
(tmpdir temporary-file-directory)
(texfilebase (make-temp-name
(expand-file-name "orgtex" tmpdir)))
(texfile (concat texfilebase ".tex"))
(image-size-adjust (or (plist-get processing-info :image-size-adjust)
'(1.0 . 1.0)))
(scale (* (if buffer (car image-size-adjust) (cdr image-size-adjust))
(or (plist-get options (if buffer :scale :html-scale)) 1.0)))
(dpi (* scale (if (and buffer (display-graphic-p)) (org--get-display-dpi) 140.0)))
(fg (or (plist-get options (if buffer :foreground :html-foreground))
"Black"))
(bg (or (plist-get options (if buffer :background :html-background))
"Transparent"))
(image-converter
(or (and (string= bg "Transparent")
(plist-get processing-info :transparent-image-converter))
(plist-get processing-info :image-converter)))
(log-buf (get-buffer-create "*Org Preview LaTeX Output*"))
(resize-mini-windows nil)) ;Fix Emacs flicker when creating image.
(dolist (program programs)
(org-check-external-command program error-message))
(if (eq fg 'default)
(setq fg (org-latex-color :foreground))
(setq fg (org-latex-color-format fg)))
(setq bg (cond
((eq bg 'default) (org-latex-color :background))
((string= bg "Transparent") nil)
(t (org-latex-color-format bg))))
;; Remove TeX \par at end of snippet to avoid trailing space.
(if (string-suffix-p string "\n")
(aset string (1- (length string)) ?%)
(setq string (concat string "%")))
(with-temp-file texfile
(insert latex-header)
(insert "\n\\begin{document}\n"
"\\definecolor{fg}{rgb}{" fg "}%\n"
(if bg
(concat "\\definecolor{bg}{rgb}{" bg "}%\n"
"\n\\pagecolor{bg}%\n")
"")
"\n{\\color{fg}\n"
string
"\n}\n"
"\n\\end{document}\n"))
(let* ((err-msg (format "Please adjust `%s' part of \
`org-preview-latex-process-alist'."
processing-type))
(image-input-file
(org-compile-file
texfile latex-compiler image-input-type err-msg log-buf))
(image-output-file
(org-compile-file
image-input-file image-converter image-output-type err-msg log-buf
`((?D . ,(shell-quote-argument (format "%s" dpi)))
(?S . ,(shell-quote-argument (format "%s" (/ dpi 140.0))))))))
(copy-file image-output-file tofile 'replace)
(dolist (e post-clean)
(when (file-exists-p (concat texfilebase e))
(delete-file (concat texfilebase e))))
image-output-file)))
(defun org-splice-latex-header (tpl def-pkg pkg snippets-p &optional extra)
"Fill a LaTeX header template TPL.
In the template, the following place holders will be recognized:
[DEFAULT-PACKAGES] \\usepackage statements for DEF-PKG
[NO-DEFAULT-PACKAGES] do not include DEF-PKG
[PACKAGES] \\usepackage statements for PKG
[NO-PACKAGES] do not include PKG
[EXTRA] the string EXTRA
[NO-EXTRA] do not include EXTRA
For backward compatibility, if both the positive and the negative place
holder is missing, the positive one (without the \"NO-\") will be
assumed to be present at the end of the template.
DEF-PKG and PKG are assumed to be alists of options/packagename lists.
EXTRA is a string.
SNIPPETS-P indicates if this is run to create snippet images for HTML."
(let (rpl (end ""))
(if (string-match "^[ \t]*\\[\\(NO-\\)?DEFAULT-PACKAGES\\][ \t]*\n?" tpl)
(setq rpl (if (or (match-end 1) (not def-pkg))
"" (org-latex-packages-to-string def-pkg snippets-p t))
tpl (replace-match rpl t t tpl))
(when def-pkg (setq end (org-latex-packages-to-string def-pkg snippets-p))))
(if (string-match "\\[\\(NO-\\)?PACKAGES\\][ \t]*\n?" tpl)
(setq rpl (if (or (match-end 1) (not pkg))
"" (org-latex-packages-to-string pkg snippets-p t))
tpl (replace-match rpl t t tpl))
(when pkg (setq end
(concat end "\n"
(org-latex-packages-to-string pkg snippets-p)))))
(if (string-match "\\[\\(NO-\\)?EXTRA\\][ \t]*\n?" tpl)
(setq rpl (if (or (match-end 1) (not extra))
"" (concat extra "\n"))
tpl (replace-match rpl t t tpl))
(when (and extra (string-match "\\S-" extra))
(setq end (concat end "\n" extra))))
(if (string-match "\\S-" end)
(concat tpl "\n" end)
tpl)))
(defun org-latex-packages-to-string (pkg &optional snippets-p newline)
"Turn an alist of packages into a string with the \\usepackage macros."
(setq pkg (mapconcat (lambda(p)
(cond
((stringp p) p)
((and snippets-p (>= (length p) 3) (not (nth 2 p)))
(format "%% Package %s omitted" (cadr p)))
((equal "" (car p))
(format "\\usepackage{%s}" (cadr p)))
(t
(format "\\usepackage[%s]{%s}"
(car p) (cadr p)))))
pkg
"\n"))
(if newline (concat pkg "\n") pkg))
(defun org-dvipng-color (attr)
"Return a RGB color specification for dvipng."
(org-dvipng-color-format (face-attribute 'default attr nil)))
(defun org-dvipng-color-format (color-name)
"Convert COLOR-NAME to a RGB color value for dvipng."
(apply #'format "rgb %s %s %s"
(mapcar 'org-normalize-color
(color-values color-name))))
(defun org-latex-color (attr)
"Return a RGB color for the LaTeX color package."
(org-latex-color-format (face-attribute 'default attr nil)))
(defun org-latex-color-format (color-name)
"Convert COLOR-NAME to a RGB color value."
(apply #'format "%s,%s,%s"
(mapcar 'org-normalize-color
(color-values color-name))))
(defun org-normalize-color (value)
"Return string to be used as color value for an RGB component."
(format "%g" (/ value 65535.0)))
;; Image display
(defvar-local org-inline-image-overlays nil)
;; Preserve when switching modes or when restarting Org.
;; If we clear the overlay list and later enable Or mode, the existing
;; image overlays will never be cleared by `org-toggle-inline-images'.
(put 'org-inline-image-overlays 'permanent-local t)
(defun org--inline-image-overlays (&optional beg end)
"Return image overlays between BEG and END."
(let* ((beg (or beg (point-min)))
(end (or end (point-max)))
(overlays (overlays-in beg end))
result)
(dolist (ov overlays result)
(when (memq ov org-inline-image-overlays)
(push ov result)))))
(defun org-toggle-inline-images (&optional include-linked beg end)
"Toggle the display of inline images.
INCLUDE-LINKED is passed to `org-display-inline-images'."
(interactive "P")
(if (org--inline-image-overlays beg end)
(progn
(org-remove-inline-images beg end)
(when (called-interactively-p 'interactive)
(message "Inline image display turned off")))
(org-display-inline-images include-linked nil beg end)
(when (called-interactively-p 'interactive)
(let ((new (org--inline-image-overlays beg end)))
(message (if new
(format "%d images displayed inline"
(length new))
"No images to display inline"))))))
(defun org-redisplay-inline-images ()
"Assure display of inline images and refresh them."
(interactive)
(org-toggle-inline-images)
(unless org-inline-image-overlays
(org-toggle-inline-images)))
;; For without-x builds.
(declare-function image-flush "image" (spec &optional frame))
(defcustom org-display-remote-inline-images 'skip
"How to display remote inline images.
Possible values of this option are:
skip Don't display remote images.
download Always download and display remote images.
t
cache Display remote images, and open them in separate buffers
for caching. Silently update the image buffer when a file
change is detected."
:group 'org-appearance
:package-version '(Org . "9.7")
:type '(choice
(const :tag "Ignore remote images" skip)
(const :tag "Always display remote images" download)
(const :tag "Display and silently update remote images" cache))
:safe #'symbolp)
(defcustom org-image-align 'left
"How to align images previewed using `org-display-inline-images'.
Only stand-alone image links are affected by this setting. These
are links without surrounding text.
Possible values of this option are:
left Insert image at specified position.
center Center image previews.
right Right-align image previews."
:group 'org-appearance
:package-version '(Org . "9.7")
:type '(choice
(const :tag "Left align (or don\\='t align) image previews" left)
(const :tag "Center image previews" center)
(const :tag "Right align image previews" right))
:safe #'symbolp)
(defun org--create-inline-image (file width)
"Create image located at FILE, or return nil.
WIDTH is the width of the image. The image may not be created
according to the value of `org-display-remote-inline-images'."
(let* ((remote? (file-remote-p file))
(file-or-data
(pcase org-display-remote-inline-images
((guard (not remote?)) file)
(`download (with-temp-buffer
(set-buffer-multibyte nil)
(insert-file-contents-literally file)
(buffer-string)))
((or `cache `t)
(let ((revert-without-query '(".")))
(with-current-buffer (find-file-noselect file)
(buffer-string))))
(`skip nil)
(other
(message "Invalid value of `org-display-remote-inline-images': %S"
other)
nil))))
(when file-or-data
(create-image file-or-data
(and (image-type-available-p 'imagemagick)
width
'imagemagick)
remote?
:width width
:max-width
(pcase org-image-max-width
(`fill-column (* fill-column (frame-char-width (selected-frame))))
(`window (window-width nil t))
((pred integerp) org-image-max-width)
((pred floatp) (floor (* org-image-max-width (window-width nil t))))
(`nil nil)
(_ (error "Unsupported value of `org-image-max-width': %S"
org-image-max-width)))
:scale 1))))
(defun org-display-inline-images (&optional include-linked refresh beg end)
"Display inline images.
An inline image is a link which follows either of these
conventions:
1. Its path is a file with an extension matching return value
from `image-file-name-regexp' and it has no contents.
2. Its description consists in a single link of the previous
type. In this case, that link must be a well-formed plain
or angle link, i.e., it must have an explicit \"file\" or
\"attachment\" type.
Equip each image with the key-map `image-map'.
When optional argument INCLUDE-LINKED is non-nil, also links with
a text description part will be inlined. This can be nice for
a quick look at those images, but it does not reflect what
exported files will look like.
When optional argument REFRESH is non-nil, refresh existing
images between BEG and END. This will create new image displays
only if necessary.
BEG and END define the considered part. They default to the
buffer boundaries with possible narrowing."
(interactive "P")
(when (display-graphic-p)
(when refresh
(org-remove-inline-images beg end)
(when (fboundp 'clear-image-cache) (clear-image-cache)))
(let ((end (or end (point-max))))
(org-with-point-at (or beg (point-min))
(let* ((case-fold-search t)
(file-extension-re (image-file-name-regexp))
(link-abbrevs (mapcar #'car
(append org-link-abbrev-alist-local
org-link-abbrev-alist)))
;; Check absolute, relative file names and explicit
;; "file:" links. Also check link abbreviations since
;; some might expand to "file" links.
(file-types-re
(format "\\[\\[\\(?:file%s:\\|attachment:\\|[./~]\\)\\|\\]\\[\\(<?\\(?:file\\|attachment\\):\\)"
(if (not link-abbrevs) ""
(concat "\\|" (regexp-opt link-abbrevs))))))
(while (re-search-forward file-types-re end t)
(let* ((link (org-element-lineage
(save-match-data (org-element-context))
'link t))
(linktype (org-element-property :type link))
(inner-start (match-beginning 1))
(path
(cond
;; No link at point; no inline image.
((not link) nil)
;; File link without a description. Also handle
;; INCLUDE-LINKED here since it should have
;; precedence over the next case. I.e., if link
;; contains filenames in both the path and the
;; description, prioritize the path only when
;; INCLUDE-LINKED is non-nil.
((or (not (org-element-contents-begin link))
include-linked)
(and (or (equal "file" linktype)
(equal "attachment" linktype))
(org-element-property :path link)))
;; Link with a description. Check if description
;; is a filename. Even if Org doesn't have syntax
;; for those -- clickable image -- constructs, fake
;; them, as in `org-export-insert-image-links'.
((not inner-start) nil)
(t
(org-with-point-at inner-start
(and (looking-at
(if (char-equal ?< (char-after inner-start))
org-link-angle-re
org-link-plain-re))
;; File name must fill the whole
;; description.
(= (org-element-contents-end link)
(match-end 0))
(progn
(setq linktype (match-string 1))
(match-string 2))))))))
(when (and path (string-match-p file-extension-re path))
(let ((file (if (equal "attachment" linktype)
(progn
(require 'org-attach)
(ignore-errors (org-attach-expand path)))
(expand-file-name path))))
;; Expand environment variables.
(when file (setq file (substitute-in-file-name file)))
(when (and file (file-exists-p file))
(let ((width (org-display-inline-image--width link))
(align (org-image--align link))
(old (get-char-property-and-overlay
(org-element-begin link)
'org-image-overlay)))
(if (and (car-safe old) refresh)
(image-flush (overlay-get (cdr old) 'display))
(let ((image (org--create-inline-image file width)))
(when image
(let ((ov (make-overlay
(org-element-begin link)
(progn
(goto-char
(org-element-end link))
(unless (eolp) (skip-chars-backward " \t"))
(point)))))
;; See bug#59902. We cannot rely
;; on Emacs to update image if the file
;; has changed.
(image-flush image)
(overlay-put ov 'display image)
(overlay-put ov 'face 'default)
(overlay-put ov 'org-image-overlay t)
(overlay-put
ov 'modification-hooks
(list 'org-display-inline-remove-overlay))
(when (boundp 'image-map)
(overlay-put ov 'keymap image-map))
(when align
(overlay-put
ov 'before-string
(propertize
" " 'face 'default
'display
(pcase align
("center" `(space :align-to (- center (0.5 . ,image))))
("right" `(space :align-to (- right ,image)))))))
(push ov org-inline-image-overlays))))))))))))))))
(declare-function org-export-read-attribute "ox"
(attribute element &optional property))
(defvar visual-fill-column-width) ; Silence compiler warning
(defun org-display-inline-image--width (link)
"Determine the display width of the image LINK, in pixels.
- When `org-image-actual-width' is t, the image's pixel width is used.
- When `org-image-actual-width' is a number, that value will is used.
- When `org-image-actual-width' is nil or a list, :width attribute of
#+attr_org or the first #+attr_... (if it exists) is used to set the
image width. A width of X% is divided by 100. If the value is a
float between 0 and 2, it interpreted as that proportion of the text
width in the buffer.
If no :width attribute is given and `org-image-actual-width' is a
list with a number as the car, then that number is used as the
default value."
;; Apply `org-image-actual-width' specifications.
;; Support subtree-level property "ORG-IMAGE-ACTUAL-WIDTH" specified
;; width.
(let ((org-image-actual-width (org-property-or-variable-value 'org-image-actual-width)))
(cond
((eq org-image-actual-width t) nil)
((listp org-image-actual-width)
(require 'ox)
(let* ((par (org-element-lineage link 'paragraph))
;; Try to find an attribute providing a :width.
;; #+ATTR_ORG: :width ...
(attr-width (org-export-read-attribute :attr_org par :width))
(width-unreadable?
(lambda (value)
(or (not (stringp value))
(unless (string= value "t")
(or (not (string-match-p
(rx bos (opt "+") (opt ".") (in "0-9"))
value))
(let ((number (string-to-number value)))
(and (floatp number) (not (<= 0.0 number 2.0)))))))))
;; #+ATTR_BACKEND: :width ...
(attr-other
(catch :found
(org-element-properties-map
(lambda (prop _)
(when (and
(not (eq prop :attr_org))
(string-match-p "^:attr_" (symbol-name prop))
(not (funcall width-unreadable? (org-export-read-attribute prop par :width))))
(throw :found prop)))
par)))
(attr-width
(if (not (funcall width-unreadable? attr-width))
attr-width
;; When #+attr_org: does not have readable :width
(and attr-other
(org-export-read-attribute attr-other par :width))))
(width
(cond
;; Treat :width t as if `org-image-actual-width' were t.
((string= attr-width "t") nil)
;; Fallback to `org-image-actual-width' if no interprable width is given.
((funcall width-unreadable? attr-width)
(car org-image-actual-width))
;; Convert numeric widths to numbers, converting percentages.
((string-match-p "\\`[[+]?[0-9.]+%" attr-width)
(/ (string-to-number attr-width) 100.0))
(t (string-to-number attr-width)))))
(if (and (floatp width) (<= 0.0 width 2.0))
;; A float in [0,2] should be interpereted as this portion of
;; the text width in the window. This works well with cases like
;; #+attr_latex: :width 0.X\{line,page,column,etc.}width,
;; as the "0.X" is pulled out as a float. We use 2 as the upper
;; bound as cases such as 1.2\linewidth are feasible.
(round (* width
(window-pixel-width)
(/ (or (and (bound-and-true-p visual-fill-column-mode)
(or visual-fill-column-width auto-fill-function))
(when auto-fill-function fill-column)
(- (window-text-width) (line-number-display-width)))
(float (window-total-width)))))
width)))
((numberp org-image-actual-width)
org-image-actual-width)
(t nil))))
(defun org-image--align (link)
"Determine the alignment of the image LINK.
LINK is a link object.
In decreasing order of priority, this is controlled:
- Per image by the value of `:center' or `:align' in the
affiliated keyword `#+attr_org'.
- By the `#+attr_html' or `#+attr_latex` keywords with valid
`:center' or `:align' values.
- Globally by the user option `org-image-align'.
The result is either nil or one of the strings \"left\",
\"center\" or \"right\".
\"center\" will cause the image preview to be centered, \"right\"
will cause it to be right-aligned. A value of \"left\" or nil
implies no special alignment."
(let ((par (org-element-lineage link 'paragraph)))
;; Only align when image is not surrounded by paragraph text:
(when (and par ; when image is not in paragraph, but in table/headline/etc, do not align
(= (org-element-begin link)
(save-excursion
(goto-char (org-element-contents-begin par))
(skip-chars-forward "\t ")
(point))) ;account for leading space
;before link
(<= (- (org-element-contents-end par)
(org-element-end link))
1)) ;account for trailing newline
;at end of paragraph
(save-match-data
;; Look for a valid ":center t" or ":align left|center|right"
;; attribute.
;;
;; An attr_org keyword has the highest priority, with
;; any attr.* next. Choosing between these is
;; unspecified.
(let ((center-re ":\\(center\\)[[:space:]]+t\\b")
(align-re ":align[[:space:]]+\\(left\\|center\\|right\\)\\b")
attr-align)
(catch 'exit
(org-element-properties-mapc
(lambda (propname propval)
(when (and propval
(string-match-p ":attr.*" (symbol-name propname)))
(setq propval (car-safe propval))
(when (or (string-match center-re propval)
(string-match align-re propval))
(setq attr-align (match-string 1 propval))
(when (eq propname :attr_org)
(throw 'exit t)))))
par))
(if attr-align
(when (member attr-align '("center" "right")) attr-align)
;; No image-specific keyword, check global alignment property
(when (memq org-image-align '(center right))
(symbol-name org-image-align))))))))
(defun org-display-inline-remove-overlay (ov after _beg _end &optional _len)
"Remove inline-display overlay if a corresponding region is modified."
(when (and ov after)
(setq org-inline-image-overlays (delete ov org-inline-image-overlays))
;; Clear image from cache to avoid image not updating upon
;; changing on disk. See Emacs bug#59902.
(when (overlay-get ov 'org-image-overlay)
(image-flush (overlay-get ov 'display)))
(delete-overlay ov)))
(defun org-remove-inline-images (&optional beg end)
"Remove inline display of images."
(interactive)
(let* ((beg (or beg (point-min)))
(end (or end (point-max)))
(overlays (overlays-in beg end)))
(dolist (ov overlays)
(when (memq ov org-inline-image-overlays)
(setq org-inline-image-overlays (delq ov org-inline-image-overlays))
(delete-overlay ov)))
;; Clear removed overlays.
(dolist (ov org-inline-image-overlays)
(unless (overlay-buffer ov)
(setq org-inline-image-overlays (delq ov org-inline-image-overlays))))))
(defvar org-self-insert-command-undo-counter 0)
(defvar org-speed-command nil)
(defun org-fix-tags-on-the-fly ()
"Align tags in headline at point.
Unlike `org-align-tags', this function does nothing if point is
either not currently on a tagged headline or on a tag."
(when (and (org-match-line org-tag-line-re)
(< (point) (match-beginning 1)))
(org-align-tags)))
(defun org--speed-command-p ()
"Return non-nil when current command is a speed command.
Set `org-speed-command' to the appropriate command as a side effect."
(and org-use-speed-commands
(let ((kv (this-command-keys-vector)))
(setq org-speed-command
(run-hook-with-args-until-success
'org-speed-command-hook
(make-string 1 (aref kv (1- (length kv)))))))))
(defun org-self-insert-command (N)
"Like `self-insert-command', use `overwrite-mode' for whitespace in tables.
If the cursor is in a table looking at whitespace, the whitespace is
overwritten, and the table is not marked as requiring realignment."
(interactive "p")
(cond
((org--speed-command-p)
(cond
((commandp org-speed-command)
(setq this-command org-speed-command)
(call-interactively org-speed-command))
((functionp org-speed-command)
(funcall org-speed-command))
((consp org-speed-command)
(eval org-speed-command t))
(t (let (org-use-speed-commands)
(call-interactively 'org-self-insert-command)))))
((and
(= N 1)
(not (org-region-active-p))
(org-at-table-p)
(progn
;; Check if we blank the field, and if that triggers align.
(and (featurep 'org-table)
org-table-auto-blank-field
(memq last-command
'(org-cycle org-return org-shifttab org-ctrl-c-ctrl-c))
(if (or (eq (char-after) ?\s) (looking-at "[^|\n]* |"))
;; Got extra space, this field does not determine
;; column width.
(let (org-table-may-need-update) (org-table-blank-field))
;; No extra space, this field may determine column
;; width.
(org-table-blank-field)))
t)
(looking-at "[^|\n]* |"))
;; There is room for insertion without re-aligning the table.
;; Interactively, point should never be inside invisible regions
(org-fold-core-suppress-folding-fix
(self-insert-command N))
(org-table-with-shrunk-field
(save-excursion
(skip-chars-forward "^|")
;; Do not delete last space, which is
;; `org-table-separator-space', but the regular space before
;; it.
(delete-region (- (point) 2) (1- (point))))))
(t
(setq org-table-may-need-update t)
;; Interactively, point should never be inside invisible regions
(org-fold-core-suppress-folding-fix
(self-insert-command N)
(when org-auto-align-tags (org-fix-tags-on-the-fly)))
(when org-self-insert-cluster-for-undo
(if (not (eq last-command 'org-self-insert-command))
(setq org-self-insert-command-undo-counter 1)
(if (>= org-self-insert-command-undo-counter 20)
(setq org-self-insert-command-undo-counter 1)
(and (> org-self-insert-command-undo-counter 0)
buffer-undo-list (listp buffer-undo-list)
(not (cadr buffer-undo-list)) ; remove nil entry
(setcdr buffer-undo-list (cddr buffer-undo-list)))
(setq org-self-insert-command-undo-counter
(1+ org-self-insert-command-undo-counter))))))))
(defun org-delete-backward-char (N)
"Like `delete-backward-char', insert whitespace at field end in tables.
When deleting backwards, in tables this function will insert whitespace in
front of the next \"|\" separator, to keep the table aligned. The table will
still be marked for re-alignment if the field did fill the entire column,
because, in this case the deletion might narrow the column."
(interactive "p")
(save-match-data
(if (and (= N 1)
(not overwrite-mode)
(not (org-region-active-p))
(not (eq (char-before) ?|))
(save-excursion (skip-chars-backward " \t") (not (bolp)))
(looking-at-p ".*?|")
(org-at-table-p))
(progn (forward-char -1) (org-delete-char 1))
(funcall-interactively #'backward-delete-char N)
(when org-auto-align-tags (org-fix-tags-on-the-fly)))))
(defun org-delete-char (N)
"Like `delete-char', but insert whitespace at field end in tables.
When deleting characters, in tables this function will insert whitespace in
front of the next \"|\" separator, to keep the table aligned. The table will
still be marked for re-alignment if the field did fill the entire column,
because, in this case the deletion might narrow the column."
(interactive "p")
(save-match-data
(cond
((or (/= N 1)
(eq (char-after) ?|)
(save-excursion (skip-chars-backward " \t") (bolp))
(not (org-at-table-p)))
(delete-char N)
(when org-auto-align-tags (org-fix-tags-on-the-fly)))
((looking-at ".\\(.*?\\)|")
(let* ((update? org-table-may-need-update)
(noalign (looking-at-p ".*? |")))
(delete-char 1)
(org-table-with-shrunk-field
(save-excursion
;; Last space is `org-table-separator-space', so insert
;; a regular one before it instead.
(goto-char (- (match-end 0) 2))
(insert " ")))
;; If there were two spaces at the end, this field does not
;; determine the width of the column.
(when noalign (setq org-table-may-need-update update?))))
(t
(delete-char N)))))
;; Make `delete-selection-mode' work with Org mode and Orgtbl mode
(put 'org-self-insert-command 'delete-selection
(lambda ()
(unless (org--speed-command-p)
(not (run-hook-with-args-until-success
'self-insert-uses-region-functions)))))
(put 'orgtbl-self-insert-command 'delete-selection
(lambda ()
(not (run-hook-with-args-until-success
'self-insert-uses-region-functions))))
(put 'org-delete-char 'delete-selection 'supersede)
(put 'org-delete-backward-char 'delete-selection 'supersede)
(put 'org-yank 'delete-selection 'yank)
(put 'org-return 'delete-selection t)
;; Make `flyspell-mode' delay after some commands
(put 'org-self-insert-command 'flyspell-delayed t)
(put 'orgtbl-self-insert-command 'flyspell-delayed t)
(put 'org-delete-char 'flyspell-delayed t)
(put 'org-delete-backward-char 'flyspell-delayed t)
;; Make pabbrev-mode expand after Org mode commands
(put 'org-self-insert-command 'pabbrev-expand-after-command t)
(put 'orgtbl-self-insert-command 'pabbrev-expand-after-command t)
(defun org-transpose-words ()
"Transpose words for Org.
This uses the `org-mode-transpose-word-syntax-table' syntax
table, which interprets characters in `org-emphasis-alist' as
word constituents."
(interactive)
(with-syntax-table org-mode-transpose-word-syntax-table
(call-interactively 'transpose-words)))
(defvar org-ctrl-c-ctrl-c-hook nil
"Hook for functions attaching themselves to \\`C-c C-c'.
This can be used to add additional functionality to the \\`C-c C-c'
key which executes context-dependent commands. This hook is run
before any other test, while `org-ctrl-c-ctrl-c-final-hook' is
run after the last test.
Each function will be called with no arguments. The function
must check if the context is appropriate for it to act. If yes,
it should do its thing and then return a non-nil value. If the
context is wrong, just do nothing and return nil.")
(defvar org-ctrl-c-ctrl-c-final-hook nil
"Hook for functions attaching themselves to \\`C-c C-c'.
This can be used to add additional functionality to the \\`C-c C-c'
key which executes context-dependent commands. This hook is run
after any other test, while `org-ctrl-c-ctrl-c-hook' is run
before the first test.
Each function will be called with no arguments. The function
must check if the context is appropriate for it to act. If yes,
it should do its thing and then return a non-nil value. If the
context is wrong, just do nothing and return nil.")
(defvar org-tab-after-check-for-table-hook nil
"Hook for functions to attach themselves to TAB.
See `org-ctrl-c-ctrl-c-hook' for more information.
This hook runs after it has been established that the cursor is not in a
table, but before checking if the cursor is in a headline or if global cycling
should be done.
If any function in this hook returns t, not other actions like visibility
cycling will be done.")
(defvar org-tab-after-check-for-cycling-hook nil
"Hook for functions to attach themselves to TAB.
See `org-ctrl-c-ctrl-c-hook' for more information.
This hook runs after it has been established that not table field motion and
not visibility should be done because of current context. This is probably
the place where a package like yasnippets can hook in.")
(defvar org-tab-before-tab-emulation-hook nil
"Hook for functions to attach themselves to TAB.
See `org-ctrl-c-ctrl-c-hook' for more information.
This hook runs after every other options for TAB have been exhausted, but
before indentation and \t insertion takes place.")
(defvar org-metaleft-hook nil
"Hook for functions attaching themselves to `M-left'.
See `org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-metaleft-final-hook nil
"Hook for functions attaching themselves to `M-left'.
This one runs after all options have been excluded.
See `org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-metaright-hook nil
"Hook for functions attaching themselves to `M-right'.
See `org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-metaright-final-hook nil
"Hook for functions attaching themselves to `M-right'.
This one runs after all options have been excluded.
See `org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-metaup-hook nil
"Hook for functions attaching themselves to `M-up'.
See `org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-metaup-final-hook nil
"Hook for functions attaching themselves to `M-up'.
This one runs after all other options except
`org-drag-element-backward' have been excluded. See
`org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-metadown-hook nil
"Hook for functions attaching themselves to `M-down'.
See `org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-metadown-final-hook nil
"Hook for functions attaching themselves to `M-down'.
This one runs after all other options except
`org-drag-element-forward' have been excluded. See
`org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-shiftmetaleft-hook nil
"Hook for functions attaching themselves to `M-S-left'.
See `org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-shiftmetaleft-final-hook nil
"Hook for functions attaching themselves to `M-S-left'.
This one runs after all other options have been excluded. See
`org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-shiftmetaright-hook nil
"Hook for functions attaching themselves to `M-S-right'.
See `org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-shiftmetaright-final-hook nil
"Hook for functions attaching themselves to `M-S-right'.
This one runs after all other options have been excluded. See
`org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-shiftmetaup-hook nil
"Hook for functions attaching themselves to `M-S-up'.
See `org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-shiftmetaup-final-hook nil
"Hook for functions attaching themselves to `M-S-up'.
This one runs after all other options except
`org-drag-line-backward' have been excluded. See
`org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-shiftmetadown-hook nil
"Hook for functions attaching themselves to `M-S-down'.
See `org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-shiftmetadown-final-hook nil
"Hook for functions attaching themselves to `M-S-down'.
This one runs after all other options except
`org-drag-line-forward' have been excluded. See
`org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-metareturn-hook nil
"Hook for functions attaching themselves to `M-RET'.
See `org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-shiftup-hook nil
"Hook for functions attaching themselves to `S-up'.
See `org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-shiftup-final-hook nil
"Hook for functions attaching themselves to `S-up'.
This one runs after all other options except shift-select have been excluded.
See `org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-shiftdown-hook nil
"Hook for functions attaching themselves to `S-down'.
See `org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-shiftdown-final-hook nil
"Hook for functions attaching themselves to `S-down'.
This one runs after all other options except shift-select have been excluded.
See `org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-shiftleft-hook nil
"Hook for functions attaching themselves to `S-left'.
See `org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-shiftleft-final-hook nil
"Hook for functions attaching themselves to `S-left'.
This one runs after all other options except shift-select have been excluded.
See `org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-shiftright-hook nil
"Hook for functions attaching themselves to `S-right'.
See `org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-shiftright-final-hook nil
"Hook for functions attaching themselves to `S-right'.
This one runs after all other options except shift-select have been excluded.
See `org-ctrl-c-ctrl-c-hook' for more information.")
(defun org-modifier-cursor-error ()
"Throw an error, a modified cursor command was applied in wrong context."
(user-error "This command is active in special context like tables, headlines or items"))
(defun org-shiftselect-error ()
"Throw an error because Shift-Cursor command was applied in wrong context."
(if (and (boundp 'shift-select-mode) shift-select-mode)
(user-error "To use shift-selection with Org mode, customize `org-support-shift-select'")
(user-error "This command works only in special context like headlines or timestamps")))
(defun org-call-for-shift-select (cmd)
(let ((this-command-keys-shift-translated t))
(call-interactively cmd)))
(defun org-shifttab (&optional arg)
"Global visibility cycling or move to previous table field.
Call `org-table-previous-field' within a table.
When ARG is nil, cycle globally through visibility states.
When ARG is a numeric prefix, show contents of this level."
(interactive "P")
(cond
((org-at-table-p) (call-interactively 'org-table-previous-field))
((integerp arg)
(let ((arg2 (if org-odd-levels-only (1- (* 2 arg)) arg)))
(message "Content view to level: %d" arg)
(org-cycle-content (prefix-numeric-value arg2))
(org-cycle-show-empty-lines t)
(setq org-cycle-global-status 'overview)
(run-hook-with-args 'org-cycle-hook 'overview)))
(t (call-interactively 'org-cycle-global))))
(defun org-shiftmetaleft ()
"Promote subtree or delete table column.
Calls `org-promote-subtree', `org-outdent-item-tree', or
`org-table-delete-column', depending on context. See the
individual commands for more information.
This function runs the functions in `org-shiftmetaleft-hook' one
by one as a first step, and exits immediately if a function from
the hook returns non-nil. In the absence of a specific context,
the function also runs `org-shiftmetaleft-final-hook' using the
same logic."
(interactive)
(cond
((and (eq system-type 'darwin)
(or (eq org-support-shift-select 'always)
(and org-support-shift-select (org-region-active-p))))
(org-call-for-shift-select 'backward-char))
((run-hook-with-args-until-success 'org-shiftmetaleft-hook))
((org-at-table-p) (call-interactively 'org-table-delete-column))
((org-at-heading-p) (call-interactively 'org-promote-subtree))
((if (not (org-region-active-p)) (org-at-item-p)
(save-excursion (goto-char (region-beginning))
(org-at-item-p)))
(call-interactively 'org-outdent-item-tree))
((run-hook-with-args-until-success 'org-shiftmetaleft-final-hook))
(t (org-modifier-cursor-error))))
(defun org-shiftmetaright ()
"Demote subtree or insert table column.
Calls `org-demote-subtree', `org-indent-item-tree', or
`org-table-insert-column', depending on context. See the
individual commands for more information.
This function runs the functions in `org-shiftmetaright-hook' one
by one as a first step, and exits immediately if a function from
the hook returns non-nil. In the absence of a specific context,
the function also runs `org-shiftmetaright-final-hook' using the
same logic."
(interactive)
(cond
((and (eq system-type 'darwin)
(or (eq org-support-shift-select 'always)
(and org-support-shift-select (org-region-active-p))))
(org-call-for-shift-select 'forward-char))
((run-hook-with-args-until-success 'org-shiftmetaright-hook))
((org-at-table-p) (call-interactively 'org-table-insert-column))
((org-at-heading-p) (call-interactively 'org-demote-subtree))
((if (not (org-region-active-p)) (org-at-item-p)
(save-excursion (goto-char (region-beginning))
(org-at-item-p)))
(call-interactively 'org-indent-item-tree))
((run-hook-with-args-until-success 'org-shiftmetaright-final-hook))
(t (org-modifier-cursor-error))))
(defun org-shiftmetaup (&optional _arg)
"Drag the line at point up.
In a table, kill the current row.
On a clock timestamp, update the value of the timestamp like `S-<up>'
but also adjust the previous clocked item in the clock history.
Everywhere else, drag the line at point up.
This function runs the functions in `org-shiftmetaup-hook' one by
one as a first step, and exits immediately if a function from the
hook returns non-nil. In the absence of a specific context, the
function also runs `org-shiftmetaup-final-hook' using the same
logic."
(interactive "P")
(cond
((run-hook-with-args-until-success 'org-shiftmetaup-hook))
((org-at-table-p) (call-interactively 'org-table-kill-row))
((org-at-clock-log-p) (let ((org-clock-adjust-closest t))
(call-interactively 'org-timestamp-up)))
((run-hook-with-args-until-success 'org-shiftmetaup-final-hook))
(t (call-interactively 'org-drag-line-backward))))
(defun org-shiftmetadown (&optional _arg)
"Drag the line at point down.
In a table, insert an empty row at the current line.
On a clock timestamp, update the value of the timestamp like `S-<down>'
but also adjust the previous clocked item in the clock history.
Everywhere else, drag the line at point down.
This function runs the functions in `org-shiftmetadown-hook' one
by one as a first step, and exits immediately if a function from
the hook returns non-nil. In the absence of a specific context,
the function also runs `org-shiftmetadown-final-hook' using the
same logic."
(interactive "P")
(cond
((run-hook-with-args-until-success 'org-shiftmetadown-hook))
((org-at-table-p) (call-interactively 'org-table-insert-row))
((org-at-clock-log-p) (let ((org-clock-adjust-closest t))
(call-interactively 'org-timestamp-down)))
((run-hook-with-args-until-success 'org-shiftmetadown-final-hook))
(t (call-interactively 'org-drag-line-forward))))
(defsubst org-hidden-tree-error ()
(user-error
"Hidden subtree, open with TAB or use subtree command M-S-<left>/<right>"))
(defun org-metaleft (&optional _arg)
"Promote heading, list item at point or move table column left.
Calls `org-do-promote', `org-outdent-item' or `org-table-move-column',
depending on context. With no specific context, calls the Emacs
default `backward-word'. See the individual commands for more
information.
This function runs the functions in `org-metaleft-hook' one by
one as a first step, and exits immediately if a function from the
hook returns non-nil. In the absence of a specific context, the
function runs `org-metaleft-final-hook' using the same logic."
(interactive "P")
(cond
((run-hook-with-args-until-success 'org-metaleft-hook))
((org-at-table-p) (org-call-with-arg 'org-table-move-column 'left))
((org-with-limited-levels
(or (org-at-heading-p)
(and (org-region-active-p)
(save-excursion
(goto-char (region-beginning))
(org-at-heading-p)))))
(when (org-check-for-hidden 'headlines) (org-hidden-tree-error))
(call-interactively 'org-do-promote))
;; At an inline task.
((org-at-heading-p)
(call-interactively 'org-inlinetask-promote))
((or (org-at-item-p)
(and (org-region-active-p)
(save-excursion
(goto-char (region-beginning))
(org-at-item-p))))
(when (org-check-for-hidden 'items) (org-hidden-tree-error))
(call-interactively 'org-outdent-item))
((run-hook-with-args-until-success 'org-metaleft-final-hook))
(t (call-interactively 'backward-word))))
(defun org-metaright (&optional _arg)
"Demote heading, list item at point or move table column right.
In front of a drawer or a block keyword, indent it correctly.
Calls `org-do-demote', `org-indent-item', `org-table-move-column',
`org-indent-drawer' or `org-indent-block' depending on context.
With no specific context, calls the Emacs default `forward-word'.
See the individual commands for more information.
This function runs the functions in `org-metaright-hook' one by
one as a first step, and exits immediately if a function from the
hook returns non-nil. In the absence of a specific context, the
function runs `org-metaright-final-hook' using the same logic."
(interactive "P")
(cond
((run-hook-with-args-until-success 'org-metaright-hook))
((org-at-table-p) (call-interactively 'org-table-move-column))
((org-at-drawer-p) (call-interactively 'org-indent-drawer))
((org-at-block-p) (call-interactively 'org-indent-block))
((org-with-limited-levels
(or (org-at-heading-p)
(and (org-region-active-p)
(save-excursion
(goto-char (region-beginning))
(org-at-heading-p)))))
(when (org-check-for-hidden 'headlines) (org-hidden-tree-error))
(call-interactively 'org-do-demote))
;; At an inline task.
((org-at-heading-p)
(call-interactively 'org-inlinetask-demote))
((or (org-at-item-p)
(and (org-region-active-p)
(save-excursion
(goto-char (region-beginning))
(org-at-item-p))))
(when (org-check-for-hidden 'items) (org-hidden-tree-error))
(call-interactively 'org-indent-item))
((run-hook-with-args-until-success 'org-metaright-final-hook))
(t (call-interactively 'forward-word))))
(defun org-check-for-hidden (what)
"Check if there are hidden headlines/items in the current visual line.
WHAT can be either `headlines' or `items'. If the current line is
an outline or item heading and it has a folded subtree below it,
this function returns t, nil otherwise."
(let ((re (cond
((eq what 'headlines) org-outline-regexp-bol)
((eq what 'items) (org-item-beginning-re))
(t (error "This should not happen"))))
beg end)
(save-excursion
(catch 'exit
(unless (org-region-active-p)
(setq beg (line-beginning-position))
(forward-line 1)
(while (and (not (eobp)) ;; this is like `next-line'
(org-invisible-p (1- (point))))
(forward-line 1))
(setq end (point))
(goto-char beg)
(goto-char (line-end-position))
(setq end (max end (point)))
(while (re-search-forward re end t)
(when (org-invisible-p (match-beginning 0))
(throw 'exit t))))
nil))))
(defun org-metaup (&optional _arg)
"Move subtree up or move table row up.
Calls `org-move-subtree-up' or `org-table-move-row' or
`org-move-item-up', depending on context. Everywhere else, move
backward the element at point. See the individual commands for
more information.
This function runs the functions in `org-metaup-hook' one by one
as a first step, and exits immediately if a function from the
hook returns non-nil. In the absence of a specific context, the
function runs `org-metaup-final-hook' using the same logic."
(interactive "P")
(cond
((run-hook-with-args-until-success 'org-metaup-hook))
((and (org-region-active-p)
(org-with-limited-levels
(save-excursion
(goto-char (region-beginning))
(org-at-heading-p))))
(when (org-check-for-hidden 'headlines) (org-hidden-tree-error))
(let ((beg (region-beginning))
(end (region-end)))
(save-excursion
;; Go a little earlier because `org-move-subtree-down' will
;; insert before markers and we may overshoot in some cases.
(goto-char (max beg (1- end)))
(setq end (point-marker))
(goto-char beg)
(let ((level (org-current-level)))
(when (or (and (> level 1) (re-search-forward (format "^\\*\\{1,%s\\} " (1- level)) end t))
;; Search previous subtree.
(progn
(goto-char beg)
(forward-line 0)
(not (re-search-backward (format "^\\*\\{%s\\} " level) nil t))))
(user-error "Cannot move past superior level or buffer limit"))
;; Drag first subtree above below the selected.
(while (< (point) end)
(let ((deactivate-mark nil))
(call-interactively 'org-move-subtree-down)))))))
((org-region-active-p)
(let* ((a (save-excursion
(goto-char (region-beginning))
(line-beginning-position)))
(b (save-excursion
(goto-char (region-end))
(if (bolp) (1- (point)) (line-end-position))))
(c (save-excursion
(goto-char a)
(move-beginning-of-line 0)
(point)))
(d (save-excursion
(goto-char a)
(move-end-of-line 0)
(point)))
(deactivate-mark nil)
(swap? (< (point) (mark))))
(transpose-regions a b c d)
(set-mark c)
(goto-char (+ c (- b a)))
(when swap? (exchange-point-and-mark))))
((org-at-table-p) (org-call-with-arg 'org-table-move-row 'up))
((and (featurep 'org-inlinetask)
(org-inlinetask-in-task-p))
(org-drag-element-backward))
((org-at-heading-p) (call-interactively 'org-move-subtree-up))
((org-at-item-p) (call-interactively 'org-move-item-up))
((run-hook-with-args-until-success 'org-metaup-final-hook))
(t (org-drag-element-backward))))
(defun org-metadown (&optional _arg)
"Move subtree down or move table row down.
Calls `org-move-subtree-down' or `org-table-move-row' or
`org-move-item-down', depending on context. Everywhere else,
move forward the element at point. See the individual commands
for more information.
This function runs the functions in `org-metadown-hook' one by
one as a first step, and exits immediately if a function from the
hook returns non-nil. In the absence of a specific context, the
function runs `org-metadown-final-hook' using the same logic."
(interactive "P")
(cond
((run-hook-with-args-until-success 'org-metadown-hook))
((and (org-region-active-p)
(org-with-limited-levels
(save-excursion
(goto-char (region-beginning))
(org-at-heading-p))))
(when (org-check-for-hidden 'headlines) (org-hidden-tree-error))
(let ((beg (region-beginning))
(end (region-end)))
(save-excursion
(goto-char beg)
(setq beg (point-marker))
(let ((level (org-current-level)))
(when (or (and (> level 1) (re-search-forward (format "^\\*\\{1,%s\\} " (1- level)) end t))
;; Search next subtree.
(progn
(goto-char end)
(not (re-search-forward (format "^\\*\\{%s\\} " level) nil t))))
(user-error "Cannot move past superior level or buffer limit"))
;; Drag first subtree below above the selected.
(while (> (point) beg)
(let ((deactivate-mark nil))
(call-interactively 'org-move-subtree-up)))))))
((org-region-active-p)
(let* ((a (save-excursion
(goto-char (region-beginning))
(line-beginning-position)))
(b (save-excursion
(goto-char (region-end))
(if (bolp) (1- (point)) (line-end-position))))
(c (save-excursion
(goto-char b)
(move-beginning-of-line (if (bolp) 1 2))
(point)))
(d (save-excursion
(goto-char b)
(move-end-of-line (if (bolp) 1 2))
(point)))
(deactivate-mark nil)
(swap? (< (point) (mark))))
(transpose-regions a b c d)
(set-mark (+ 1 a (- d c)))
(goto-char (+ 1 a (- d c) (- b a)))
(when swap? (exchange-point-and-mark))))
((org-at-table-p) (call-interactively 'org-table-move-row))
((and (featurep 'org-inlinetask)
(org-inlinetask-in-task-p))
(org-drag-element-forward))
((org-at-heading-p) (call-interactively 'org-move-subtree-down))
((org-at-item-p) (call-interactively 'org-move-item-down))
((run-hook-with-args-until-success 'org-metadown-final-hook))
(t (org-drag-element-forward))))
(defun org-shiftup (&optional arg)
"Act on current element according to context.
Call `org-timestamp-up' or `org-priority-up', or
`org-previous-item', or `org-table-move-cell-up'. See the
individual commands for more information.
This function runs the functions in `org-shiftup-hook' one by one
as a first step, and exits immediately if a function from the
hook returns non-nil. In the absence of a specific context, the
function also runs `org-shiftup-final-hook' using the same logic.
If none of the previous steps succeed and
`org-support-shift-select' is non-nil, the function runs
`shift-select-mode' associated command. See that variable for
more information."
(interactive "P")
(cond
((run-hook-with-args-until-success 'org-shiftup-hook))
((and org-support-shift-select (org-region-active-p))
(org-call-for-shift-select 'previous-line))
((org-at-timestamp-p 'lax)
(call-interactively (if org-edit-timestamp-down-means-later
'org-timestamp-down 'org-timestamp-up)))
((and (not (eq org-support-shift-select 'always))
org-priority-enable-commands
(org-at-heading-p))
(call-interactively 'org-priority-up))
((and (not org-support-shift-select) (org-at-item-p))
(call-interactively 'org-previous-item))
((org-clocktable-try-shift 'up arg))
((and (not (eq org-support-shift-select 'always))
(org-at-table-p))
(org-table-move-cell-up))
((run-hook-with-args-until-success 'org-shiftup-final-hook))
(org-support-shift-select
(org-call-for-shift-select 'previous-line))
(t (org-shiftselect-error))))
(defun org-shiftdown (&optional arg)
"Act on current element according to context.
Call `org-timestamp-down' or `org-priority-down', or
`org-next-item', or `org-table-move-cell-down'. See the
individual commands for more information.
This function runs the functions in `org-shiftdown-hook' one by
one as a first step, and exits immediately if a function from the
hook returns non-nil. In the absence of a specific context, the
function also runs `org-shiftdown-final-hook' using the same
logic.
If none of the previous steps succeed and
`org-support-shift-select' is non-nil, the function runs
`shift-select-mode' associated command. See that variable for
more information."
(interactive "P")
(cond
((run-hook-with-args-until-success 'org-shiftdown-hook))
((and org-support-shift-select (org-region-active-p))
(org-call-for-shift-select 'next-line))
((org-at-timestamp-p 'lax)
(call-interactively (if org-edit-timestamp-down-means-later
'org-timestamp-up 'org-timestamp-down)))
((and (not (eq org-support-shift-select 'always))
org-priority-enable-commands
(org-at-heading-p))
(call-interactively 'org-priority-down))
((and (not org-support-shift-select) (org-at-item-p))
(call-interactively 'org-next-item))
((org-clocktable-try-shift 'down arg))
((and (not (eq org-support-shift-select 'always))
(org-at-table-p))
(org-table-move-cell-down))
((run-hook-with-args-until-success 'org-shiftdown-final-hook))
(org-support-shift-select
(org-call-for-shift-select 'next-line))
(t (org-shiftselect-error))))
(defun org-shiftright (&optional arg)
"Act on the current element according to context.
This does one of the following:
- switch a timestamp at point one day into the future
- on a headline, switch to the next TODO keyword
- on an item, switch entire list to the next bullet type
- on a property line, switch to the next allowed value
- on a clocktable definition line, move time block into the future
- in a table, move a single cell right
This function runs the functions in `org-shiftright-hook' one by
one as a first step, and exits immediately if a function from the
hook returns non-nil. In the absence of a specific context, the
function runs `org-shiftright-final-hook' using the same logic.
If none of the above succeeds and `org-support-shift-select' is
non-nil, runs `shift-select-mode' specific command. See that
variable for more information."
(interactive "P")
(cond
((run-hook-with-args-until-success 'org-shiftright-hook))
((and org-support-shift-select (org-region-active-p))
(org-call-for-shift-select 'forward-char))
((org-at-timestamp-p 'lax) (call-interactively 'org-timestamp-up-day))
((and (not (eq org-support-shift-select 'always))
(org-at-heading-p))
(let ((org-inhibit-logging
(not org-treat-S-cursor-todo-selection-as-state-change))
(org-inhibit-blocking
(not org-treat-S-cursor-todo-selection-as-state-change)))
(org-call-with-arg 'org-todo 'right)))
((or (and org-support-shift-select
(not (eq org-support-shift-select 'always))
(org-at-item-bullet-p))
(and (not org-support-shift-select) (org-at-item-p)))
(org-call-with-arg 'org-cycle-list-bullet nil))
((and (not (eq org-support-shift-select 'always))
(org-at-property-p))
(call-interactively 'org-property-next-allowed-value))
((org-clocktable-try-shift 'right arg))
((and (not (eq org-support-shift-select 'always))
(org-at-table-p))
(org-table-move-cell-right))
((run-hook-with-args-until-success 'org-shiftright-final-hook))
(org-support-shift-select
(org-call-for-shift-select 'forward-char))
(t (org-shiftselect-error))))
(defun org-shiftleft (&optional arg)
"Act on current element according to context.
This does one of the following:
- switch a timestamp at point one day into the past
- on a headline, switch to the previous TODO keyword.
- on an item, switch entire list to the previous bullet type
- on a property line, switch to the previous allowed value
- on a clocktable definition line, move time block into the past
- in a table, move a single cell left
This function runs the functions in `org-shiftleft-hook' one by
one as a first step, and exits immediately if a function from the
hook returns non-nil. In the absence of a specific context, the
function runs `org-shiftleft-final-hook' using the same logic.
If none of the above succeeds and `org-support-shift-select' is
non-nil, runs `shift-select-mode' specific command. See that
variable for more information."
(interactive "P")
(cond
((run-hook-with-args-until-success 'org-shiftleft-hook))
((and org-support-shift-select (org-region-active-p))
(org-call-for-shift-select 'backward-char))
((org-at-timestamp-p 'lax) (call-interactively 'org-timestamp-down-day))
((and (not (eq org-support-shift-select 'always))
(org-at-heading-p))
(let ((org-inhibit-logging
(not org-treat-S-cursor-todo-selection-as-state-change))
(org-inhibit-blocking
(not org-treat-S-cursor-todo-selection-as-state-change)))
(org-call-with-arg 'org-todo 'left)))
((or (and org-support-shift-select
(not (eq org-support-shift-select 'always))
(org-at-item-bullet-p))
(and (not org-support-shift-select) (org-at-item-p)))
(org-call-with-arg 'org-cycle-list-bullet 'previous))
((and (not (eq org-support-shift-select 'always))
(org-at-property-p))
(call-interactively 'org-property-previous-allowed-value))
((org-clocktable-try-shift 'left arg))
((and (not (eq org-support-shift-select 'always))
(org-at-table-p))
(org-table-move-cell-left))
((run-hook-with-args-until-success 'org-shiftleft-final-hook))
(org-support-shift-select
(org-call-for-shift-select 'backward-char))
(t (org-shiftselect-error))))
(defun org-shiftcontrolright ()
"Switch to next TODO set."
(interactive)
(cond
((and org-support-shift-select (org-region-active-p))
(org-call-for-shift-select 'forward-word))
((and (not (eq org-support-shift-select 'always))
(org-at-heading-p))
(org-call-with-arg 'org-todo 'nextset))
(org-support-shift-select
(org-call-for-shift-select 'forward-word))
(t (org-shiftselect-error))))
(defun org-shiftcontrolleft ()
"Switch to previous TODO set."
(interactive)
(cond
((and org-support-shift-select (org-region-active-p))
(org-call-for-shift-select 'backward-word))
((and (not (eq org-support-shift-select 'always))
(org-at-heading-p))
(org-call-with-arg 'org-todo 'previousset))
(org-support-shift-select
(org-call-for-shift-select 'backward-word))
(t (org-shiftselect-error))))
(defun org-shiftcontrolup (&optional n)
"Change timestamps synchronously up in CLOCK log lines.
Optional argument N tells to change by that many units."
(interactive "P")
(if (and (org-at-clock-log-p) (org-at-timestamp-p 'lax))
(let (org-support-shift-select)
(org-clock-timestamps-up n))
(user-error "Not at a clock log")))
(defun org-shiftcontroldown (&optional n)
"Change timestamps synchronously down in CLOCK log lines.
Optional argument N tells to change by that many units."
(interactive "P")
(if (and (org-at-clock-log-p) (org-at-timestamp-p 'lax))
(let (org-support-shift-select)
(org-clock-timestamps-down n))
(user-error "Not at a clock log")))
(defun org-increase-number-at-point (&optional inc)
"Increment the number at point.
With an optional prefix numeric argument INC, increment using
this numeric value."
(interactive "p")
(if (not (number-at-point))
(user-error "Not on a number")
(unless inc (setq inc 1))
(let ((pos (point))
(beg (skip-chars-backward "-+^/*0-9eE."))
(end (skip-chars-forward "-+^/*0-9eE.")) nap)
(setq nap (buffer-substring-no-properties
(+ pos beg) (+ pos beg end)))
(delete-region (+ pos beg) (+ pos beg end))
(insert (calc-eval (concat (number-to-string inc) "+" nap))))
(when (org-at-table-p)
(org-table-align)
(org-table-end-of-field 1))))
(defun org-decrease-number-at-point (&optional inc)
"Decrement the number at point.
With an optional prefix numeric argument INC, decrement using
this numeric value."
(interactive "p")
(org-increase-number-at-point (- (or inc 1))))
(defun org-ctrl-c-ret ()
"Call `org-table-hline-and-move' or `org-insert-heading'."
(interactive)
(cond
((org-at-table-p) (call-interactively 'org-table-hline-and-move))
(t (call-interactively 'org-insert-heading))))
(defun org-copy-visible (beg end)
"Copy the visible parts of the region."
(interactive "r")
(let ((result ""))
(while (/= beg end)
(while (org-invisible-p beg)
(setq beg (org-fold-next-visibility-change beg end)))
(let ((next (org-fold-next-visibility-change beg end)))
(setq result (concat result (buffer-substring beg next)))
(setq beg next)))
;; Prevent Emacs from adding full selected text to `kill-ring'
;; when `select-enable-primary' is non-nil. This special value of
;; `deactivate-mark' only works since Emacs 29.
(setq deactivate-mark 'dont-save)
(kill-new result)
(message "Visible strings have been copied to the kill ring.")))
(defun org-copy-special ()
"Copy region in table or copy current subtree.
Calls `org-table-copy-region' or `org-copy-subtree', depending on
context. See the individual commands for more information."
(interactive)
(call-interactively
(if (org-at-table-p) #'org-table-copy-region #'org-copy-subtree)))
(defun org-cut-special ()
"Cut region in table or cut current subtree.
Calls `org-table-cut-region' or `org-cut-subtree', depending on
context. See the individual commands for more information."
(interactive)
(call-interactively
(if (org-at-table-p) #'org-table-cut-region #'org-cut-subtree)))
(defun org-paste-special (arg)
"Paste rectangular region into table, or paste subtree relative to level.
Calls `org-table-paste-rectangle' or `org-paste-subtree', depending on context.
See the individual commands for more information."
(interactive "P")
(if (org-at-table-p)
(org-table-paste-rectangle)
(org-paste-subtree arg)))
(defun org-edit-special (&optional arg)
"Call a special editor for the element at point.
When at a table, call the formula editor with `org-table-edit-formulas'.
When at table.el table, edit it in dedicated buffer.
When in a source code block, call `org-edit-src-code'; with prefix
argument, switch to session buffer.
When in an example block, call `org-edit-src-code'.
When in an inline code block, call `org-edit-inline-src-code'.
When in a fixed-width region, call `org-edit-fixed-width-region'.
When in an export block, call `org-edit-export-block'.
When in a comment block, call `org-edit-comment-block'.
When in a LaTeX environment, call `org-edit-latex-environment'.
When at an INCLUDE, SETUPFILE or BIBLIOGRAPHY keyword, visit the included file.
When at a footnote reference, call `org-edit-footnote-reference'.
When at a planning line call, `org-deadline' and/or `org-schedule'.
When at an active timestamp, call `org-timestamp'.
When at an inactive timestamp, call `org-timestamp-inactive'.
On a link, call `ffap' to visit the link at point.
Otherwise, return a user error."
(interactive "P")
(let ((element (org-element-at-point)))
(barf-if-buffer-read-only)
(pcase (org-element-type element)
(`src-block
(if (not arg) (org-edit-src-code)
(let* ((info (org-babel-get-src-block-info))
(lang (nth 0 info))
(params (nth 2 info))
(session (cdr (assq :session params))))
(if (not session) (org-edit-src-code)
;; At a source block with a session and function called
;; with an ARG: switch to the buffer related to the
;; inferior process.
(switch-to-buffer
(funcall (intern (concat "org-babel-prep-session:" lang))
session params))))))
(`keyword
(unless (member (org-element-property :key element)
'("BIBLIOGRAPHY" "INCLUDE" "SETUPFILE"))
(user-error "No special environment to edit here"))
(let ((value (org-element-property :value element)))
(unless (org-string-nw-p value) (user-error "No file to edit"))
(let ((file (and (string-match "\\`\"\\(.*?\\)\"\\|\\S-+" value)
(or (match-string 1 value)
(match-string 0 value)))))
(when (org-url-p file)
(user-error "Files located with a URL cannot be edited"))
(org-link-open-from-string
(format "[[%s]]" (expand-file-name file))))))
(`table
(if (eq (org-element-property :type element) 'table.el)
(org-edit-table.el)
(call-interactively 'org-table-edit-formulas)))
;; Only Org tables contain `table-row' type elements.
(`table-row (call-interactively 'org-table-edit-formulas))
(`example-block (org-edit-src-code))
(`export-block (org-edit-export-block))
(`comment-block (org-edit-comment-block))
(`fixed-width (org-edit-fixed-width-region))
(`latex-environment (org-edit-latex-environment))
(`planning
(let ((proplist (cadr element)))
(mapc #'call-interactively
(remq nil
(list
(when (plist-get proplist :deadline) #'org-deadline)
(when (plist-get proplist :scheduled) #'org-schedule))))))
(_
;; No notable element at point. Though, we may be at a link or
;; a footnote reference, which are objects. Thus, scan deeper.
(let ((context (org-element-context element)))
(pcase (org-element-type context)
(`footnote-reference (org-edit-footnote-reference))
(`inline-src-block (org-edit-inline-src-code))
(`latex-fragment (org-edit-latex-fragment))
(`timestamp (if (eq 'inactive (org-element-property :type context))
(call-interactively #'org-timestamp-inactive)
(call-interactively #'org-timestamp)))
(`link (call-interactively #'ffap))
(_ (user-error "No special environment to edit here"))))))))
(defun org-ctrl-c-ctrl-c (&optional arg)
"Set tags in headline, or update according to changed information at point.
This command does many different things, depending on context:
- If column view is active, in agenda or org buffers, quit it.
- If there are highlights, remove them.
- If a function in `org-ctrl-c-ctrl-c-hook' recognizes this location,
this is what we do.
- If the cursor is on a statistics cookie, update it.
- If the cursor is in a headline, in an agenda or an org buffer,
prompt for tags and insert them into the current line, aligned
to `org-tags-column'. When called with prefix arg, realign all
tags in the current buffer.
- If the cursor is in one of the special #+KEYWORD lines, this
triggers scanning the buffer for these lines and updating the
information.
- If the cursor is inside a table, realign the table. This command
works even if the automatic table editor has been turned off.
- If the cursor is on a #+TBLFM line, re-apply the formulas to
the entire table.
- If the cursor is at a footnote reference or definition, jump to
the corresponding definition or references, respectively.
- If the cursor is a the beginning of a dynamic block, update it.
- If the current buffer is a capture buffer, close note and file it.
- If the cursor is on a <<<target>>>, update radio targets and
corresponding links in this buffer.
- If the cursor is on a numbered item in a plain list, renumber the
ordered list.
- If the cursor is on a checkbox, toggle it.
- If the cursor is on a code block, evaluate it. The variable
`org-confirm-babel-evaluate' can be used to control prompting
before code block evaluation, by default every code block
evaluation requires confirmation. Code block evaluation can be
inhibited by setting `org-babel-no-eval-on-ctrl-c-ctrl-c'."
(interactive "P")
(cond
((bound-and-true-p org-columns-overlays) (org-columns-quit))
((or (bound-and-true-p org-clock-overlays) org-occur-highlights)
(when (boundp 'org-clock-overlays) (org-clock-remove-overlays))
(org-remove-occur-highlights)
(message "Temporary highlights/overlays removed from current buffer"))
((and (local-variable-p 'org-finish-function)
(fboundp org-finish-function))
(funcall org-finish-function))
((org-babel-hash-at-point))
((run-hook-with-args-until-success 'org-ctrl-c-ctrl-c-hook))
(t
(let* ((context
(org-element-lineage
(org-element-context)
;; Limit to supported contexts.
'(babel-call clock dynamic-block footnote-definition
footnote-reference inline-babel-call inline-src-block
inlinetask item keyword node-property paragraph
plain-list planning property-drawer radio-target
src-block statistics-cookie table table-cell table-row
timestamp)
t))
(radio-list-p (org-at-radio-list-p))
(type (org-element-type context)))
;; For convenience: at the first line of a paragraph on the same
;; line as an item, apply function on that item instead.
(when (eq type 'paragraph)
(let ((parent (org-element-parent context)))
(when (and (org-element-type-p parent 'item)
(= (line-beginning-position)
(org-element-begin parent)))
(setq context parent)
(setq type 'item))))
;; Act according to type of element or object at point.
;;
;; Do nothing on a blank line, except if it is contained in
;; a source block. Hence, we first check if point is in such
;; a block and then if it is at a blank line.
(pcase type
((or `inline-src-block `src-block)
(unless org-babel-no-eval-on-ctrl-c-ctrl-c
(org-babel-eval-wipe-error-buffer)
(org-babel-execute-src-block
current-prefix-arg (org-babel-get-src-block-info nil context))))
((guard (org-match-line "[ \t]*$"))
(or (run-hook-with-args-until-success 'org-ctrl-c-ctrl-c-final-hook)
(user-error
(substitute-command-keys
"`\\[org-ctrl-c-ctrl-c]' can do nothing useful here"))))
((or `babel-call `inline-babel-call)
(let ((info (org-babel-lob-get-info context)))
(when info (org-babel-execute-src-block nil info nil type))))
(`clock
(if (org-at-timestamp-p 'lax)
;; Update the timestamp as well. `org-timestamp-change'
;; will call `org-clock-update-time-maybe'.
(org-timestamp-change 0 'day)
(org-clock-update-time-maybe)))
(`dynamic-block
(save-excursion
(goto-char (org-element-post-affiliated context))
(org-update-dblock)))
(`footnote-definition
(goto-char (org-element-post-affiliated context))
(call-interactively 'org-footnote-action))
(`footnote-reference (call-interactively #'org-footnote-action))
((or `headline `inlinetask)
(save-excursion (goto-char (org-element-begin context))
(call-interactively #'org-set-tags-command)))
(`item
;; At an item: `C-u C-u' sets checkbox to "[-]"
;; unconditionally, whereas `C-u' will toggle its presence.
;; Without a universal argument, if the item has a checkbox,
;; toggle it. Otherwise repair the list.
(if (or radio-list-p
(and (boundp org-list-checkbox-radio-mode)
org-list-checkbox-radio-mode))
(org-toggle-radio-button arg)
(let* ((box (org-element-property :checkbox context))
(struct (org-element-property :structure context))
(old-struct (copy-tree struct))
(parents (org-list-parents-alist struct))
(prevs (org-list-prevs-alist struct))
(orderedp (org-not-nil (org-entry-get nil "ORDERED"))))
(org-list-set-checkbox
(org-element-begin context) struct
(cond ((equal arg '(16)) "[-]")
((and (not box) (equal arg '(4))) "[ ]")
((or (not box) (equal arg '(4))) nil)
((eq box 'on) "[ ]")
(t "[X]")))
;; Mimic `org-list-write-struct' but with grabbing a return
;; value from `org-list-struct-fix-box'.
(org-list-struct-fix-ind struct parents 2)
(org-list-struct-fix-item-end struct)
(org-list-struct-fix-bul struct prevs)
(org-list-struct-fix-ind struct parents)
(let ((block-item
(org-list-struct-fix-box struct parents prevs orderedp)))
(if (and box (equal struct old-struct))
(if (equal arg '(16))
(message "Checkboxes already reset")
(user-error "Cannot toggle this checkbox: %s"
(if (eq box 'on)
"all subitems checked"
"unchecked subitems")))
(org-list-struct-apply-struct struct old-struct)
(org-update-checkbox-count-maybe))
(when block-item
(message "Checkboxes were removed due to empty box at line %d"
(org-current-line block-item)))))))
(`plain-list
;; At a plain list, with a double C-u argument, set
;; checkboxes of each item to "[-]", whereas a single one
;; will toggle their presence according to the state of the
;; first item in the list. Without an argument, repair the
;; list.
(if (or radio-list-p
(and (boundp org-list-checkbox-radio-mode)
org-list-checkbox-radio-mode))
(org-toggle-radio-button arg)
(let* ((begin (org-element-contents-begin context))
(struct (org-element-property :structure context))
(old-struct (copy-tree struct))
(first-box (save-excursion
(goto-char begin)
(looking-at org-list-full-item-re)
(match-string-no-properties 3)))
(new-box (cond ((equal arg '(16)) "[-]")
((equal arg '(4)) (unless first-box "[ ]"))
((equal first-box "[X]") "[ ]")
(t "[X]"))))
(cond
(arg
(dolist (pos
(org-list-get-all-items
begin struct (org-list-prevs-alist struct)))
(org-list-set-checkbox pos struct new-box)))
((and first-box (eq (point) begin))
;; For convenience, when point is at bol on the first
;; item of the list and no argument is provided, simply
;; toggle checkbox of that item, if any.
(org-list-set-checkbox begin struct new-box)))
(when (equal
(org-list-write-struct
struct (org-list-parents-alist struct) old-struct)
old-struct)
(message "Cannot update this checkbox"))
(org-update-checkbox-count-maybe))))
(`keyword
(let ((org-inhibit-startup-visibility-stuff t)
(org-startup-align-all-tables nil))
(when (boundp 'org-table-coordinate-overlays)
(mapc #'delete-overlay org-table-coordinate-overlays)
(setq org-table-coordinate-overlays nil))
(org-save-outline-visibility 'use-markers (org-mode-restart)))
(message "Local setup has been refreshed"))
((or `property-drawer `node-property)
(call-interactively #'org-property-action))
(`radio-target
(call-interactively #'org-update-radio-target-regexp))
(`statistics-cookie
(call-interactively #'org-update-statistics-cookies))
((or `table `table-cell `table-row)
;; At a table, generate a plot if on the #+plot line,
;; recalculate every field and align it otherwise. Also
;; send the table if necessary.
(cond
((and (org-match-line "[ \t]*#\\+plot:")
(< (point) (org-element-post-affiliated context)))
(org-plot/gnuplot))
;; If the table has a `table.el' type, just give up.
((eq (org-element-property :type context) 'table.el)
(message "%s" (substitute-command-keys "\\<org-mode-map>\
Use `\\[org-edit-special]' to edit table.el tables")))
;; At a table row or cell, maybe recalculate line but always
;; align table.
((or (eq type 'table)
;; Check if point is at a TBLFM line.
(and (eq type 'table-row)
(= (point) (org-element-end context))))
(save-excursion
(if (org-at-TBLFM-p)
(progn (require 'org-table)
(org-table-calc-current-TBLFM))
(goto-char (org-element-contents-begin context))
(org-call-with-arg 'org-table-recalculate (or arg t))
(orgtbl-send-table 'maybe))))
(t
(org-table-maybe-eval-formula)
(cond (arg (call-interactively #'org-table-recalculate))
((org-table-maybe-recalculate-line))
(t (org-table-align))))))
((or `timestamp (and `planning (guard (org-at-timestamp-p 'lax))))
(org-timestamp-change 0 'day))
((and `nil (guard (org-at-heading-p)))
;; When point is on an unsupported object type, we can miss
;; the fact that it also is at a heading. Handle it here.
(call-interactively #'org-set-tags-command))
((guard
(run-hook-with-args-until-success 'org-ctrl-c-ctrl-c-final-hook)))
(_
(user-error
(substitute-command-keys
"`\\[org-ctrl-c-ctrl-c]' can do nothing useful here"))))))))
(defun org-mode-restart ()
"Restart `org-mode'."
(interactive)
(let ((indent-status (bound-and-true-p org-indent-mode)))
(funcall major-mode)
(hack-local-variables)
(when (and indent-status (not (bound-and-true-p org-indent-mode)))
(org-indent-mode -1))
(org-reset-file-cache))
(message "%s restarted" major-mode))
(defun org-kill-note-or-show-branches ()
"Abort storing current note, or show just branches."
(interactive)
(cond (org-finish-function
(let ((org-note-abort t)) (funcall org-finish-function)))
((org-before-first-heading-p)
(org-fold-show-branches-buffer)
(org-fold-hide-archived-subtrees (point-min) (point-max)))
(t
(let ((beg (progn (org-back-to-heading) (point)))
(end (save-excursion (org-end-of-subtree t t) (point))))
(org-fold-hide-subtree)
(org-fold-show-branches)
(org-fold-hide-archived-subtrees beg end)))))
(defun org-delete-indentation (&optional arg beg end)
"Join current line to previous and fix whitespace at join.
If previous line is a headline add to headline title. Otherwise
the function calls `delete-indentation'.
If there is a region (BEG END), then join the lines in that region.
With a non-nil prefix ARG, join the line with the following one,
ignoring region."
(interactive
(cons current-prefix-arg
(when (and (not current-prefix-arg) (use-region-p))
(list (region-beginning) (region-end)))))
(unless (and beg end)
;; No region selected or BEG/END arguments not passed.
(setq beg (line-beginning-position (if arg 1 0))
end (line-end-position (if arg 2 1))))
(if (save-excursion
(goto-char beg)
(forward-line 0)
(and (< (line-end-position) end)
(let ((case-fold-search nil))
(looking-at org-complex-heading-regexp))))
;; At headline.
(let ((tags-column (when (match-beginning 5)
(save-excursion (goto-char (match-beginning 5))
(current-column))))
string)
(goto-char beg)
;; Join all but headline.
(save-excursion
(save-match-data
(if (version<= "27" emacs-version)
(delete-indentation nil (line-beginning-position 2) end)
;; FIXME: Emacs 26. `delete-indentation' does not yet
;; accept BEG/END arguments.
(save-restriction
(narrow-to-region beg end)
(goto-char beg)
(forward-line 2)
(while (< (point) (point-max))
(delete-indentation)
(forward-line 1))))))
(setq string (org-trim (delete-and-extract-region (line-end-position) (line-end-position 2))))
(goto-char (or (match-end 4)
(match-beginning 5)
(match-end 0)))
(skip-chars-backward " \t")
(save-excursion (insert " " string))
;; Adjust alignment of tags.
(cond
((not tags-column)) ;no tags
(org-auto-align-tags (org-align-tags))
(t (org--align-tags-here tags-column)))) ;preserve tags column
(if (version<= "27" emacs-version)
(funcall-interactively #'delete-indentation arg beg end)
;; FIXME: Emacs 26. `delete-indentation' does not yet
;; accept BEG/END arguments.
(save-restriction
(narrow-to-region beg end)
(goto-char beg)
(forward-line 1)
(while (< (point) (point-max))
(delete-indentation)
(forward-line 1))))))
(defun org-open-line (n)
"Insert a new row in tables, call `open-line' elsewhere.
If `org-special-ctrl-o' is nil, just call `open-line' everywhere.
As a special case, when a document starts with a table, allow
calling `open-line' on the very first character."
(interactive "*p")
(if (and org-special-ctrl-o (/= (point) 1) (org-at-table-p))
(org-table-insert-row)
(open-line n)))
(defun org--newline (indent arg interactive)
"Call `newline-and-indent' or just `newline'.
If INDENT is non-nil, call `newline-and-indent' with ARG to
indent unconditionally; otherwise, call `newline' with ARG and
INTERACTIVE, which can trigger indentation if
`electric-indent-mode' is enabled."
(if indent
(org-newline-and-indent arg)
(newline arg interactive)))
(defun org-return (&optional indent arg interactive)
"Goto next table row or insert a newline.
Calls `org-table-next-row' or `newline', depending on context.
When optional INDENT argument is non-nil, call
`newline-and-indent' with ARG, otherwise call `newline' with ARG
and INTERACTIVE.
When `org-return-follows-link' is non-nil and point is on
a timestamp, a link or a citation, call `org-open-at-point'.
However, it will not happen if point is in a table or on a \"dead\"
object (e.g., within a comment). In these case, you need to use
`org-open-at-point' directly."
(interactive "i\nP\np")
(let* ((context (if org-return-follows-link (org-element-context)
(org-element-at-point)))
(element-type (org-element-type context)))
(cond
;; In a table, call `org-table-next-row'. However, before first
;; column or after last one, split the table.
((or (and (eq 'table element-type)
(not (eq 'table.el (org-element-property :type context)))
(>= (point) (org-element-contents-begin context))
(< (point) (org-element-contents-end context)))
(org-element-lineage context '(table-row table-cell) t))
(if (or (looking-at-p "[ \t]*$")
(save-excursion (skip-chars-backward " \t") (bolp)))
(insert "\n")
(org-table-justify-field-maybe)
(call-interactively #'org-table-next-row)))
;; On a link, a timestamp or a citation, call `org-open-at-point'
;; if `org-return-follows-link' allows it. Tolerate fuzzy
;; locations, e.g., in a comment, as `org-open-at-point'.
((and org-return-follows-link
(or
(let ((context
(org-element-lineage
context
'(citation citation-reference link)
'include-self)))
(and context
;; Ensure point is not on the white spaces after
;; the link.
(let ((origin (point)))
(org-with-point-at (org-element-end context)
(skip-chars-backward " \t")
(> (point) origin)))))
(org-in-regexp org-ts-regexp-both nil t)
(org-in-regexp org-tsr-regexp-both nil t)
(org-in-regexp org-link-any-re nil t)))
(call-interactively #'org-open-at-point))
;; Insert newline in heading, but preserve tags.
((and (not (bolp))
(let ((case-fold-search nil))
(org-match-line org-complex-heading-regexp)))
;; At headline. Split line. However, if point is on keyword,
;; priority cookie or tags, do not break any of them: add
;; a newline after the headline instead.
(let ((tags-column (and (match-beginning 5)
(save-excursion (goto-char (match-beginning 5))
(current-column))))
(string
(when (and (match-end 4) (org-point-in-group (point) 4))
(delete-and-extract-region (point) (match-end 4)))))
;; Adjust tag alignment.
(cond
((not (and tags-column string)))
(org-auto-align-tags (org-align-tags))
(t (org--align-tags-here tags-column))) ;preserve tags column
(end-of-line)
(org-fold-show-entry 'hide-drawers)
(org--newline indent arg interactive)
(when string (save-excursion (insert (org-trim string))))))
;; In a list, make sure indenting keeps trailing text within.
((and (not (eolp))
(org-element-lineage context 'item))
(let ((trailing-data
(delete-and-extract-region (point) (line-end-position))))
(org--newline indent arg interactive)
(save-excursion (insert trailing-data))))
(t
;; Do not auto-fill when point is in an Org property drawer.
(let ((auto-fill-function (and (not (org-at-property-p))
auto-fill-function)))
(org--newline indent arg interactive))))))
(defun org-return-and-maybe-indent ()
"Goto next table row, or insert a newline, maybe indented.
Call `org-table-next-row' or `org-return', depending on context.
See the individual commands for more information.
When inserting a newline, if `org-adapt-indentation' is t:
indent the line if `electric-indent-mode' is disabled, don't
indent it if it is enabled."
(interactive)
(org-return (not electric-indent-mode)))
(defun org-ctrl-c-tab (&optional arg)
"Toggle columns width in a table, or show children.
Call `org-table-toggle-column-width' if point is in a table.
Otherwise provide a compact view of the children. ARG is the
level to hide."
(interactive "p")
(cond
((org-at-table-p)
(call-interactively #'org-table-toggle-column-width))
((org-before-first-heading-p)
(save-excursion
(org-fold-flag-above-first-heading)
(org-fold-hide-sublevels (or arg 1))))
(t
(org-fold-hide-subtree)
(org-fold-show-children arg))))
(defun org-ctrl-c-star ()
"Compute table, or change heading status of lines.
Calls `org-table-recalculate' or `org-toggle-heading',
depending on context."
(interactive)
(cond
((org-at-table-p)
(call-interactively 'org-table-recalculate))
(t
;; Convert all lines in region to list items
(call-interactively 'org-toggle-heading))))
(defun org-ctrl-c-minus ()
"Insert separator line in table or modify bullet status of line.
Also turns a plain line or a region of lines into list items.
Calls `org-table-insert-hline', `org-toggle-item', or
`org-cycle-list-bullet', depending on context."
(interactive)
(cond
((org-at-table-p)
(call-interactively 'org-table-insert-hline))
((org-region-active-p)
(call-interactively 'org-toggle-item))
((org-in-item-p)
(call-interactively 'org-cycle-list-bullet))
(t
(call-interactively 'org-toggle-item))))
(defun org-toggle-heading (&optional nstars)
"Convert headings to normal text, or items or text to headings.
If there is no active region, only convert the current line.
With a `\\[universal-argument]' prefix, convert the whole list at
point into heading.
In a region:
- If the first non blank line is a headline, remove the stars
from all headlines in the region.
- If it is a normal line, turn each and every normal line (i.e.,
not an heading or an item) in the region into headings. If you
want to convert only the first line of this region, use one
universal prefix argument.
- If it is a plain list item, turn all plain list items into headings.
The checkboxes are converted to appropriate TODO or DONE keywords
(using `car' or `org-done-keywords' and `org-not-done-keywords' when
available).
When converting a line into a heading, the number of stars is chosen
such that the lines become children of the current entry. However,
when a numeric prefix argument is given, its value determines the
number of stars to add."
(interactive "P")
(let ((skip-blanks
;; Return beginning of first non-blank line, starting from
;; line at POS.
(lambda (pos)
(save-excursion
(goto-char pos)
(while (org-at-comment-p) (forward-line))
(skip-chars-forward " \r\t\n")
(line-beginning-position))))
beg end toggled)
;; Determine boundaries of changes. If a universal prefix has
;; been given, put the list in a region. If region ends at a bol,
;; do not consider the last line to be in the region.
(when (and current-prefix-arg (org-at-item-p))
(when (listp current-prefix-arg) (setq current-prefix-arg 1))
(org-mark-element))
(if (org-region-active-p)
(setq beg (funcall skip-blanks (region-beginning))
end (copy-marker (save-excursion
(goto-char (region-end))
(if (bolp) (point) (line-end-position)))))
(setq beg (funcall skip-blanks (line-beginning-position))
end (copy-marker (line-end-position))))
;; Ensure inline tasks don't count as headings.
(org-with-limited-levels
(save-excursion
(goto-char beg)
(cond
;; Case 1. Started at an heading: de-star headings.
((org-at-heading-p)
(while (< (point) end)
(when (org-at-heading-p)
(looking-at org-outline-regexp) (replace-match "")
(setq toggled t))
(forward-line)))
;; Case 2. Started at an item: change items into headlines.
;; One star will be added by `org-list-to-subtree'.
((org-at-item-p)
(while (< (point) end)
(when (org-at-item-p)
;; Pay attention to cases when region ends before list.
(let* ((struct (org-list-struct))
(list-end
(min (org-list-get-bottom-point struct) (1+ end))))
(save-restriction
(narrow-to-region (point) list-end)
(insert (org-list-to-subtree
(org-list-to-lisp t)
(pcase (org-current-level)
(`nil 1)
(l (1+ (org-reduced-level l))))
;; Keywords to replace checkboxes.
(list
;; [X]
:cbon (concat (or (car org-done-keywords) "DONE") " ")
;; [ ]
:cboff (concat (or (car org-not-done-keywords) "TODO") " ")
;; [-]
:cbtrans (concat (or (car org-not-done-keywords) "TODO") " ")))
"\n")))
(setq toggled t))
(forward-line)))
;; Case 3. Started at normal text: make every line an heading,
;; skipping headlines and items.
(t (let* ((stars
(make-string
(if (numberp nstars) nstars (or (org-current-level) 0)) ?*))
(add-stars
(cond (nstars "") ; stars from prefix only
((equal stars "") "*") ; before first heading
(org-odd-levels-only "**") ; inside heading, odd
(t "*"))) ; inside heading, oddeven
(rpl (concat stars add-stars " "))
(lend (when (listp nstars) (save-excursion (end-of-line) (point)))))
(while (< (point) (if (equal nstars '(4)) lend end))
(when (and (not (or (org-at-heading-p) (org-at-item-p) (org-at-comment-p)))
(looking-at "\\([ \t]*\\)\\(\\S-\\)"))
(replace-match (concat rpl (match-string 2))) (setq toggled t))
(forward-line)))))))
(unless toggled (message "Cannot toggle heading from here"))))
(defun org-meta-return (&optional arg)
"Insert a new heading or wrap a region in a table.
Calls `org-insert-heading', `org-insert-item' or
`org-table-wrap-region', depending on context. When called with
an argument, unconditionally call `org-insert-heading'."
(interactive "P")
(or (run-hook-with-args-until-success 'org-metareturn-hook)
(call-interactively (cond (arg #'org-insert-heading)
((org-at-table-p) #'org-table-wrap-region)
((org-in-item-p) #'org-insert-item)
(t #'org-insert-heading)))))
;;; Menu entries
(defsubst org-in-subtree-not-table-p ()
"Are we in a subtree and not in a table?"
(and (not (org-before-first-heading-p))
(not (org-at-table-p))))
;; Define the Org mode menus
(easy-menu-define org-org-menu org-mode-map "Org menu."
`("Org"
("Show/Hide"
["Cycle Visibility" org-cycle :active (or (bobp) (outline-on-heading-p))]
["Cycle Global Visibility" org-shifttab :active (not (org-at-table-p))]
["Sparse Tree..." org-sparse-tree t]
["Reveal Context" org-fold-reveal t]
["Show All" org-fold-show-all t]
"--"
["Subtree to indirect buffer" org-tree-to-indirect-buffer t])
"--"
["New Heading" org-insert-heading t]
("Navigate Headings"
["Up" outline-up-heading t]
["Next" outline-next-visible-heading t]
["Previous" outline-previous-visible-heading t]
["Next Same Level" outline-forward-same-level t]
["Previous Same Level" outline-backward-same-level t]
"--"
["Jump" org-goto t])
("Edit Structure"
["Move Subtree Up" org-metaup (org-at-heading-p)]
["Move Subtree Down" org-metadown (org-at-heading-p)]
"--"
["Copy Subtree" org-copy-special (org-in-subtree-not-table-p)]
["Cut Subtree" org-cut-special (org-in-subtree-not-table-p)]
["Paste Subtree" org-paste-special (not (org-at-table-p))]
"--"
["Clone subtree, shift time" org-clone-subtree-with-time-shift t]
"--"
["Copy visible text" org-copy-visible t]
"--"
["Promote Heading" org-metaleft (org-in-subtree-not-table-p)]
["Promote Subtree" org-shiftmetaleft (org-in-subtree-not-table-p)]
["Demote Heading" org-metaright (org-in-subtree-not-table-p)]
["Demote Subtree" org-shiftmetaright (org-in-subtree-not-table-p)]
"--"
["Sort Region/Children" org-sort t]
"--"
["Convert to odd levels" org-convert-to-odd-levels t]
["Convert to odd/even levels" org-convert-to-oddeven-levels t])
("Editing"
["Emphasis..." org-emphasize t]
["Add block structure" org-insert-structure-template t]
["Edit Source Example" org-edit-special t]
"--"
["Footnote new/jump" org-footnote-action t]
["Footnote extra" (org-footnote-action t) :active t :keys "C-u C-c C-x f"])
("Archive"
["Archive (default method)" org-archive-subtree-default (org-in-subtree-not-table-p)]
"--"
["Move Subtree to Archive file" org-archive-subtree (org-in-subtree-not-table-p)]
["Toggle ARCHIVE tag" org-toggle-archive-tag (org-in-subtree-not-table-p)]
["Move subtree to Archive sibling" org-archive-to-archive-sibling (org-in-subtree-not-table-p)])
"--"
("Hyperlinks"
["Store Link (Global)" org-store-link t]
["Find existing link to here" org-occur-link-in-agenda-files t]
["Insert Link" org-insert-link t]
["Follow Link" org-open-at-point t]
"--"
["Next link" org-next-link t]
["Previous link" org-previous-link t]
"--"
["Descriptive Links"
org-toggle-link-display
:style radio
:selected org-descriptive-links
]
["Literal Links"
org-toggle-link-display
:style radio
:selected (not org-descriptive-links)])
"--"
("TODO Lists"
["TODO/DONE/-" org-todo t]
("Select keyword"
["Next keyword" org-shiftright (org-at-heading-p)]
["Previous keyword" org-shiftleft (org-at-heading-p)]
["Complete Keyword" pcomplete (assq :todo-keyword (org-context))]
["Next keyword set" org-shiftcontrolright (and (> (length org-todo-sets) 1) (org-at-heading-p))]
["Previous keyword set" org-shiftcontrolright (and (> (length org-todo-sets) 1) (org-at-heading-p))])
["Show TODO Tree" org-show-todo-tree :active t :keys "C-c / t"]
["Global TODO list" org-todo-list :active t :keys "\\[org-agenda] t"]
"--"
["Enforce dependencies" (customize-variable 'org-enforce-todo-dependencies)
:selected org-enforce-todo-dependencies :style toggle :active t]
"Settings for tree at point"
["Do Children sequentially" org-toggle-ordered-property :style radio
:selected (org-entry-get nil "ORDERED")
:active org-enforce-todo-dependencies :keys "C-c C-x o"]
["Do Children parallel" org-toggle-ordered-property :style radio
:selected (not (org-entry-get nil "ORDERED"))
:active org-enforce-todo-dependencies :keys "C-c C-x o"]
"--"
["Set Priority" org-priority t]
["Priority Up" org-shiftup t]
["Priority Down" org-shiftdown t]
"--"
["Get news from all feeds" org-feed-update-all t]
["Go to the inbox of a feed..." org-feed-goto-inbox t]
["Customize feeds" (customize-variable 'org-feed-alist) t])
("TAGS and Properties"
["Set Tags" org-set-tags-command (not (org-before-first-heading-p))]
["Change tag in region" org-change-tag-in-region (org-region-active-p)]
"--"
["Set property" org-set-property (not (org-before-first-heading-p))]
["Column view of properties" org-columns t]
["Insert Column View DBlock" org-columns-insert-dblock t])
("Dates and Scheduling"
["Timestamp" org-timestamp (not (org-before-first-heading-p))]
["Timestamp (inactive)" org-timestamp-inactive (not (org-before-first-heading-p))]
("Change Date"
["1 Day Later" org-shiftright (org-at-timestamp-p 'lax)]
["1 Day Earlier" org-shiftleft (org-at-timestamp-p 'lax)]
["1 ... Later" org-shiftup (org-at-timestamp-p 'lax)]
["1 ... Earlier" org-shiftdown (org-at-timestamp-p 'lax)])
["Compute Time Range" org-evaluate-time-range t]
["Schedule Item" org-schedule (not (org-before-first-heading-p))]
["Deadline" org-deadline (not (org-before-first-heading-p))]
"--"
["Custom time format" org-toggle-timestamp-overlays
:style radio :selected org-display-custom-times]
"--"
["Goto Calendar" org-goto-calendar t]
["Date from Calendar" org-date-from-calendar t]
"--"
["Start/Restart Timer" org-timer-start t]
["Pause/Continue Timer" org-timer-pause-or-continue t]
["Stop Timer" org-timer-pause-or-continue :active t :keys "C-u C-c C-x ,"]
["Insert Timer String" org-timer t]
["Insert Timer Item" org-timer-item t])
("Logging work"
["Clock in" org-clock-in :active t :keys "C-c C-x C-i"]
["Switch task" (lambda () (interactive) (org-clock-in '(4))) :active t :keys "C-u C-c C-x C-i"]
["Clock out" org-clock-out t]
["Clock cancel" org-clock-cancel t]
"--"
["Mark as default task" org-clock-mark-default-task t]
["Clock in, mark as default" (lambda () (interactive) (org-clock-in '(16))) :active t :keys "C-u C-u C-c C-x C-i"]
["Goto running clock" org-clock-goto t]
"--"
["Display times" org-clock-display t]
["Create clock table" org-clock-report t]
"--"
["Record DONE time"
(progn (setq org-log-done (not org-log-done))
(message "Switching to %s will %s record a timestamp"
(car org-done-keywords)
(if org-log-done "automatically" "not")))
:style toggle :selected org-log-done])
"--"
["Agenda Command..." org-agenda t]
["Set Restriction Lock" org-agenda-set-restriction-lock t]
("File List for Agenda")
("Special views current file"
["TODO Tree" org-show-todo-tree t]
["Check Deadlines" org-check-deadlines t]
["Tags/Property tree" org-match-sparse-tree t])
"--"
["Export/Publish..." org-export-dispatch t]
("LaTeX"
["Org CDLaTeX mode" org-cdlatex-mode :active (require 'cdlatex nil t)
:style toggle :selected org-cdlatex-mode]
["Insert Environment" cdlatex-environment (fboundp 'cdlatex-environment)]
["Insert math symbol" cdlatex-math-symbol (fboundp 'cdlatex-math-symbol)]
["Modify math symbol" org-cdlatex-math-modify
(org-inside-LaTeX-fragment-p)]
["Insert citation" org-reftex-citation t])
"--"
("Documentation"
["Show Version" org-version t]
["Info Documentation" org-info t]
["Browse Org News" org-browse-news t])
("Customize"
["Browse Org Group" org-customize t]
"--"
["Expand This Menu" org-create-customize-menu t])
["Send bug report" org-submit-bug-report t]
"--"
("Refresh/Reload"
["Refresh setup current buffer" org-mode-restart t]
["Reload Org (after update)" org-reload t]
["Reload Org uncompiled" (org-reload t) :active t :keys "C-u C-c C-x !"])))
(easy-menu-define org-tbl-menu org-mode-map "Org Table menu."
'("Table"
["Align" org-ctrl-c-ctrl-c :active (org-at-table-p)]
["Next Field" org-cycle (org-at-table-p)]
["Previous Field" org-shifttab (org-at-table-p)]
["Next Row" org-return (org-at-table-p)]
"--"
["Blank Field" org-table-blank-field (org-at-table-p)]
["Edit Field" org-table-edit-field (org-at-table-p)]
["Copy Field from Above" org-table-copy-down (org-at-table-p)]
"--"
("Column"
["Move Column Left" org-metaleft (org-at-table-p)]
["Move Column Right" org-metaright (org-at-table-p)]
["Delete Column" org-shiftmetaleft (org-at-table-p)]
["Insert Column" org-shiftmetaright (org-at-table-p)]
["Shrink Column" org-table-toggle-column-width (org-at-table-p)])
("Row"
["Move Row Up" org-metaup (org-at-table-p)]
["Move Row Down" org-metadown (org-at-table-p)]
["Delete Row" org-shiftmetaup (org-at-table-p)]
["Insert Row" org-shiftmetadown (org-at-table-p)]
["Sort lines in region" org-table-sort-lines (org-at-table-p)]
"--"
["Insert Hline" org-ctrl-c-minus (org-at-table-p)])
("Rectangle"
["Copy Rectangle" org-copy-special (org-at-table-p)]
["Cut Rectangle" org-cut-special (org-at-table-p)]
["Paste Rectangle" org-paste-special (org-at-table-p)]
["Fill Rectangle" org-table-wrap-region (org-at-table-p)])
"--"
("Calculate"
["Set Column Formula" org-table-eval-formula (org-at-table-p)]
["Set Field Formula" (org-table-eval-formula '(4)) :active (org-at-table-p) :keys "C-u C-c ="]
["Edit Formulas" org-edit-special (org-at-table-p)]
"--"
["Recalculate line" org-table-recalculate (org-at-table-p)]
["Recalculate all" (lambda () (interactive) (org-table-recalculate '(4))) :active (org-at-table-p) :keys "C-u C-c *"]
["Iterate all" (lambda () (interactive) (org-table-recalculate '(16))) :active (org-at-table-p) :keys "C-u C-u C-c *"]
"--"
["Toggle Recalculate Mark" org-table-rotate-recalc-marks (org-at-table-p)]
"--"
["Sum Column/Rectangle" org-table-sum
(or (org-at-table-p) (org-region-active-p))]
["Which Column?" org-table-current-column (org-at-table-p)])
["Debug Formulas"
org-table-toggle-formula-debugger
:style toggle :selected (bound-and-true-p org-table-formula-debug)]
["Show Col/Row Numbers"
org-table-toggle-coordinate-overlays
:style toggle
:selected (bound-and-true-p org-table-overlay-coordinates)]
"--"
["Create" org-table-create (not (org-at-table-p))]
["Convert Region" org-table-convert-region (not (org-at-table-p 'any))]
["Import from File" org-table-import (not (org-at-table-p))]
["Export to File" org-table-export (org-at-table-p)]
"--"
["Create/Convert from/to table.el" org-table-create-with-table.el t]
"--"
("Plot"
["Ascii plot" orgtbl-ascii-plot :active (org-at-table-p) :keys "C-c \" a"]
["Gnuplot" org-plot/gnuplot :active (org-at-table-p) :keys "C-c \" g"])))
(defun org-info (&optional node)
"Read documentation for Org in the info system.
With optional NODE, go directly to that node."
(interactive)
(info (format "(org)%s" (or node ""))))
(defun org-browse-news ()
"Browse the news for the latest major release."
(interactive)
(browse-url "https://orgmode.org/Changes.html"))
(defvar org--warnings nil
"List of warnings to be added to the bug reports.")
;;;###autoload
(defun org-submit-bug-report ()
"Submit a bug report on Org via mail.
Don't hesitate to report any problems or inaccurate documentation.
If you don't have setup sending mail from (X)Emacs, please copy the
output buffer into your mail program, as it gives us important
information about your Org version and configuration."
(interactive)
(require 'reporter)
(defvar reporter-prompt-for-summary-p)
(org-load-modules-maybe)
(org-require-autoloaded-modules)
(let ((reporter-prompt-for-summary-p "Bug report subject: "))
(reporter-submit-bug-report
"emacs-orgmode@gnu.org"
(org-version nil 'full)
(let (list)
(save-window-excursion
(pop-to-buffer
(get-buffer-create "*Warn about privacy*")
'(org-display-buffer-full-frame))
(erase-buffer)
(insert "You are about to submit a bug report to the Org mailing list.
If your report is about Org installation, please read this section:
https://orgmode.org/org.html#Installation
Please read https://orgmode.org/org.html#Feedback on how to make
a good report, it will help Org contributors fixing your problem.
Search https://lists.gnu.org/archive/html/emacs-orgmode/ to see
if the issue you are about to raise has already been dealt with.
We also would like to add your full Org and Outline configuration
to the bug report. It will help us debugging the issue.
*HOWEVER*, some variables you have customized may contain private
information. The names of customers, colleagues, or friends, might
appear in the form of file names, tags, todo states or search strings.
If you answer \"yes\" to the prompt, you might want to check and remove
such private information before sending the email.")
(add-text-properties (point-min) (point-max) '(face org-warning))
(when (yes-or-no-p "Include your Org configuration and Org warning log?")
(mapatoms
(lambda (v)
(and (boundp v)
(string-match "\\`\\(org-\\|outline-\\)" (symbol-name v))
(or (and (symbol-value v)
(string-match "\\(-hook\\|-function\\)\\'" (symbol-name v)))
(eq v 'org--warnings)
(and
(get v 'custom-type) (get v 'standard-value)
(not (equal (symbol-value v)
(eval (car (get v 'standard-value)) t)))))
(push v list)))))
(kill-buffer (get-buffer "*Warn about privacy*"))
list))
nil nil
"Remember to cover the basics, that is, what you expected to happen and
what in fact did happen. You don't know how to make a good report? See
https://orgmode.org/manual/Feedback.html#Feedback
Your bug report will be posted to the Org mailing list.
------------------------------------------------------------------------")
(save-excursion
(when (re-search-backward "^\\(Subject: \\)Org mode version \\(.*?\\);[ \t]*\\(.*\\)" nil t)
(replace-match "\\1[BUG] \\3 [\\2]")))))
(defun org-install-agenda-files-menu ()
"Install agenda file menu."
(let ((bl (buffer-list)))
(save-excursion
(while bl
(set-buffer (pop bl))
(when (derived-mode-p 'org-mode) (setq bl nil)))
(when (derived-mode-p 'org-mode)
(easy-menu-change
'("Org") "File List for Agenda"
(append
(list
["Edit File List" (org-edit-agenda-file-list) t]
["Add/Move Current File to Front of List" org-agenda-file-to-front t]
["Remove Current File from List" org-remove-file t]
["Cycle through agenda files" org-cycle-agenda-files t]
["Occur in all agenda files" org-occur-in-agenda-files t]
"--")
(mapcar 'org-file-menu-entry
;; Prevent initialization from failing.
(ignore-errors (org-agenda-files t)))))))))
;;;; Documentation
(defun org-require-autoloaded-modules ()
(interactive)
(mapc #'require
'(org-agenda org-archive org-attach org-clock org-colview org-id
org-table org-timer)))
;;;###autoload
(defun org-reload (&optional uncompiled)
"Reload all Org Lisp files.
With prefix arg UNCOMPILED, load the uncompiled versions."
(interactive "P")
(require 'loadhist)
(let* ((org-dir (org-find-library-dir "org"))
(contrib-dir (or (org-find-library-dir "org-contribdir") org-dir))
(feature-re "^\\(org\\|ob\\|ox\\|ol\\|oc\\)\\(-.*\\)?")
(remove-re (format "\\`%s\\'"
(regexp-opt '("org" "org-loaddefs" "org-version"))))
(feats (delete-dups
(mapcar 'file-name-sans-extension
(mapcar 'file-name-nondirectory
(delq nil
(mapcar 'feature-file
features))))))
(lfeat (append
(sort
(setq feats
(delq nil (mapcar
(lambda (f)
(if (and (string-match feature-re f)
(not (string-match remove-re f)))
f nil))
feats)))
'string-lessp)
(list "org-version" "org")))
(load-suffixes (if uncompiled (reverse load-suffixes) load-suffixes))
load-uncore load-misses)
(setq load-misses
(delq t
(mapcar (lambda (f)
(or (org-load-noerror-mustsuffix (concat org-dir f))
(and (string= org-dir contrib-dir)
(org-load-noerror-mustsuffix (concat contrib-dir f)))
(and (org-load-noerror-mustsuffix (concat (org-find-library-dir f) f))
(push f load-uncore)
t)
f))
lfeat)))
(when load-uncore
(message "The following feature%s found in load-path, please check if that's correct:\n%s"
(if (> (length load-uncore) 1) "s were" " was")
(reverse load-uncore)))
(if load-misses
(message "Some error occurred while reloading Org feature%s\n%s\nPlease check *Messages*!\n%s"
(if (> (length load-misses) 1) "s" "") load-misses (org-version nil 'full))
(message "Successfully reloaded Org\n%s" (org-version nil 'full)))))
;;;###autoload
(defun org-customize ()
"Call the customize function with org as argument."
(interactive)
(org-load-modules-maybe)
(org-require-autoloaded-modules)
(customize-browse 'org))
(defun org-create-customize-menu ()
"Create a full customization menu for Org mode, insert it into the menu."
(interactive)
(org-load-modules-maybe)
(org-require-autoloaded-modules)
(easy-menu-change
'("Org") "Customize"
`(["Browse Org group" org-customize t]
"--"
,(customize-menu-create 'org)
["Set" Custom-set t]
["Save" Custom-save t]
["Reset to Current" Custom-reset-current t]
["Reset to Saved" Custom-reset-saved t]
["Reset to Standard Settings" Custom-reset-standard t]))
(message "\"Org\"-menu now contains full customization menu"))
;;;; Miscellaneous stuff
;;; Generally useful functions
(defun org-in-clocktable-p ()
"Check if the cursor is in a clocktable."
(let ((pos (point)) start)
(save-excursion
(end-of-line 1)
(and (re-search-backward "^[ \t]*#\\+BEGIN:[ \t]+clocktable" nil t)
(setq start (match-beginning 0))
(re-search-forward "^[ \t]*#\\+END:.*" nil t)
(>= (match-end 0) pos)
start))))
(defun org-in-verbatim-emphasis ()
(save-match-data
(and (org-in-regexp org-verbatim-re 2)
(>= (point) (match-beginning 3))
(<= (point) (match-end 4)))))
(defun org-goto-marker-or-bmk (marker &optional bookmark)
"Go to MARKER, widen if necessary. When marker is not live, try BOOKMARK."
(if (and marker (marker-buffer marker)
(buffer-live-p (marker-buffer marker)))
(progn
(pop-to-buffer-same-window (marker-buffer marker))
(when (or (> marker (point-max)) (< marker (point-min)))
(widen))
(goto-char marker)
(org-fold-show-context 'org-goto))
(if bookmark
(bookmark-jump bookmark)
(error "Cannot find location"))))
(defun org-quote-csv-field (s)
"Quote field for inclusion in CSV material."
(if (string-match "[\",]" s)
(concat "\"" (mapconcat 'identity (split-string s "\"") "\"\"") "\"")
s))
(defun org-force-self-insert (N)
"Needed to enforce self-insert under remapping."
(interactive "p")
(self-insert-command N))
(defun org-quote-vert (s)
"Replace \"|\" with \"\\vert\"."
(while (string-match "|" s)
(setq s (replace-match "\\vert" t t s)))
s)
(defun org-in-src-block-p (&optional inside element)
"Return t when point is at a source block element.
When INSIDE is non-nil, return t only when point is between #+BEGIN_SRC
and #+END_SRC lines.
Note that affiliated keywords and blank lines after are considered a
part of a source block.
When ELEMENT is provided, it is considered to be element at point."
(save-match-data (setq element (or element (org-element-at-point))))
(when (org-element-type-p element 'src-block)
(or (not inside)
(not (or (<= (line-beginning-position)
(org-element-post-affiliated element))
(>= (line-end-position)
(org-with-point-at (org-element-end element)
(skip-chars-backward " \t\n\r")
(point))))))))
(defun org-context ()
"Return a list of contexts of the current cursor position.
If several contexts apply, all are returned.
Each context entry is a list with a symbol naming the context, and
two positions indicating start and end of the context. Possible
contexts are:
:headline anywhere in a headline
:headline-stars on the leading stars in a headline
:todo-keyword on a TODO keyword (including DONE) in a headline
:tags on the TAGS in a headline
:priority on the priority cookie in a headline
:item on the first line of a plain list item
:item-bullet on the bullet/number of a plain list item
:checkbox on the checkbox in a plain list item
:table in an Org table
:table-special on a special filed in a table
:table-table in a table.el table
:clocktable in a clocktable
:src-block in a source block
:link on a hyperlink
:keyword on a keyword: SCHEDULED, DEADLINE, CLOSE, COMMENT.
:latex-fragment on a LaTeX fragment
:latex-preview on a LaTeX fragment with overlaid preview image
This function expects the position to be visible because it uses font-lock
faces as a help to recognize the following contexts: :table-special, :link,
and :keyword."
(let* ((f (get-text-property (point) 'face))
(faces (if (listp f) f (list f)))
(case-fold-search t)
(p (point)) clist o)
;; First the large context
(cond
((org-at-heading-p)
(push (list :headline (line-beginning-position)
(line-end-position))
clist)
(when (progn
(forward-line 0)
(looking-at org-todo-line-tags-regexp))
(push (org-point-in-group p 1 :headline-stars) clist)
(push (org-point-in-group p 2 :todo-keyword) clist)
(push (org-point-in-group p 4 :tags) clist))
(goto-char p)
(skip-chars-backward "^[\n\r \t") (or (bobp) (backward-char 1))
(when (looking-at "\\[#[A-Z0-9]\\]")
(push (org-point-in-group p 0 :priority) clist)))
((org-at-item-p)
(push (org-point-in-group p 2 :item-bullet) clist)
(push (list :item (line-beginning-position)
(save-excursion (org-end-of-item) (point)))
clist)
(and (org-at-item-checkbox-p)
(push (org-point-in-group p 0 :checkbox) clist)))
((org-at-table-p)
(push (list :table (org-table-begin) (org-table-end)) clist)
(when (memq 'org-formula faces)
(push (list :table-special
(previous-single-property-change p 'face)
(next-single-property-change p 'face))
clist)))
((org-at-table-p 'any)
(push (list :table-table) clist)))
(goto-char p)
(let ((case-fold-search t))
;; New the "medium" contexts: clocktables, source blocks
(cond ((org-in-clocktable-p)
(push (list :clocktable
(and (or (looking-at "[ \t]*\\(#\\+BEGIN: clocktable\\)")
(re-search-backward "[ \t]*\\(#+BEGIN: clocktable\\)" nil t))
(match-beginning 1))
(and (re-search-forward "[ \t]*#\\+END:?" nil t)
(match-end 0)))
clist))
((org-in-src-block-p)
(push (list :src-block
(and (or (looking-at "[ \t]*\\(#\\+BEGIN_SRC\\)")
(re-search-backward "[ \t]*\\(#+BEGIN_SRC\\)" nil t))
(match-beginning 1))
(and (search-forward "#+END_SRC" nil t)
(match-beginning 0)))
clist))))
(goto-char p)
;; Now the small context
(cond
((org-at-timestamp-p)
(push (org-point-in-group p 0 :timestamp) clist))
((memq 'org-link faces)
(push (list :link
(previous-single-property-change p 'face)
(next-single-property-change p 'face))
clist))
((memq 'org-special-keyword faces)
(push (list :keyword
(previous-single-property-change p 'face)
(next-single-property-change p 'face))
clist))
((setq o (cl-some
(lambda (o)
(and (eq (overlay-get o 'org-overlay-type) 'org-latex-overlay)
o))
(overlays-at (point))))
(push (list :latex-fragment
(overlay-start o) (overlay-end o))
clist)
(push (list :latex-preview
(overlay-start o) (overlay-end o))
clist))
((org-inside-LaTeX-fragment-p)
;; FIXME: positions wrong.
(push (list :latex-fragment (point) (point)) clist)))
(setq clist (nreverse (delq nil clist)))
clist))
(defun org-between-regexps-p (start-re end-re &optional lim-up lim-down)
"Non-nil when point is between matches of START-RE and END-RE.
Also return a non-nil value when point is on one of the matches.
Optional arguments LIM-UP and LIM-DOWN bound the search; they are
buffer positions. Default values are the positions of headlines
surrounding the point.
The functions returns a cons cell whose car (resp. cdr) is the
position before START-RE (resp. after END-RE)."
(save-match-data
(let ((pos (point))
(limit-up (or lim-up (save-excursion (outline-previous-heading))))
(limit-down (or lim-down (save-excursion (outline-next-heading))))
beg end)
(save-excursion
;; Point is on a block when on START-RE or if START-RE can be
;; found before it...
(and (or (org-in-regexp start-re)
(re-search-backward start-re limit-up t))
(setq beg (match-beginning 0))
;; ... and END-RE after it...
(goto-char (match-end 0))
(re-search-forward end-re limit-down t)
(> (setq end (match-end 0)) pos)
;; ... without another START-RE in-between.
(goto-char (match-beginning 0))
(not (re-search-backward start-re (1+ beg) t))
;; Return value.
(cons beg end))))))
(defun org-in-block-p (names)
"Non-nil when point belongs to a block whose name belongs to NAMES.
NAMES is a list of strings containing names of blocks.
Return first block name matched, or nil. Beware that in case of
nested blocks, the returned name may not belong to the closest
block from point."
(save-match-data
(catch 'exit
(let ((case-fold-search t)
(lim-up (save-excursion (outline-previous-heading)))
(lim-down (save-excursion (outline-next-heading))))
(dolist (name names)
(let ((n (regexp-quote name)))
(when (org-between-regexps-p
(concat "^[ \t]*#\\+begin_" n)
(concat "^[ \t]*#\\+end_" n)
lim-up lim-down)
(throw 'exit n)))))
nil)))
;; Defined in org-agenda.el
(defvar org-agenda-restrict)
(defvar org-agenda-restrict-begin)
(defvar org-agenda-restrict-end)
(defun org-occur-in-agenda-files (regexp &optional _nlines)
"Call `multi-occur' with buffers for all agenda files."
(interactive "sOrg-files matching: ")
(let* ((files (org-agenda-files))
(tnames (mapcar #'file-truename files))
(extra org-agenda-text-search-extra-files)
(narrows nil))
(when (and (eq (car extra) 'agenda-archives)
(not org-agenda-restrict))
(setq extra (cdr extra))
(setq files (org-add-archive-files files)))
(unless org-agenda-restrict
(dolist (f extra)
(unless (member (file-truename f) tnames)
(unless (member f files) (setq files (append files (list f))))
(setq tnames (append tnames (list (file-truename f)))))))
(multi-occur
(mapcar (lambda (x)
(with-current-buffer
;; FIXME: Why not just (find-file-noselect x)?
;; Is it to avoid the "revert buffer" prompt?
(or (get-file-buffer x) (find-file-noselect x))
(if (eq (current-buffer) org-agenda-restrict)
(progn
;; Save the narrowing state.
(push (list (current-buffer) (point-min) (point-max))
narrows)
(widen)
(narrow-to-region org-agenda-restrict-begin
org-agenda-restrict-end))
(widen))
(current-buffer)))
files)
regexp)
;; Restore the narrowing.
(dolist (narrow narrows)
(with-current-buffer (car narrow)
(widen)
(narrow-to-region (nth 1 narrow) (nth 2 narrow))))))
(add-hook 'occur-mode-find-occurrence-hook
(lambda () (when (derived-mode-p 'org-mode) (org-fold-reveal))))
(defun org-occur-link-in-agenda-files ()
"Create a link and search for it in the agendas.
The link is not stored in `org-stored-links', it is just created
for the search purpose."
(interactive)
(let ((link (condition-case nil
(org-store-link nil)
(error "Unable to create a link to here"))))
(org-occur-in-agenda-files (regexp-quote link))))
(defun org-back-over-empty-lines ()
"Move backwards over whitespace, to the beginning of the first empty line.
Returns the number of empty lines passed."
(let ((pos (point)))
(if (cdr (assq 'heading org-blank-before-new-entry))
(skip-chars-backward " \t\n\r")
(unless (eobp)
(forward-line -1)))
(forward-line 1)
(goto-char (min (point) pos))
(count-lines (point) pos)))
;;; TODO: Only called once, from ox-odt which should probably use
;;; org-export-inline-image-p or something.
(defun org-file-image-p (file)
"Return non-nil if FILE is an image."
(save-match-data
(string-match (image-file-name-regexp) file)))
(defun org-get-cursor-date (&optional with-time)
"Return the date at cursor in as a time.
This works in the calendar and in the agenda, anywhere else it just
returns the current time.
If WITH-TIME is non-nil, returns the time of the event at point (in
the agenda) or the current time of the day; otherwise returns the
earliest time on the cursor date that Org treats as that date
(bearing in mind `org-extend-today-until')."
(let (date day defd tp hod mod)
(when with-time
(setq tp (get-text-property (point) 'time))
(when (and tp (string-match "\\([0-2]?[0-9]\\):\\([0-5][0-9]\\)" tp))
(setq hod (string-to-number (match-string 1 tp))
mod (string-to-number (match-string 2 tp))))
(or tp (let ((now (decode-time)))
(setq hod (nth 2 now)
mod (nth 1 now)))))
(cond
((eq major-mode 'calendar-mode)
(setq date (calendar-cursor-to-date)
defd (org-encode-time 0 (or mod 0) (or hod org-extend-today-until)
(nth 1 date) (nth 0 date) (nth 2 date))))
((eq major-mode 'org-agenda-mode)
(setq day (get-text-property (point) 'day))
(when day
(setq date (calendar-gregorian-from-absolute day)
defd (org-encode-time 0 (or mod 0) (or hod org-extend-today-until)
(nth 1 date) (nth 0 date) (nth 2 date))))))
(or defd (current-time))))
(defun org-mark-subtree (&optional up)
"Mark the current subtree.
This puts point at the start of the current subtree, and mark at
the end. If a numeric prefix UP is given, move up into the
hierarchy of headlines by UP levels before marking the subtree."
(interactive "P")
(org-with-limited-levels
(cond ((org-at-heading-p) (forward-line 0))
((org-before-first-heading-p) (user-error "Not in a subtree"))
(t (outline-previous-visible-heading 1))))
(when up (while (and (> up 0) (org-up-heading-safe)) (cl-decf up)))
(if (called-interactively-p 'any)
(call-interactively 'org-mark-element)
(org-mark-element)))
;;; Indentation
(defun org--at-headline-data-p (&optional beg element)
"Return non-nil when `point' or BEG is inside headline metadata.
Metadata is planning line, properties drawer, logbook drawer right
after property drawer, or clock log line immediately following
properties drawer/planning line/ heading.
Optional argument ELEMENT contains element at BEG."
(org-with-wide-buffer
(when beg (goto-char beg))
(setq element (or element (org-element-at-point)))
(if (or (org-element-type-p element 'headline)
(not (org-element-lineage element '(headline inlinetask))))
nil ; Not inside heading.
;; Skip to top-level parent in section.
(while (not (org-element-type-p (org-element-parent element) 'section))
(setq element (org-element-parent element)))
(pcase (org-element-type element)
((or `planning `property-drawer)
t)
(`drawer
;; LOGBOOK drawer with appropriate name.
(equal
(org-log-into-drawer)
(org-element-property :drawer-name element)))
(`clock
;; Previous element must be headline metadata or headline.
(goto-char (1- (org-element-begin element)))
(or (org-at-heading-p)
(org--at-headline-data-p)))))))
(defvar org-element-greater-elements)
(defun org--get-expected-indentation (element contentsp)
"Expected indentation column for current line, according to ELEMENT.
ELEMENT is an element containing point. CONTENTSP is non-nil
when indentation is to be computed according to contents of
ELEMENT."
(let ((type (org-element-type element))
(start (org-element-begin element))
(post-affiliated (org-element-post-affiliated element)))
(org-with-wide-buffer
(cond
(contentsp
(cl-case type
((diary-sexp footnote-definition) 0)
(section
(org--get-expected-indentation
(org-element-parent element)
t))
((headline inlinetask nil)
(if (not org-adapt-indentation) 0
(let ((level (org-current-level)))
(if level (1+ level) 0))))
((item plain-list) (org-list-item-body-column post-affiliated))
(t
(when start (goto-char start))
(current-indentation))))
((memq type '(headline inlinetask nil))
(if (org-match-line "[ \t]*$")
(org--get-expected-indentation element t)
0))
((memq type '(diary-sexp footnote-definition)) 0)
;; First paragraph of a footnote definition or an item.
;; Indent like parent.
((and start (< (line-beginning-position) start))
(org--get-expected-indentation
(org-element-parent element) t))
;; At first line: indent according to previous sibling, if any,
;; ignoring footnote definitions and inline tasks, or parent's
;; contents. If `org-adapt-indentation' is `headline-data', ignore
;; previous headline data siblings.
((and start (= (line-beginning-position) start))
(catch 'exit
(while t
(if (= (point-min) start) (throw 'exit 0)
(goto-char (1- start))
(let* ((previous (org-element-at-point))
(parent previous))
(while (and parent (<= (org-element-end parent) start))
(setq previous parent
parent (org-element-parent parent)))
(cond
((not previous) (throw 'exit 0))
((> (org-element-end previous) start)
(throw 'exit (org--get-expected-indentation previous t)))
((org-element-type-p
previous '(footnote-definition inlinetask))
(setq start (org-element-begin previous)))
;; Do not indent like previous when the previous
;; element is headline data and `org-adapt-indentation'
;; is set to `headline-data'.
((and (eq 'headline-data org-adapt-indentation)
(not (org--at-headline-data-p start element))
(or (org-at-heading-p)
(org--at-headline-data-p (1- start) previous)))
(throw 'exit 0))
(t (goto-char (org-element-begin previous))
(throw 'exit
(if (bolp) (current-indentation)
;; At first paragraph in an item or
;; a footnote definition.
(org--get-expected-indentation
(org-element-parent previous) t))))))))))
;; Otherwise, move to the first non-blank line above.
(t
(forward-line 0)
(let ((pos (point)))
(skip-chars-backward " \r\t\n")
(cond
;; Two blank lines end a footnote definition or a plain
;; list. When we indent an empty line after them, the
;; containing list or footnote definition is over, so it
;; qualifies as a previous sibling. Therefore, we indent
;; like its first line.
((and (memq type '(footnote-definition plain-list))
(> (count-lines (point) pos) 2))
(goto-char start)
(current-indentation))
;; Line above is the first one of a paragraph at the
;; beginning of an item or a footnote definition. Indent
;; like parent.
((and start (< (line-beginning-position) start))
(org--get-expected-indentation
(org-element-parent element) t))
;; Line above is the beginning of an element, i.e., point
;; was originally on the blank lines between element's start
;; and contents.
((and post-affiliated (= (line-beginning-position) post-affiliated))
(org--get-expected-indentation element t))
;; POS is after contents in a greater element. Indent like
;; the beginning of the element.
((and (memq type org-element-greater-elements)
(let ((cend (org-element-contents-end element)))
(and cend (<= cend pos))))
;; As a special case, if point is at the end of a footnote
;; definition or an item, indent like the very last element
;; within. If that last element is an item, indent like
;; its contents.
(if (memq type '(footnote-definition item plain-list))
(let ((last (org-element-at-point)))
(goto-char pos)
(org--get-expected-indentation
last (org-element-type-p last 'item)))
(goto-char start)
(current-indentation)))
;; In any other case, indent like the current line.
(t (current-indentation)))))))))
(defun org--align-node-property ()
"Align node property at point.
Alignment is done according to `org-property-format', which see."
(when (save-excursion
(forward-line 0)
(looking-at org-property-re))
(org-combine-change-calls (match-beginning 0) (match-end 0)
(let ((newtext (concat (match-string 4)
(org-trim
(format org-property-format (match-string 1) (match-string 3))))))
;; Do not use `replace-match' here as we want to inherit folding
;; properties if inside fold.
(delete-region (match-beginning 0) (match-end 0))
(insert-and-inherit newtext)))))
(defun org-indent-line ()
"Indent line depending on context.
Indentation is done according to the following rules:
- Footnote definitions, diary sexps, headlines and inline tasks
have to start at column 0.
- On the very first line of an element, consider, in order, the
next rules until one matches:
1. If there's a sibling element before, ignoring footnote
definitions and inline tasks, indent like its first line.
2. If element has a parent, indent like its contents. More
precisely, if parent is an item, indent after the bullet.
Else, indent like parent's first line.
3. Otherwise, indent relatively to current level, if
`org-adapt-indentation' is t, or to left margin.
- On a blank line at the end of an element, indent according to
the type of the element. More precisely
1. If element is a plain list, an item, or a footnote
definition, indent like the very last element within.
2. If element is a paragraph, indent like its last non blank
line.
3. Otherwise, indent like its very first line.
- In the code part of a source block, use language major mode
to indent current line if `org-src-tab-acts-natively' is
non-nil. If it is nil, do nothing.
- Otherwise, indent like the first non-blank line above.
The function doesn't indent an item as it could break the whole
list structure. Instead, use \\<org-mode-map>`\\[org-shiftmetaleft]' or \
`\\[org-shiftmetaright]'.
Also align node properties according to `org-property-format'."
(interactive)
(let* ((element (save-excursion (forward-line 0) (org-element-at-point-no-context)))
(type (org-element-type element)))
(unless (or (org-at-heading-p) ; headline has no indent ever.
;; Do not indent first element after headline data.
(and (eq org-adapt-indentation 'headline-data)
(not (org--at-headline-data-p nil element))
;; Not at headline data and previous is headline data/headline.
(or (memq type '(headline inlinetask)) ; blank lines after heading
(and element
(save-excursion
(goto-char (1- (org-element-begin element)))
(or (org-at-heading-p)
(org--at-headline-data-p)))))))
(cond ((and (memq type '(plain-list item))
(= (line-beginning-position)
(org-element-post-affiliated element)))
nil)
((and (eq type 'latex-environment)
(>= (point) (org-element-post-affiliated element))
(< (point)
(org-with-point-at (org-element-end element)
(skip-chars-backward " \t\n")
(line-beginning-position 2))))
nil)
((and (eq type 'src-block)
org-src-tab-acts-natively
(> (line-beginning-position)
(org-element-post-affiliated element))
(< (line-beginning-position)
(org-with-point-at (org-element-end element)
(skip-chars-backward " \t\n")
(line-beginning-position))))
(let ((block-content-ind
(when (not (org-src-preserve-indentation-p element))
(org-with-point-at (org-element-property :begin element)
(+ (org-current-text-indentation)
org-edit-src-content-indentation)))))
(ignore-errors ; do not err when there is no proper major mode
;; It is important to call `indent-according-to-mode'
;; rather than `indent-line-function' here or we may
;; sometimes break `electric-indent-mode'
;; https://orgmode.org/list/5O9VMGb6WRaqeHR5_NXTb832Z2Lek_5L40YPDA52-S3kPwGYJspI8kLWaGtuq3DXyhtHpj1J7jTIXb39RX9BtCa2ecrWHjijZqI8QAD742U=@proton.me
(org-babel-do-in-edit-buffer (indent-according-to-mode)))
(when (and block-content-ind (looking-at-p "^$"))
(indent-line-to block-content-ind))))
(t
(let ((column (org--get-expected-indentation element nil)))
;; Preserve current column.
(if (<= (current-column) (current-indentation))
(indent-line-to column)
(save-excursion (indent-line-to column))))
;; Align node property. Also preserve current column.
(when (eq type 'node-property)
(let ((column (current-column)))
(org--align-node-property)
(org-move-to-column column))))))))
(defun org-indent-region (start end)
"Indent each non-blank line in the region.
Called from a program, START and END specify the region to
indent. The function will not indent contents of example blocks,
verse blocks and export blocks as leading white spaces are
assumed to be significant there."
(interactive "r")
(save-excursion
(goto-char start)
(skip-chars-forward " \r\t\n")
(unless (eobp) (forward-line 0))
(let ((indent-to
(lambda (ind pos)
;; Set IND as indentation for all lines between point and
;; POS. Blank lines are ignored. Leave point after POS
;; once done.
(let ((limit (copy-marker pos)))
(while (< (point) limit)
(unless (looking-at-p "[ \t]*$") (indent-line-to ind))
(forward-line))
(set-marker limit nil))))
(end (copy-marker end)))
(while (< (point) end)
(if (or (looking-at-p " \r\t\n") (org-at-heading-p)) (forward-line)
(let* ((element (org-element-at-point))
(type (org-element-type element))
(element-end (copy-marker (org-element-end element)))
(ind (org--get-expected-indentation element nil)))
(cond
;; Element indented as a single block. Example blocks
;; preserving indentation are a special case since the
;; "contents" must not be indented whereas the block
;; boundaries can.
((or (memq type '(export-block latex-environment))
(and (eq type 'example-block)
(not (org-src-preserve-indentation-p element))))
(let ((offset (- ind (current-indentation))))
(unless (zerop offset)
(indent-rigidly (org-element-begin element)
(org-element-end element)
offset)))
(goto-char element-end))
;; Elements indented line wise. Be sure to exclude
;; example blocks (preserving indentation) and source
;; blocks from this category as they are treated
;; specially later.
((or (memq type '(paragraph table table-row))
(not (or (org-element-contents-begin element)
(memq type '(example-block src-block)))))
(when (eq type 'node-property)
(org--align-node-property)
(forward-line 0))
(funcall indent-to ind (min element-end end)))
;; Elements consisting of three parts: before the
;; contents, the contents, and after the contents. The
;; contents are treated specially, according to the
;; element type, or not indented at all. Other parts are
;; indented as a single block.
(t
(let* ((post (copy-marker
(org-element-post-affiliated element)))
(cbeg
(copy-marker
(cond
((not (org-element-contents-begin element))
;; Fake contents for source blocks.
(org-with-wide-buffer
(goto-char post)
(line-beginning-position 2)))
((memq type '(footnote-definition item plain-list))
;; Contents in these elements could start on
;; the same line as the beginning of the
;; element. Make sure we start indenting
;; from the second line.
(org-with-wide-buffer
(goto-char post)
(end-of-line)
(skip-chars-forward " \r\t\n")
(if (eobp) (point) (line-beginning-position))))
(t (org-element-contents-begin element)))))
(cend (copy-marker
(or (org-element-contents-end element)
;; Fake contents for source blocks.
(org-with-wide-buffer
(goto-char element-end)
(skip-chars-backward " \r\t\n")
(line-beginning-position)))
t)))
;; Do not change items indentation individually as it
;; might break the list as a whole. On the other
;; hand, when at a plain list, indent it as a whole.
(cond ((eq type 'plain-list)
(let ((offset (- ind (org-current-text-indentation))))
(unless (zerop offset)
(indent-rigidly (org-element-begin element)
(org-element-end element)
offset))
(goto-char cbeg)))
((eq type 'item) (goto-char cbeg))
(t (funcall indent-to ind (min cbeg end))))
(when (< (point) end)
(cl-case type
((example-block verse-block))
(src-block
;; In a source block, indent source code
;; according to language major mode, but only if
;; `org-src-tab-acts-natively' is non-nil.
(when (and (< (point) end) org-src-tab-acts-natively)
(ignore-errors
(org-babel-do-in-edit-buffer
(indent-region (point-min) (point-max))))))
(t (org-indent-region (point) (min cend end))))
(goto-char (min cend end))
(when (< (point) end)
(funcall indent-to ind (min element-end end))))
(set-marker post nil)
(set-marker cbeg nil)
(set-marker cend nil))))
(set-marker element-end nil))))
(set-marker end nil))))
(defun org-indent-drawer ()
"Indent the drawer at point.
Signal an error when not at a drawer."
(interactive)
(let ((element (org-element-at-point)))
(unless (org-element-type-p element '(drawer property-drawer))
(user-error "Not at a drawer"))
(org-with-wide-buffer
(org-indent-region (org-element-begin element)
(org-element-end element))))
(message "Drawer at point indented"))
(defun org-indent-block ()
"Indent the block at point.
Signal an error when not at a block."
(interactive)
(let ((element (org-element-at-point)))
(unless (org-element-type-p
element
'(comment-block center-block dynamic-block example-block
export-block quote-block special-block
src-block verse-block))
(user-error "Not at a block"))
(org-with-wide-buffer
(org-indent-region (org-element-begin element)
(org-element-end element))))
(message "Block at point indented"))
;;; Filling
;; We use our own fill-paragraph and auto-fill functions.
;; `org-fill-paragraph' relies on adaptive filling and context
;; checking. Appropriate `fill-prefix' is computed with
;; `org-adaptive-fill-function'.
;; `org-auto-fill-function' takes care of auto-filling. It calls
;; `do-auto-fill' only on valid areas with `fill-prefix' shadowed with
;; `org-adaptive-fill-function' value. Internally,
;; `org-comment-line-break-function' breaks the line.
;; `org-setup-filling' installs filling and auto-filling related
;; variables during `org-mode' initialization.
(defvar org--single-lines-list-is-paragraph) ; defined later
(defun org-setup-filling ()
(require 'org-element)
;; Prevent auto-fill from inserting unwanted new items.
(setq-local fill-nobreak-predicate
(org-uniquify
(append fill-nobreak-predicate
'(org-fill-line-break-nobreak-p
org-fill-n-macro-as-item-nobreak-p
org-fill-paragraph-with-timestamp-nobreak-p))))
(let ((paragraph-ending (substring org-element-paragraph-separate 1)))
(setq-local paragraph-start paragraph-ending)
(setq-local paragraph-separate paragraph-ending))
(setq-local fill-paragraph-function 'org-fill-paragraph)
(setq-local fill-forward-paragraph-function
(lambda (&optional arg)
(let ((org--single-lines-list-is-paragraph nil))
(org-forward-paragraph arg))))
(setq-local auto-fill-inhibit-regexp nil)
(setq-local adaptive-fill-function 'org-adaptive-fill-function)
(setq-local normal-auto-fill-function 'org-auto-fill-function)
(setq-local comment-line-break-function 'org-comment-line-break-function))
(defun org-fill-line-break-nobreak-p ()
"Non-nil when a new line at point would create an Org line break."
(save-excursion
(skip-chars-backward " \t")
(skip-chars-backward "\\\\")
(looking-at "\\\\\\\\\\($\\|[^\\]\\)")))
(defun org-fill-paragraph-with-timestamp-nobreak-p ()
"Non-nil when a new line at point would split a timestamp."
(and (org-at-timestamp-p 'lax)
(not (looking-at org-ts-regexp-both))))
(defun org-fill-n-macro-as-item-nobreak-p ()
"Non-nil when a new line at point would create a new list."
;; During export, a "n" macro followed by a dot or a closing
;; parenthesis can end up being parsed as a new list item.
(looking-at-p "[ \t]*{{{n\\(?:([^\n)]*)\\)?}}}[.)]\\(?:$\\| \\)"))
(defun org-adaptive-fill-function ()
"Compute a fill prefix for the current line.
Return fill prefix, as a string, or nil if current line isn't
meant to be filled. For convenience, if `adaptive-fill-regexp'
matches in paragraphs or comments, use it."
(org-with-wide-buffer
(unless (org-at-heading-p)
(let* ((p (line-beginning-position))
(element (save-excursion
(forward-line 0)
(org-element-at-point)))
(type (org-element-type element))
(post-affiliated (org-element-post-affiliated element)))
(unless (< p post-affiliated)
(cl-case type
(comment
(save-excursion
(forward-line 0)
(looking-at "[ \t]*")
(concat (match-string 0) "# ")))
(footnote-definition "")
((item plain-list)
(make-string (org-list-item-body-column post-affiliated) ?\s))
(paragraph
;; Fill prefix is usually the same as the current line,
;; unless the paragraph is at the beginning of an item.
(let ((parent (org-element-parent element)))
(save-excursion
(forward-line 0)
(cond ((org-element-type-p parent 'item)
(make-string (org-list-item-body-column
(org-element-begin parent))
?\s))
((and adaptive-fill-regexp
;; Locally disable
;; `adaptive-fill-function' to let
;; `fill-context-prefix' handle
;; `adaptive-fill-regexp' variable.
(let (adaptive-fill-function)
(fill-context-prefix
post-affiliated
(org-element-end element)))))
((looking-at "[ \t]+") (match-string 0))
(t "")))))
(comment-block
;; Only fill contents if P is within block boundaries.
(let* ((cbeg (save-excursion (goto-char post-affiliated)
(forward-line)
(point)))
(cend (save-excursion
(goto-char (org-element-end element))
(skip-chars-backward " \r\t\n")
(line-beginning-position))))
(when (and (>= p cbeg) (< p cend))
(if (save-excursion (forward-line 0) (looking-at "[ \t]+"))
(match-string 0)
""))))))))))
(defun org-fill-element (&optional justify)
"Fill element at point, when applicable.
This function only applies to comment blocks, comments, example
blocks and paragraphs. Also, as a special case, re-align table
when point is at one.
If JUSTIFY is non-nil (interactively, with prefix argument),
justify as well. If `sentence-end-double-space' is non-nil, then
period followed by one space does not end a sentence, so don't
break a line there. The variable `fill-column' controls the
width for filling.
For convenience, when point is at a plain list, an item or
a footnote definition, try to fill the first paragraph within."
(with-syntax-table org-mode-transpose-word-syntax-table
;; Move to end of line in order to get the first paragraph within
;; a plain list or a footnote definition.
(let ((element (save-excursion (end-of-line) (org-element-at-point))))
;; First check if point is in a blank line at the beginning of
;; the buffer. In that case, ignore filling.
(cl-case (org-element-type element)
;; Use major mode filling function is source blocks.
(src-block
(let ((regionp (region-active-p)))
(org-babel-do-in-edit-buffer
;; `org-babel-do-in-edit-buffer' will preserve region if it
;; is within src block contents. Otherwise, the region
;; crosses src block boundaries. We re-fill the whole src
;; block in such scenario.
(when (and regionp (not (region-active-p)))
(push-mark (point-min))
(goto-char (point-max))
(setq mark-active t))
(funcall-interactively #'fill-paragraph justify 'region))))
;; Align Org tables, leave table.el tables as-is.
(table-row (org-table-align) t)
(table
(when (eq (org-element-property :type element) 'org)
(save-excursion
(goto-char (org-element-post-affiliated element))
(org-table-align)))
t)
(paragraph
;; Paragraphs may contain `line-break' type objects.
(let ((beg (max (point-min)
(org-element-contents-begin element)))
(end (min (point-max)
(org-element-contents-end element))))
;; Do nothing if point is at an affiliated keyword.
(if (< (line-end-position) beg) t
;; Fill paragraph, taking line breaks into account.
(save-excursion
(goto-char beg)
(let ((cuts (list beg)))
(while (re-search-forward "\\\\\\\\[ \t]*\n" end t)
(when (org-element-type-p
(save-excursion (backward-char)
(org-element-context))
'line-break)
(push (point) cuts)))
(dolist (c (delq end cuts))
(fill-region-as-paragraph c end justify)
(setq end c))))
t)))
;; Contents of `comment-block' type elements should be
;; filled as plain text, but only if point is within block
;; markers.
(comment-block
(let* ((case-fold-search t)
(beg (save-excursion
(goto-char (org-element-begin element))
(re-search-forward "^[ \t]*#\\+begin_comment" nil t)
(forward-line)
(point)))
(end (save-excursion
(goto-char (org-element-end element))
(re-search-backward "^[ \t]*#\\+end_comment" nil t)
(line-beginning-position))))
(if (or (< (point) beg) (> (point) end)) t
(fill-region-as-paragraph
(save-excursion (end-of-line)
(re-search-backward "^[ \t]*$" beg 'move)
(line-beginning-position))
(save-excursion (forward-line 0)
(re-search-forward "^[ \t]*$" end 'move)
(line-beginning-position))
justify))))
;; Fill comments.
(comment
(let ((begin (org-element-post-affiliated element))
(end (org-element-end element)))
(when (and (>= (point) begin) (<= (point) end))
(let ((begin (save-excursion
(end-of-line)
(if (re-search-backward "^[ \t]*#[ \t]*$" begin t)
(progn (forward-line) (point))
begin)))
(end (save-excursion
(end-of-line)
(if (re-search-forward "^[ \t]*#[ \t]*$" end 'move)
(1- (line-beginning-position))
(skip-chars-backward " \r\t\n")
(line-end-position)))))
;; Do not fill comments when at a blank line.
(when (> end begin)
(let ((fill-prefix
(save-excursion
(forward-line 0)
(looking-at "[ \t]*#")
(let ((comment-prefix (match-string 0)))
(goto-char (match-end 0))
(if (looking-at adaptive-fill-regexp)
(concat comment-prefix (match-string 0))
(concat comment-prefix " "))))))
(save-excursion
(fill-region-as-paragraph begin end justify))))))
t))
;; Ignore every other element.
(otherwise t)))))
(defun org-fill-paragraph (&optional justify region)
"Fill element at point, when applicable.
This function only applies to comment blocks, comments, example
blocks and paragraphs. Also, as a special case, re-align table
when point is at one.
For convenience, when point is at a plain list, an item or
a footnote definition, try to fill the first paragraph within.
If JUSTIFY is non-nil (interactively, with prefix argument),
justify as well. If `sentence-end-double-space' is non-nil, then
period followed by one space does not end a sentence, so don't
break a line there. The variable `fill-column' controls the
width for filling.
The REGION argument is non-nil if called interactively; in that
case, if Transient Mark mode is enabled and the mark is active,
fill each of the elements in the active region, instead of just
filling the current element."
(interactive (progn
(barf-if-buffer-read-only)
(list (when current-prefix-arg 'full) t)))
(let ((hash (and (not (buffer-modified-p))
(org-buffer-hash))))
(cond
((and region transient-mark-mode mark-active
(not (eq (region-beginning) (region-end))))
(let ((origin (point-marker))
(start (region-beginning)))
(unwind-protect
(progn
(goto-char (region-end))
(skip-chars-backward " \t\n")
(let ((org--single-lines-list-is-paragraph nil))
(while (> (point) start)
(org-fill-element justify)
(org-backward-paragraph)
(skip-chars-backward " \t\n"))))
(goto-char origin)
(set-marker origin nil))))
(t
(save-excursion
(when (org-match-line "[ \t]*$")
(skip-chars-forward " \t\n"))
(org-fill-element justify))))
;; If we didn't change anything in the buffer (and the buffer was
;; previously unmodified), then flip the modification status back
;; to "unchanged".
(when (and hash (equal hash (org-buffer-hash)))
(set-buffer-modified-p nil))
;; Return non-nil.
t))
(defun org-auto-fill-function ()
"Auto-fill function."
;; Check if auto-filling is meaningful.
(let ((fc (current-fill-column)))
(when (and fc (> (current-column) fc))
(let* ((fill-prefix (org-adaptive-fill-function))
;; Enforce empty fill prefix, if required. Otherwise, it
;; will be computed again.
(adaptive-fill-mode (not (equal fill-prefix ""))))
(when fill-prefix (do-auto-fill))))))
(defun org-comment-line-break-function (&optional soft)
"Break line at point and indent, continuing comment if within one.
The inserted newline is marked hard if variable
`use-hard-newlines' is true, unless optional argument SOFT is
non-nil.
This function is a simplified version of `comment-indent-new-line'
that bypasses the complex Emacs machinery dealing with comments.
We instead rely on Org parser, utilizing `org-adaptive-fill-function'"
(let ((fill-prefix (org-adaptive-fill-function)))
(if soft (insert-and-inherit ?\n) (newline 1))
(save-excursion (forward-char -1) (delete-horizontal-space))
(delete-horizontal-space)
(indent-to-left-margin)
(when fill-prefix
(insert-before-markers-and-inherit fill-prefix))))
;;; Fixed Width Areas
(defun org-toggle-fixed-width ()
"Toggle fixed-width markup.
Add or remove fixed-width markup on current line, whenever it
makes sense. Return an error otherwise.
If a region is active and if it contains only fixed-width areas
or blank lines, remove all fixed-width markup in it. If the
region contains anything else, convert all non-fixed-width lines
to fixed-width ones.
Blank lines at the end of the region are ignored unless the
region only contains such lines."
(interactive)
(if (not (org-region-active-p))
;; No region:
;;
;; Remove fixed width marker only in a fixed-with element.
;;
;; Add fixed width maker in paragraphs, in blank lines after
;; elements or at the beginning of a headline or an inlinetask,
;; and before any one-line elements (e.g., a clock).
(progn
(forward-line 0)
(let* ((element (org-element-at-point))
(type (org-element-type element)))
(cond
((and (eq type 'fixed-width)
(looking-at "[ \t]*\\(:\\(?: \\|$\\)\\)"))
(replace-match
"" nil nil nil (if (= (line-end-position) (match-end 0)) 0 1)))
((and (memq type '(babel-call clock comment diary-sexp headline
horizontal-rule keyword paragraph
planning))
(<= (org-element-post-affiliated element) (point)))
(skip-chars-forward " \t")
(insert ": "))
((and (looking-at-p "[ \t]*$")
(or (eq type 'inlinetask)
(save-excursion
(skip-chars-forward " \r\t\n")
(<= (org-element-end element) (point)))))
(delete-region (point) (line-end-position))
(org-indent-line)
(insert ": "))
(t (user-error "Cannot insert a fixed-width line here")))))
;; Region active.
(let* ((begin (save-excursion
(goto-char (region-beginning))
(line-beginning-position)))
(end (copy-marker
(save-excursion
(goto-char (region-end))
(unless (eolp) (forward-line 0))
(if (save-excursion (re-search-backward "\\S-" begin t))
(progn (skip-chars-backward " \r\t\n") (point))
(point)))))
(all-fixed-width-p
(catch 'not-all-p
(save-excursion
(goto-char begin)
(skip-chars-forward " \r\t\n")
(when (eobp) (throw 'not-all-p nil))
(while (< (point) end)
(let ((element (org-element-at-point)))
(if (org-element-type-p element 'fixed-width)
(goto-char (org-element-end element))
(throw 'not-all-p nil))))
t))))
(if all-fixed-width-p
(save-excursion
(goto-char begin)
(while (< (point) end)
(when (looking-at "[ \t]*\\(:\\(?: \\|$\\)\\)")
(replace-match
"" nil nil nil
(if (= (line-end-position) (match-end 0)) 0 1)))
(forward-line)))
(let ((min-ind (point-max)))
;; Find minimum indentation across all lines.
(save-excursion
(goto-char begin)
(if (not (save-excursion (re-search-forward "\\S-" end t)))
(setq min-ind 0)
(catch 'zerop
(while (< (point) end)
(unless (looking-at-p "[ \t]*$")
(let ((ind (org-current-text-indentation)))
(setq min-ind (min min-ind ind))
(when (zerop ind) (throw 'zerop t))))
(forward-line)))))
;; Loop over all lines and add fixed-width markup everywhere
;; but in fixed-width lines.
(save-excursion
(goto-char begin)
(while (< (point) end)
(cond
((org-at-heading-p)
(insert ": ")
(forward-line)
(while (and (< (point) end) (looking-at-p "[ \t]*$"))
(insert ":")
(forward-line)))
((looking-at-p "[ \t]*:\\( \\|$\\)")
(let* ((element (org-element-at-point))
(element-end (org-element-end element)))
(if (org-element-type-p element 'fixed-width)
(progn (goto-char element-end)
(skip-chars-backward " \r\t\n")
(forward-line))
(let ((limit (min end element-end)))
(while (< (point) limit)
(org-move-to-column min-ind t)
(insert ": ")
(forward-line))))))
(t
(org-move-to-column min-ind t)
(insert ": ")
(forward-line)))))))
(set-marker end nil))))
;;; Blocks
(defun org-block-map (function &optional start end)
"Call FUNCTION at the head of all source blocks in the current buffer.
Optional arguments START and END can be used to limit the range."
(let ((start (or start (point-min)))
(end (or end (point-max))))
(save-excursion
(goto-char start)
(while (and (< (point) end) (re-search-forward "^[ \t]*#\\+begin" end t))
(save-excursion
(save-match-data
(goto-char (match-beginning 0))
(when (org-at-block-p)
(funcall function))))))))
(defun org-next-block (arg &optional backward block-regexp)
"Jump to the next block.
With a prefix argument ARG, jump forward ARG many blocks.
When BACKWARD is non-nil, jump to the previous block.
When BLOCK-REGEXP is non-nil, use this regexp to find blocks.
Match data is set according to this regexp when the function
returns.
Return point at beginning of the opening line of found block.
Throw an error if no block is found."
(interactive "p")
(let ((re (or block-regexp "^[ \t]*#\\+BEGIN"))
(case-fold-search t)
(search-fn (if backward #'re-search-backward #'re-search-forward))
(count (or arg 1))
(origin (point))
last-element)
(if backward (forward-line 0)
(let ((inhibit-field-text-motion t)) (end-of-line)))
(while (and (> count 0) (funcall search-fn re nil t))
(let ((element (save-excursion
(goto-char (match-beginning 0))
(save-match-data (org-element-at-point)))))
(when (and (org-element-type-p
element
'(center-block comment-block dynamic-block
example-block export-block quote-block
special-block src-block verse-block))
(<= (match-beginning 0)
(org-element-post-affiliated element)))
(setq last-element element)
(cl-decf count))))
(if (= count 0)
(prog1 (goto-char (org-element-post-affiliated last-element))
(save-match-data (org-fold-show-context)))
(goto-char origin)
(user-error "No %s code blocks" (if backward "previous" "further")))))
(defun org-previous-block (arg &optional block-regexp)
"Jump to the previous block.
With a prefix argument ARG, jump backward ARG many source blocks.
When BLOCK-REGEXP is non-nil, use this regexp to find blocks."
(interactive "p")
(org-next-block arg t block-regexp))
;;; Comments
;; Org comments syntax is quite complex. It requires the entire line
;; to be just a comment. Also, even with the right syntax at the
;; beginning of line, some elements (e.g., verse-block or
;; example-block) don't accept comments. Usual Emacs comment commands
;; cannot cope with those requirements. Therefore, Org replaces them.
;; Org still relies on 'comment-dwim', but cannot trust
;; 'comment-only-p'. So, 'comment-region-function' and
;; 'uncomment-region-function' both point
;; to 'org-comment-or-uncomment-region'. Eventually,
;; 'org-insert-comment' takes care of insertion of comments at the
;; beginning of line.
;; 'org-setup-comments-handling' install comments related variables
;; during 'org-mode' initialization.
(defun org-setup-comments-handling ()
(interactive)
(setq-local comment-use-syntax nil)
(setq-local comment-start "# ")
(setq-local comment-start-skip "^\\s-*#\\(?: \\|$\\)")
(setq-local comment-insert-comment-function 'org-insert-comment)
(setq-local comment-region-function 'org-comment-or-uncomment-region)
(setq-local uncomment-region-function 'org-comment-or-uncomment-region))
(defun org-insert-comment ()
"Insert an empty comment above current line.
If the line is empty, insert comment at its beginning. When
point is within a source block, comment according to the related
major mode."
(if (let ((element (org-element-at-point)))
(and (org-element-type-p element 'src-block)
(< (save-excursion
(goto-char (org-element-post-affiliated element))
(line-end-position))
(point))
(> (save-excursion
(goto-char (org-element-end element))
(skip-chars-backward " \r\t\n")
(line-beginning-position))
(point))))
(org-babel-do-in-edit-buffer (call-interactively 'comment-dwim))
(forward-line 0)
(if (looking-at "\\s-*$") (delete-region (point) (line-end-position))
(open-line 1))
(org-indent-line)
(insert "# ")))
(defvar comment-empty-lines) ; From newcomment.el.
(defun org-comment-or-uncomment-region (beg end &rest _)
"Comment or uncomment each non-blank line in the region.
Uncomment each non-blank line between BEG and END if it only
contains commented lines. Otherwise, comment them. If region is
strictly within a source block, use appropriate comment syntax."
(if (let ((element (org-element-at-point)))
(and (org-element-type-p element 'src-block)
(< (save-excursion
(goto-char (org-element-post-affiliated element))
(line-end-position))
beg)
(>= (save-excursion
(goto-char (org-element-end element))
(skip-chars-backward " \r\t\n")
(line-beginning-position))
end)))
;; Translate region boundaries for the Org buffer to the source
;; buffer.
(let (src-end)
(save-excursion
(goto-char end)
(org-babel-do-in-edit-buffer
(setq src-end (point))))
(save-excursion
(goto-char beg)
(org-babel-do-in-edit-buffer
(comment-or-uncomment-region (point) src-end))))
(save-restriction
;; Restrict region
(narrow-to-region (save-excursion (goto-char beg)
(skip-chars-forward " \r\t\n" end)
(line-beginning-position))
(save-excursion (goto-char end)
(skip-chars-backward " \r\t\n" beg)
(line-end-position)))
(let ((uncommentp
;; UNCOMMENTP is non-nil when every non blank line between
;; BEG and END is a comment.
(save-excursion
(goto-char (point-min))
(while (and (not (eobp))
(let ((element (org-element-at-point)))
(and (org-element-type-p element 'comment)
(goto-char (min (point-max)
(org-element-property
:end element)))))))
(eobp))))
(if uncommentp
;; Only blank lines and comments in region: uncomment it.
(save-excursion
(goto-char (point-min))
(while (not (eobp))
(when (looking-at "[ \t]*\\(#\\(?: \\|$\\)\\)")
(replace-match "" nil nil nil 1))
(forward-line)))
;; Comment each line in region.
(let ((min-indent (point-max)))
;; First find the minimum indentation across all lines.
(save-excursion
(goto-char (point-min))
(while (and (not (eobp)) (not (zerop min-indent)))
(unless (looking-at "[ \t]*$")
(setq min-indent (min min-indent (org-current-text-indentation))))
(forward-line)))
;; Then loop over all lines.
(save-excursion
(goto-char (point-min))
(while (not (eobp))
(unless (and (not comment-empty-lines) (looking-at "[ \t]*$"))
;; Don't get fooled by invisible text (e.g. link path)
;; when moving to column MIN-INDENT.
(let ((buffer-invisibility-spec nil))
(org-move-to-column min-indent t))
(insert comment-start))
(forward-line)))))))))
(defun org-comment-dwim (_arg)
"Call the comment command you mean.
Call `org-toggle-comment' if on a heading, otherwise call
`comment-dwim'."
(interactive "*P")
(cond ((org-at-heading-p)
(call-interactively #'org-toggle-comment))
(t (call-interactively #'comment-dwim))))
;;; Timestamps API
;; This section contains tools to operate on, or create, timestamp
;; objects, as returned by, e.g. `org-element-context'.
(defun org-timestamp-from-string (s)
"Convert Org timestamp S, as a string, into a timestamp object.
Return nil if S is not a valid timestamp string."
(when (org-string-nw-p s)
(with-temp-buffer
(save-excursion (insert s))
(org-element-timestamp-parser))))
(defun org-timestamp-from-time (time &optional with-time inactive)
"Convert a time value into a timestamp object.
TIME is an Emacs internal time representation, as returned, e.g.,
by `current-time'.
When optional argument WITH-TIME is non-nil, return a timestamp
object with a time part, i.e., with hours and minutes.
Return an inactive timestamp if INACTIVE is non-nil. Otherwise,
return an active timestamp."
(pcase-let ((`(,_ ,minute ,hour ,day ,month ,year . ,_) (decode-time time)))
(org-element-create 'timestamp
(list :type (if inactive 'inactive 'active)
:year-start year
:month-start month
:day-start day
:hour-start (and with-time hour)
:minute-start (and with-time minute)))))
(defun org-timestamp-to-time (timestamp &optional end)
"Convert TIMESTAMP object into an Emacs internal time value.
Use end of date range or time range when END is non-nil.
Otherwise, use its start."
(org-encode-time
(append '(0)
(mapcar
(lambda (prop) (or (org-element-property prop timestamp) 0))
(if end '(:minute-end :hour-end :day-end :month-end :year-end)
'(:minute-start :hour-start :day-start :month-start
:year-start)))
'(nil -1 nil))))
(defun org-timestamp-has-time-p (timestamp)
"Non-nil when TIMESTAMP has a time specified."
(org-element-property :hour-start timestamp))
(defun org-format-timestamp (timestamp format &optional end utc)
"Format a TIMESTAMP object into a string.
FORMAT is a format specifier to be passed to
`format-time-string'.
When optional argument END is non-nil, use end of date-range or
time-range, if possible.
When optional argument UTC is non-nil, time is be expressed as
Universal Time."
(format-time-string format (org-timestamp-to-time timestamp end)
(and utc t)))
(defun org-timestamp-split-range (timestamp &optional end)
"Extract a TIMESTAMP object from a date or time range.
END, when non-nil, means extract the end of the range.
Otherwise, extract its start.
Return a new timestamp object."
(let ((type (org-element-property :type timestamp)))
(if (memq type '(active inactive diary)) timestamp
(let ((split-ts (org-element-copy timestamp)))
;; Set new type.
(org-element-put-property
split-ts :type (if (eq type 'active-range) 'active 'inactive))
(org-element-put-property split-ts :range-type nil)
;; Copy start properties over end properties if END is
;; non-nil. Otherwise, copy end properties over `start' ones.
(let ((p-alist '((:minute-start . :minute-end)
(:hour-start . :hour-end)
(:day-start . :day-end)
(:month-start . :month-end)
(:year-start . :year-end))))
(dolist (p-cell p-alist)
(org-element-put-property
split-ts
(funcall (if end #'car #'cdr) p-cell)
(org-element-property
(funcall (if end #'cdr #'car) p-cell) split-ts)))
;; Eventually refresh `:raw-value'.
(org-element-put-property split-ts :raw-value nil)
(org-element-put-property
split-ts :raw-value (org-element-interpret-data split-ts)))))))
(defun org-timestamp-translate (timestamp &optional boundary)
"Translate TIMESTAMP object to custom format.
Format string is defined in `org-timestamp-custom-formats',
which see.
When optional argument BOUNDARY is non-nil, it is either the
symbol `start' or `end'. In this case, only translate the
starting or ending part of TIMESTAMP if it is a date or time
range. Otherwise, translate both parts.
Return timestamp as-is if `org-display-custom-times' is nil or if
it has a `diary' type."
(let ((type (org-element-property :type timestamp)))
(if (or (not org-display-custom-times) (eq type 'diary))
(org-element-interpret-data timestamp)
(let ((fmt (org-time-stamp-format
(org-timestamp-has-time-p timestamp) nil 'custom)))
(if (and (not boundary) (memq type '(active-range inactive-range)))
(concat (org-format-timestamp timestamp fmt)
"--"
(org-format-timestamp timestamp fmt t))
(org-format-timestamp timestamp fmt (eq boundary 'end)))))))
;;; Yank media handler and DND
(defun org-setup-yank-dnd-handlers ()
"Setup the `yank-media' and DND handlers for buffer."
(let ((handler (if (>= emacs-major-version 30)
#'org--dnd-multi-local-file-handler
#'org--dnd-local-file-handler)))
(setq-local dnd-protocol-alist
(append
(list (cons "^file:///" handler)
(cons "^file:/[^/]" handler)
(cons "^file:[^/]" handler))
dnd-protocol-alist)))
(when (fboundp 'yank-media-handler)
(yank-media-handler "image/.*" #'org--image-yank-media-handler)
;; Looks like different DEs go for different handler names,
;; https://larsee.com/blog/2019/05/clipboard-files/.
(yank-media-handler "x/special-\\(?:gnome\\|KDE\\|mate\\)-files"
#'org--copied-files-yank-media-handler))
(when (boundp 'x-dnd-direct-save-function)
(setq-local x-dnd-direct-save-function #'org--dnd-xds-function)))
(defcustom org-yank-image-save-method 'attach
"Method to save images yanked from clipboard and dropped to Emacs.
It can be the symbol `attach' to add it as an attachment, or a
directory name to copy/cut the image to that directory."
:group 'org
:package-version '(Org . "9.7")
:type '(choice (const :tag "Add it as attachment" attach)
(directory :tag "Save it in directory"))
:safe (lambda (x) (eq x 'attach)))
(defcustom org-yank-image-file-name-function #'org-yank-image-autogen-filename
"Function to generate filename for image yanked from clipboard.
By default, this autogenerates a filename based on the current
time.
It is called with no arguments and should return a string without
any extension which is used as the filename."
:group 'org
:package-version '(Org . "9.7")
:type '(radio (function-item :doc "Autogenerate filename"
org-yank-image-autogen-filename)
(function-item :doc "Ask for filename"
org-yank-image-read-filename)
function))
(defun org-yank-image-autogen-filename ()
"Autogenerate filename for image in clipboard."
(format-time-string "clipboard-%Y%m%dT%H%M%S.%6N"))
(defun org-yank-image-read-filename ()
"Read filename for image in clipboard."
(read-string "Basename for image file without extension: "))
(declare-function org-attach-attach "org-attach" (file &optional visit-dir method))
(defun org--image-yank-media-handler (mimetype data)
"Save image DATA of mime-type MIMETYPE and insert link at point.
It is saved as per `org-yank-image-save-method'. The name for the
image is prompted and the extension is automatically added to the
end."
(cl-assert (fboundp 'mailcap-mime-type-to-extension)) ; Emacs >=29
(cl-assert (fboundp 'file-name-with-extension)) ; Emacs >=28
(let* ((ext (symbol-name
(with-no-warnings ; Suppress warning in Emacs <29
(mailcap-mime-type-to-extension mimetype))))
(iname (funcall org-yank-image-file-name-function))
(filename (with-no-warnings ; Suppress warning in Emacs <28
(file-name-with-extension iname ext)))
(absname (expand-file-name
filename
(if (eq org-yank-image-save-method 'attach)
temporary-file-directory
org-yank-image-save-method)))
link)
(when (and (not (eq org-yank-image-save-method 'attach))
(not (file-directory-p org-yank-image-save-method)))
(make-directory org-yank-image-save-method t))
;; DATA is a raw image. Tell Emacs to write it raw, without
;; trying to auto-detect the coding system.
(let ((coding-system-for-write 'emacs-internal))
(with-temp-file absname
(insert data)))
(if (null (eq org-yank-image-save-method 'attach))
(setq link (org-link-make-string (concat "file:" (file-relative-name absname))))
(require 'org-attach)
(org-attach-attach absname nil 'mv)
(setq link (org-link-make-string (concat "attachment:" filename))))
(insert link)))
;; I cannot find a spec for this but
;; https://indigo.re/posts/2021-12-21-clipboard-data.html and pcmanfm
;; suggests that this is the format.
(defun org--copied-files-yank-media-handler (_mimetype data)
"Handle copied or cut files from file manager.
They are handled as per `org-yank-dnd-method'.
DATA is a string where the first line is the operation to
perform: copy or cut. Rest of the lines are file: links to the
concerned files."
;; pcmanfm adds a null byte at the end for some reason.
(let* ((data (split-string data "[\0\n\r]" t))
(files (cdr data))
(action (if (equal (car data) "cut")
'copy
'move))
(sep (if (= (length files) 1) "" " ")))
(dolist (f files)
(if (file-readable-p f)
(org--dnd-local-file-handler f action sep)
(message "File `%s' is not readable, skipping" f)))))
(defcustom org-yank-dnd-method 'ask
"Action to perform on the dropped and the pasted files.
When the value is the symbol,
. `attach' -- attach dropped/pasted file
. `open' -- visit/open dropped/pasted file in Emacs
. `file-link' -- insert file: link to dropped/pasted file
. `ask' -- ask what to do out of the above."
:group 'org
:package-version '(Org . "9.7")
:type '(choice (const :tag "Attach" attach)
(const :tag "Open/Visit file" open)
(const :tag "Insert file: link" file-link)
(const :tag "Ask what to do" ask)))
(defcustom org-yank-dnd-default-attach-method nil
"Default attach method to use when DND action is unspecified.
This attach method is used when the DND action is `private'.
This is also used when `org-yank-image-save-method' is nil.
When nil, use `org-attach-method'."
:group 'org
:package-version '(Org . "9.7")
:type '(choice (const :tag "Default attach method" nil)
(const :tag "Copy" cp)
(const :tag "Move" mv)
(const :tag "Hard link" ln)
(const :tag "Symbolic link" lns)))
(declare-function mailcap-file-name-to-mime-type "mailcap" (file-name))
(defvar org-attach-method)
(defun org--dnd-rmc (prompt choices)
"Display a menu or dialog and select with PROMPT among CHOICES.
PROMPT is the prompt string. CHOICES is a list of choices. Each
choice is a list of (key description value). VALUE from the selected
choice is returned."
(if (null (and
;; Emacs <=28 does not have `use-dialog-box-p'.
(fboundp 'use-dialog-box-p)
(use-dialog-box-p)))
(progn
(setq choices
(mapcar
(pcase-lambda (`(,key ,message ,val))
;; `read-multiple-choice' expects VAL to be a long
;; description of the choice - string or nil. Move VAL
;; further, so that it is not seen by the extended
;; help in `read-multiple-choice'.
(list key message nil val))
choices))
(nth 3 (read-multiple-choice prompt choices)))
(setq choices
(mapcar
(pcase-lambda (`(_key ,message ,val))
(cons (capitalize message) val))
choices))
(x-popup-menu t (list prompt (cons "" choices)))))
(defun org--dnd-multi-local-file-handler (urls action)
"Handle file URLS as per ACTION.
URLS is a list of file URL."
(let ((sep (if (= (length urls) 1) "" " ")))
(dolist (u urls)
(org--dnd-local-file-handler u action sep))))
(put 'org--dnd-multi-local-file-handler 'dnd-multiple-handler t)
(defun org--dnd-local-file-handler (url action &optional separator)
"Handle file URL as per ACTION.
SEPARATOR is the string to insert after each link. It may be nil
in which case, space is inserted."
(unless separator
(setq separator " "))
(let ((method (if (eq org-yank-dnd-method 'ask)
(org--dnd-rmc
"What to do with file?"
'((?a "attach" attach)
(?o "open" open)
(?f "insert file: link" file-link)))
org-yank-dnd-method)))
(pcase method
(`attach (org--dnd-attach-file url action separator))
(`open (dnd-open-local-file url action))
(`file-link
(let ((filename (dnd-get-local-file-name url)))
(insert (org-link-make-string (concat "file:" filename)) separator))))))
(defun org--dnd-attach-file (url action separator)
"Attach filename given by URL using method pertaining to ACTION.
If ACTION is `move', use `mv' attach method.
If `copy', use `cp' attach method.
If `ask', ask the user.
If `private', use the method denoted in `org-yank-dnd-default-attach-method'.
The action `private' is always returned.
SEPARATOR is the string to insert after each link."
(require 'mailcap)
(require 'org-attach)
(let* ((filename (dnd-get-local-file-name url))
(mimetype (mailcap-file-name-to-mime-type filename))
(separatep (and (string-prefix-p "image/" mimetype)
(not (eq 'attach org-yank-image-save-method))))
(method (pcase action
('copy 'cp)
('move 'mv)
('ask (org--dnd-rmc
"Attach using method"
'((?c "copy" cp)
(?m "move" mv)
(?l "hard link" ln)
(?s "symbolic link" lns))))
('private (or org-yank-dnd-default-attach-method
org-attach-method)))))
(if separatep
(progn
(unless (file-directory-p org-yank-image-save-method)
(make-directory org-yank-image-save-method t))
(funcall
(pcase method
('cp #'copy-file)
('mv #'rename-file)
('ln #'add-name-to-file)
('lns #'make-symbolic-link))
filename
(expand-file-name (file-name-nondirectory filename)
org-yank-image-save-method)))
(org-attach-attach filename nil method))
(insert
(org-link-make-string
(concat (if separatep
"file:"
"attachment:")
(if separatep
(expand-file-name (file-name-nondirectory filename)
org-yank-image-save-method)
(file-name-nondirectory filename))))
separator)
'private))
(defvar-local org--dnd-xds-method nil
"The method to use for dropped file.")
(defun org--dnd-xds-function (need-name filename)
"Handle file with FILENAME dropped via XDS protocol.
When NEED-NAME is t, FILENAME is the base name of the file to be
saved.
When NEED-NAME is nil, the drop is complete."
(if need-name
(let ((method (if (eq org-yank-dnd-method 'ask)
(org--dnd-rmc
"What to do with dropped file?"
'((?a "attach" attach)
(?o "open" open)
(?f "insert file: link" file-link)))
org-yank-dnd-method)))
(setq-local org--dnd-xds-method method)
(pcase method
(`attach (expand-file-name filename (org-attach-dir 'create)))
(`open (expand-file-name (make-temp-name "emacs.") temporary-file-directory))
(`file-link (read-file-name "Write file to: " nil nil nil filename))))
(pcase org--dnd-xds-method
(`attach (insert (org-link-make-string
(concat "attachment:" (file-name-nondirectory filename)))))
(`file-link (insert (org-link-make-string (concat "file:" filename))))
(`open (find-file filename)))
(setq-local org--dnd-xds-method nil)))
;;; Other stuff
(defvar reftex-docstruct-symbol)
(defvar org--rds)
(defun org-reftex-citation ()
"Use `reftex-citation' to insert a citation into the buffer.
This looks for a line like
#+BIBLIOGRAPHY: foo plain option:-d
and derives from it that foo.bib is the bibliography file relevant
for this document. It then installs the necessary environment for RefTeX
to work in this buffer and calls `reftex-citation' to insert a citation
into the buffer.
Export of such citations to both LaTeX and HTML is handled by the contributed
package ox-bibtex by Taru Karttunen."
(interactive)
(let ((reftex-docstruct-symbol 'org--rds)
org--rds bib)
(org-with-wide-buffer
(let ((case-fold-search t)
(re "^[ \t]*#\\+BIBLIOGRAPHY:[ \t]+\\([^ \t\n]+\\)"))
(if (not (save-excursion
(or (re-search-forward re nil t)
(re-search-backward re nil t))))
(user-error "No bibliography defined in file")
(setq bib (concat (match-string 1) ".bib")
org--rds (list (list 'bib bib))))))
(call-interactively 'reftex-citation)))
;;;; Functions extending outline functionality
(defun org-beginning-of-line (&optional n)
"Go to the beginning of the current visible line.
If this is a headline, and `org-special-ctrl-a/e' is not nil or
symbol `reversed', on the first attempt move to where the
headline text starts, and only move to beginning of line when the
cursor is already before the start of the text of the headline.
If `org-special-ctrl-a/e' is symbol `reversed' then go to the
start of the text on the second attempt.
With argument N not nil or 1, move forward N - 1 lines first."
(interactive "^p")
(let ((origin (point))
(special (pcase org-special-ctrl-a/e
(`(,C-a . ,_) C-a) (_ org-special-ctrl-a/e)))
deactivate-mark)
;; First move to a visible line.
(if (bound-and-true-p visual-line-mode)
(beginning-of-visual-line n)
(move-beginning-of-line n)
;; `move-beginning-of-line' may leave point after invisible
;; characters if line starts with such of these (e.g., with
;; a link at column 0). Really move to the beginning of the
;; current visible line.
(forward-line 0))
(cond
;; No special behavior. Point is already at the beginning of
;; a line, logical or visual.
((not special))
;; `beginning-of-visual-line' left point before logical beginning
;; of line: point is at the beginning of a visual line. Bail
;; out.
((and (bound-and-true-p visual-line-mode) (not (bolp))))
((let ((case-fold-search nil)) (looking-at org-complex-heading-regexp))
;; At a headline, special position is before the title, but
;; after any TODO keyword or priority cookie.
(let ((refpos (min (1+ (or (match-end 3) (match-end 2) (match-end 1)))
(line-end-position)))
(bol (point)))
(if (eq special 'reversed)
(when (and (= origin bol) (eq last-command this-command))
(goto-char refpos))
(when (or (> origin refpos) (<= origin bol))
(goto-char refpos)))))
((and (looking-at org-list-full-item-re)
(org-element-type-p
(save-match-data (org-element-at-point))
'(item plain-list)))
;; Set special position at first white space character after
;; bullet, and check-box, if any.
(let ((after-bullet
(let ((box (match-end 3)))
(cond ((not box) (match-end 1))
((eq (char-after box) ?\s) (1+ box))
(t box)))))
(if (eq special 'reversed)
(when (and (= (point) origin) (eq last-command this-command))
(goto-char after-bullet))
(when (or (> origin after-bullet) (>= (point) origin))
(goto-char after-bullet)))))
;; No special context. Point is already at beginning of line.
(t nil))))
(defun org-end-of-line (&optional n)
"Go to the end of the line, but before ellipsis, if any.
If this is a headline, and `org-special-ctrl-a/e' is not nil or
symbol `reversed', ignore tags on the first attempt, and only
move to after the tags when the cursor is already beyond the end
of the headline.
If `org-special-ctrl-a/e' is symbol `reversed' then ignore tags
on the second attempt.
With argument N not nil or 1, move forward N - 1 lines first."
(interactive "^p")
(let ((origin (point))
(special (pcase org-special-ctrl-a/e
(`(,_ . ,C-e) C-e) (_ org-special-ctrl-a/e)))
deactivate-mark)
;; First move to a visible line.
(if (bound-and-true-p visual-line-mode)
(beginning-of-visual-line n)
(move-beginning-of-line n))
(cond
;; At a headline, with tags.
((and special
(save-excursion
(forward-line 0)
(let ((case-fold-search nil))
(looking-at org-complex-heading-regexp)))
(match-end 5))
(let ((tags (save-excursion
(goto-char (match-beginning 5))
(skip-chars-backward " \t")
(point)))
(visual-end (and (bound-and-true-p visual-line-mode)
(save-excursion
(end-of-visual-line)
(point)))))
;; If `end-of-visual-line' brings us before end of line or
;; even tags, i.e., the headline spans over multiple visual
;; lines, move there.
(cond ((and visual-end
(< visual-end tags)
(<= origin visual-end))
(goto-char visual-end))
((eq special 'reversed)
(if (and (= origin (line-end-position))
(eq this-command last-command))
(goto-char tags)
(end-of-line)))
(t
(if (or (< origin tags) (>= origin (line-end-position)))
(goto-char tags)
(end-of-line))))))
((bound-and-true-p visual-line-mode)
(let ((bol (line-beginning-position)))
(end-of-visual-line)
;; If `end-of-visual-line' gets us past the ellipsis at the
;; end of a line, backtrack and use `end-of-line' instead.
(when (/= bol (line-beginning-position))
(goto-char bol)
(end-of-line))))
(t (end-of-line)))))
(defun org-backward-sentence (&optional _arg)
"Go to beginning of sentence, or beginning of table field.
This will call `backward-sentence' or `org-table-beginning-of-field',
depending on context."
(interactive)
(let* ((element (org-element-at-point))
(contents-begin (org-element-contents-begin element))
(table (org-element-lineage element 'table t)))
(if (and table
(> (point) contents-begin)
(<= (point) (org-element-contents-end table)))
(call-interactively #'org-table-beginning-of-field)
(save-restriction
(when (and contents-begin
(< (point-min) contents-begin)
(> (point) contents-begin))
(narrow-to-region contents-begin
(org-element-contents-end element)))
(call-interactively #'backward-sentence)))))
(defun org-forward-sentence (&optional _arg)
"Go to end of sentence, or end of table field.
This will call `forward-sentence' or `org-table-end-of-field',
depending on context."
(interactive)
(if (and (org-at-heading-p)
(save-restriction (skip-chars-forward " \t") (not (eolp))))
(save-restriction
(narrow-to-region (line-beginning-position) (line-end-position))
(call-interactively #'forward-sentence))
(let* ((element (org-element-at-point))
(contents-end (org-element-contents-end element))
(table (org-element-lineage element 'table t)))
(if (and table
(>= (point) (org-element-contents-begin table))
(< (point) contents-end))
(call-interactively #'org-table-end-of-field)
(save-restriction
(when (and contents-end
(> (point-max) contents-end)
;; Skip blank lines between elements.
(< (org-element-end element)
(save-excursion (goto-char contents-end)
(skip-chars-forward " \r\t\n"))))
(narrow-to-region (org-element-contents-begin element)
contents-end))
;; End of heading is considered as the end of a sentence.
(let ((sentence-end (concat (sentence-end) "\\|^\\*+ .*$")))
(call-interactively #'forward-sentence)))))))
(defun org-kill-line (&optional _arg)
"Kill line, to tags or end of line.
The behavior of this command depends on the user options
`org-special-ctrl-k' and `org-ctrl-k-protect-subtree' (which
see)."
(interactive)
(cond
((or (not org-special-ctrl-k)
(bolp)
(not (org-at-heading-p)))
(when (and (org-invisible-p (line-end-position))
org-ctrl-k-protect-subtree
(or (eq org-ctrl-k-protect-subtree 'error)
(not (y-or-n-p "Kill hidden subtree along with headline? "))))
(user-error
(substitute-command-keys
"`\\[org-kill-line]' aborted as it would kill a hidden subtree")))
(call-interactively
(if (bound-and-true-p visual-line-mode) 'kill-visual-line 'kill-line)))
((org-match-line org-tag-line-re)
(let ((end (save-excursion
(goto-char (match-beginning 1))
(skip-chars-backward " \t")
(point))))
(if (<= end (point)) ;on tags part
(kill-region (point) (line-end-position))
(kill-region (point) end)))
;; Only align tags when we are still on a heading:
(if (and (org-at-heading-p) org-auto-align-tags) (org-align-tags)))
(t (kill-region (point) (line-end-position)))))
(defun org-yank (&optional arg)
"Yank. If the kill is a subtree, treat it specially.
This command will look at the current kill and check if is a single
subtree, or a series of subtrees[1]. If it passes the test, and if the
cursor is at the beginning of a line or after the stars of a currently
empty headline, then the yank is handled specially. How exactly depends
on the value of the following variables.
`org-yank-folded-subtrees'
By default, this variable is non-nil, which results in
subtree(s) being folded after insertion, except if doing so
would swallow text after the yanked text.
`org-yank-adjusted-subtrees'
When non-nil (the default value is nil), the subtree will be
promoted or demoted in order to fit into the local outline tree
structure, which means that the level will be adjusted so that it
becomes the smaller one of the two *visible* surrounding headings.
Any prefix to this command will cause `yank' to be called directly with
no special treatment. In particular, a simple `\\[universal-argument]' prefix \
will just
plainly yank the text as it is.
\[1] The test checks if the first non-white line is a heading
and if there are no other headings with fewer stars."
(interactive "P")
(org-yank-generic 'yank arg))
(defun org-yank-generic (command arg)
"Perform some yank-like command.
This function implements the behavior described in the `org-yank'
documentation. However, it has been generalized to work for any
interactive command with similar behavior."
;; pretend to be command COMMAND
(setq this-command command)
(if arg
(call-interactively command)
(let ((subtreep ; is kill a subtree, and the yank position appropriate?
(and (org-kill-is-subtree-p)
(or (bolp)
(and (looking-at "[ \t]*$")
(string-match
"\\`\\*+\\'"
(buffer-substring (line-beginning-position) (point)))))))
swallowp)
(cond
((and subtreep org-yank-folded-subtrees)
(let ((beg (point))
end)
(if (and subtreep org-yank-adjusted-subtrees)
(org-paste-subtree nil nil 'for-yank)
(call-interactively command))
(setq end (point))
(goto-char beg)
(when (and (bolp) subtreep
(not (setq swallowp
(org-yank-folding-would-swallow-text beg end))))
(org-with-limited-levels
(or (looking-at org-outline-regexp)
(re-search-forward org-outline-regexp-bol end t))
(while (and (< (point) end) (looking-at org-outline-regexp))
(org-fold-subtree t)
(org-cycle-show-empty-lines 'folded)
(condition-case nil
(outline-forward-same-level 1)
(error (goto-char end))))))
(when swallowp
(message
"Inserted text not folded because that would swallow text"))
(goto-char end)
(skip-chars-forward " \t\n\r")
(forward-line 0)
(push-mark beg 'nomsg)))
((and subtreep org-yank-adjusted-subtrees)
(let ((beg (line-beginning-position)))
(org-paste-subtree nil nil 'for-yank)
(push-mark beg 'nomsg)))
(t
(call-interactively command))))))
(defun org-yank-folding-would-swallow-text (beg end)
"Would `hide-subtree' at BEG swallow any text after END?"
(let (level)
(org-with-limited-levels
(save-excursion
(goto-char beg)
(when (or (looking-at org-outline-regexp)
(re-search-forward org-outline-regexp-bol end t))
(setq level (org-outline-level)))
(goto-char end)
(skip-chars-forward " \t\r\n\v\f")
(not (or (eobp)
(and (bolp) (looking-at-p org-outline-regexp)
(<= (org-outline-level) level))))))))
(defun org-back-to-heading (&optional invisible-ok)
"Go back to beginning of heading or inlinetask."
(forward-line 0)
(or (and (org-at-heading-p (not invisible-ok))
(not (and (featurep 'org-inlinetask)
(fboundp 'org-inlinetask-end-p)
(org-inlinetask-end-p))))
(unless
(org-element-lineage-map
(org-element-at-point)
(lambda (el)
(goto-char (org-element-begin el))
(or invisible-ok (not (org-fold-folded-p))))
'(headline inlinetask)
'with-self 'first-match)
(user-error "Before first headline at position %d in buffer %s"
(point) (current-buffer))))
(point))
(defun org-back-to-heading-or-point-min (&optional invisible-ok)
"Go back to heading or first point in buffer.
If point is before first heading go to first point in buffer
instead of back to heading."
(if (org-before-first-heading-p)
(goto-char (point-min))
(org-back-to-heading invisible-ok)))
(defun org-before-first-heading-p ()
"Before first heading?
Respect narrowing."
(let ((cached (org-element-at-point nil 'cached)))
(if cached
(let ((cached-headline (org-element-lineage cached 'headline t)))
(or (not cached-headline)
(< (org-element-begin cached-headline) (point-min))))
(org-with-limited-levels
(save-excursion
(end-of-line)
(null (re-search-backward org-outline-regexp-bol nil t)))))))
(defun org-at-heading-p (&optional invisible-not-ok)
"Return t if point is on a (possibly invisible) heading line.
If INVISIBLE-NOT-OK is non-nil, an invisible heading line is not ok."
(save-excursion
(forward-line 0)
(and (or (not invisible-not-ok) (not (org-fold-folded-p)))
(looking-at outline-regexp))))
(defun org-in-commented-heading-p (&optional no-inheritance element)
"Non-nil if point is under a commented heading.
This function also checks ancestors of the current headline,
unless optional argument NO-INHERITANCE is non-nil.
Optional argument ELEMENT contains element at point."
(unless element
(setq
element
(org-element-lineage
(org-element-at-point)
'(headline inlinetask) 'with-self)))
(if no-inheritance
(org-element-property :commentedp element)
(org-element-property-inherited :commentedp element 'with-self)))
(defun org-in-archived-heading-p (&optional no-inheritance element)
"Non-nil if point is under an archived heading.
This function also checks ancestors of the current headline,
unless optional argument NO-INHERITANCE is non-nil.
Optional argument ELEMENT contains element at point."
(unless element
(setq
element
(org-element-lineage
(org-element-at-point)
'(headline inlinetask) 'with-self)))
(if no-inheritance
(org-element-property :archivedp element)
(org-element-property-inherited :archivedp element 'with-self)))
(defun org-at-comment-p nil
"Return t if cursor is in a commented line."
(save-excursion
(save-match-data
(forward-line 0)
(looking-at org-comment-regexp))))
(defun org-at-keyword-p nil
"Return t if cursor is at a keyword-line."
(save-excursion
(move-beginning-of-line 1)
(looking-at org-keyword-regexp)))
(defun org-at-drawer-p nil
"Return t if cursor is at a drawer keyword."
(save-excursion
(move-beginning-of-line 1)
(looking-at org-drawer-regexp)))
(defun org-at-block-p nil
"Return t if cursor is at a block keyword."
(save-excursion
(move-beginning-of-line 1)
(looking-at org-block-regexp)))
(defun org-point-at-end-of-empty-headline ()
"If point is at the end of an empty headline, return t, else nil.
If the heading only contains a TODO keyword, it is still considered
empty."
(let ((case-fold-search nil))
(and (looking-at "[ \t]*$")
org-todo-line-regexp
(save-excursion
(forward-line 0)
(looking-at org-todo-line-regexp)
(string= (match-string 3) "")))))
(defun org-at-heading-or-item-p ()
(or (org-at-heading-p) (org-at-item-p)))
(defun org-up-heading-all (arg)
"Move to the heading line of which the present line is a subheading.
This function considers both visible and invisible heading lines.
With argument, move up ARG levels."
(outline-up-heading arg t))
(defun org-up-heading-safe ()
"Move to the heading line of which the present line is a subheading.
Return the true heading level, as number or nil when there is no such
heading.
When point is not at heading, go to the parent of the current heading.
When point is at or inside an inlinetask, go to the containing
heading.
This version will not throw an error. It will return the true level
of the headline found, or nil if no higher level is found.
When no higher level is found, the still move point to the containing
heading, if there is any in the accessible portion of the buffer.
When narrowing is in effect, ignore headings starting before the
available portion of the buffer."
(let* ((current-heading (org-element-lineage
(org-element-at-point)
'(headline inlinetask)
'with-self))
(parent (org-element-lineage current-heading 'headline)))
(if (and parent
(<= (point-min) (org-element-begin parent)))
(progn
(goto-char (org-element-begin parent))
(org-element-property :true-level parent))
(when (and current-heading
(<= (point-min) (org-element-begin current-heading)))
(goto-char (org-element-begin current-heading))
nil))))
(defun org-up-heading-or-point-min ()
"Move to the heading line of which the present is a subheading, or point-min.
This version is needed to make point-min behave like a virtual
heading of level 0 for property-inheritance. It will return the
level of the headline found (down to 0) or nil if already at a
point before the first headline or at point-min."
(when (ignore-errors (org-back-to-heading t))
(if (< 1 (funcall outline-level))
(or (org-up-heading-safe)
;; The first heading may not be level 1 heading.
(goto-char (point-min)))
(unless (= (point) (point-min)) (goto-char (point-min))))))
(defun org-first-sibling-p ()
"Is this heading the first child of its parents?"
(let ((re org-outline-regexp-bol)
level l)
(unless (org-at-heading-p t)
(user-error "Not at a heading"))
(setq level (funcall outline-level))
(save-excursion
(if (not (re-search-backward re nil t))
t
(setq l (funcall outline-level))
(< l level)))))
(defun org-goto-sibling (&optional previous)
"Goto the next sibling heading, even if it is invisible.
When PREVIOUS is set, go to the previous sibling instead. Returns t
when a sibling was found. When none is found, return nil and don't
move point."
(let ((fun (if previous 're-search-backward 're-search-forward))
(pos (point))
(re org-outline-regexp-bol)
level l)
(when (ignore-errors (org-back-to-heading t))
(when (org-element-type-p (org-element-at-point) 'inlinetask)
(org-up-heading-safe))
(setq level (funcall outline-level))
(catch 'exit
(or previous (forward-char 1))
(while (funcall fun re nil t)
(setq l (funcall outline-level))
(when (< l level) (goto-char pos) (throw 'exit nil))
(when (= l level) (goto-char (match-beginning 0)) (throw 'exit t)))
(goto-char pos)
nil))))
(defun org-goto-first-child (&optional element)
"Goto the first child, even if it is invisible.
Return t when a child was found. Otherwise don't move point and
return nil."
(let ((heading (org-element-lineage
(or element (org-element-at-point))
'(headline inlinetask org-data)
'with-self)))
(when heading
(unless (or (org-element-type-p heading 'inlinetask)
(not (org-element-contents-begin heading)))
(let ((pos (point)))
(goto-char (org-element-contents-begin heading))
(if (re-search-forward
org-outline-regexp-bol
(org-element-end heading)
t)
(progn (goto-char (match-beginning 0)) t)
(goto-char pos) nil))))))
(defun org-get-next-sibling ()
"Move to next heading of the same level, and return point.
If there is no such heading, return nil.
This is like outline-next-sibling, but invisible headings are ok."
(let ((level (funcall outline-level)))
(outline-next-heading)
(while (and (not (eobp)) (> (funcall outline-level) level))
(outline-next-heading))
(unless (or (eobp) (< (funcall outline-level) level))
(point))))
(defun org-get-previous-sibling ()
"Move to previous heading of the same level, and return point.
If there is no such heading, return nil."
(let ((opoint (point))
(level (funcall outline-level)))
(outline-previous-heading)
(when (and (/= (point) opoint) (outline-on-heading-p t))
(while (and (> (funcall outline-level) level)
(not (bobp)))
(outline-previous-heading))
(unless (< (funcall outline-level) level)
(point)))))
(defun org-end-of-subtree (&optional invisible-ok to-heading element)
"Goto to the end of a visible subtree at point or ELEMENT and return point.
The subtree is considered at first heading parent containing point or
ELEMENT.
When end of the subtree has blank lines, move point before these blank
lines.
When INVISIBLE-OK is non-nil, ignore visibility.
When before first heading, goto `point-max' minus blank lines.
When TO-HEADING is non-nil, go to the next heading or `point-max'."
(when element
(setq element (org-element-lineage
element
'(headline)
'include-self))
(goto-char (org-element-begin element)))
(unless (and invisible-ok element)
(org-back-to-heading-or-point-min invisible-ok)
(setq element
(org-element-lineage
(org-element-at-point)
'(headline)
'include-self)))
(if (org-element-type-p element 'headline)
(goto-char (org-element-end element))
(goto-char (point-max)))
(unless to-heading
(when (memq (preceding-char) '(?\n ?\^M))
;; Go to end of line before heading
(forward-char -1)
;; Skip blank lines
(skip-chars-backward "\n\r\t ")))
(point))
(defun org-end-of-meta-data (&optional full)
"Skip planning line and properties drawer in current entry.
When optional argument FULL is t, also skip planning information,
clocking lines, any kind of drawer, and blank lines
When FULL is non-nil but not t, skip planning information,
properties, clocking lines, logbook drawers, and blank lines."
(org-back-to-heading t)
(forward-line)
;; Skip planning information.
(when (looking-at-p org-planning-line-re) (forward-line))
;; Skip property drawer.
(when (looking-at org-property-drawer-re)
(goto-char (match-end 0))
(forward-line))
;; When FULL is not nil, skip more.
(when (and full (not (org-at-heading-p)))
(catch 'exit
(let ((end (save-excursion (outline-next-heading) (point)))
(re (concat "[ \t]*$" "\\|" org-clock-line-re)))
(while (not (eobp))
(cond ;; Skip clock lines and blank lines.
((looking-at-p re) (forward-line))
;; Skip logbook drawer.
((looking-at-p org-logbook-drawer-re)
(if (re-search-forward "^[ \t]*:END:[ \t]*$" end t)
(forward-line)
(throw 'exit t)))
;; When FULL is t, skip regular drawer too.
((and (eq full t) (looking-at-p org-drawer-regexp))
(if (re-search-forward "^[ \t]*:END:[ \t]*$" end t)
(forward-line)
(throw 'exit t)))
(t (throw 'exit t))))))))
(defun org--line-fully-invisible-p ()
"Return non-nil if the current line is fully invisible."
(let ((line-beg (line-beginning-position))
(line-pos (1- (line-end-position)))
(is-invisible t))
(while (and (< line-beg line-pos) is-invisible)
(setq is-invisible (org-invisible-p line-pos))
(setq line-pos (1- line-pos)))
is-invisible))
(defun org-forward-heading-same-level (arg &optional invisible-ok)
"Move forward to the ARG'th subheading at same level as this one.
Stop at the first and last subheadings of a superior heading.
Normally this only looks at visible headings, but when INVISIBLE-OK is
non-nil it will also look at invisible ones."
(interactive "p")
(let ((backward? (and arg (< arg 0))))
(if (org-before-first-heading-p)
(if backward? (goto-char (point-min)) (outline-next-heading))
(org-back-to-heading invisible-ok)
(unless backward? (end-of-line)) ;do not match current headline
(let ((level (org-current-level))
(f (if backward? #'re-search-backward #'re-search-forward))
(count (if arg (abs arg) 1))
(result (point)))
(while (and (> count 0)
(funcall f org-outline-regexp-bol nil 'move))
(let ((l (- (match-end 0) (match-beginning 0) 1)))
(cond ((< l level) (setq count 0))
((and (= l level)
(or invisible-ok
;; FIXME: See commit a700fadd72 and the
;; related discussion on why using
;; `org--line-fully-invisible-p' is needed
;; here, which is to serve the needs of an
;; external package. If the change is
;; wrong regarding Org itself, it should
;; be removed.
(not (org--line-fully-invisible-p))))
(cl-decf count)
(when (= l level) (setq result (point)))))))
(goto-char result))
(forward-line 0))))
(defun org-backward-heading-same-level (arg &optional invisible-ok)
"Move backward to the ARG'th subheading at same level as this one.
Stop at the first and last subheadings of a superior heading."
(interactive "p")
(org-forward-heading-same-level (if arg (- arg) -1) invisible-ok))
(defun org-next-visible-heading (arg)
"Move to the next visible heading line.
With ARG, repeats or can move backward if negative."
(interactive "p")
(let ((regexp (concat "^" (org-get-limited-outline-regexp))))
(if (< arg 0)
(forward-line 0)
(end-of-line))
(while (and (< arg 0) (re-search-backward regexp nil :move))
(unless (bobp)
(when (org-invisible-p nil t)
(goto-char (org-fold-previous-visibility-change))
(unless (looking-at-p regexp)
(re-search-backward regexp nil :mode))))
(cl-incf arg))
(while (and (> arg 0) (re-search-forward regexp nil :move))
(when (org-invisible-p nil t)
(goto-char (org-fold-next-visibility-change))
(skip-chars-forward " \t\n")
(end-of-line))
(cl-decf arg))
(if (> arg 0) (goto-char (point-max)) (forward-line 0))))
(defun org-previous-visible-heading (arg)
"Move to the previous visible heading.
With ARG, repeats or can move forward if negative."
(interactive "p")
(org-next-visible-heading (- arg)))
(defun org-forward-paragraph (&optional arg)
"Move forward by a paragraph, or equivalent, unit.
With argument ARG, do it ARG times;
a negative argument ARG = -N means move backward N paragraphs.
The function moves point between two structural
elements (paragraphs, tables, lists, etc.).
It also provides the following special moves for convenience:
- on a table or a property drawer, move to its beginning;
- on comment, example, export, source and verse blocks, stop
at blank lines;
- skip consecutive clocks, diary S-exps, and keywords."
(interactive "^p")
(unless arg (setq arg 1))
(if (< arg 0) (org-backward-paragraph (- arg))
(while (and (> arg 0) (not (eobp)))
(org--forward-paragraph-once)
(cl-decf arg))
;; Return moves left.
arg))
(defun org-backward-paragraph (&optional arg)
"Move backward by a paragraph, or equivalent, unit.
With argument ARG, do it ARG times;
a negative argument ARG = -N means move forward N paragraphs.
The function moves point between two structural
elements (paragraphs, tables, lists, etc.).
It also provides the following special moves for convenience:
- on a table or a property drawer, move to its beginning;
- on comment, example, export, source and verse blocks, stop
at blank lines;
- skip consecutive clocks, diary S-exps, and keywords."
(interactive "^p")
(unless arg (setq arg 1))
(if (< arg 0) (org-forward-paragraph (- arg))
(while (and (> arg 0) (not (bobp)))
(org--backward-paragraph-once)
(cl-decf arg))
;; Return moves left.
arg))
(defvar org--single-lines-list-is-paragraph t
"Treat plain lists with single line items as a whole paragraph.")
(defun org--paragraph-at-point ()
"Return paragraph, or equivalent, element at point.
Paragraph element at point is the element at point, with the
following special cases:
- treat table rows (resp. node properties) as the table
\(resp. property drawer) containing them.
- treat plain lists with an item every line as a whole.
- treat consecutive keywords, clocks, and diary-sexps as a single
block.
Function may return a real element, or a pseudo-element with type
`pseudo-paragraph'."
(let* ((e (org-element-at-point))
(type (org-element-type e))
;; If we need to fake a new pseudo-element, triplet is
;;
;; (BEG END PARENT)
;;
;; where BEG and END are element boundaries, and PARENT the
;; element containing it, or nil.
(triplet
(cond
((memq type '(table property-drawer))
(list (org-element-begin e)
(org-element-end e)
(org-element-parent e)))
((memq type '(node-property table-row))
(let ((e (org-element-parent e)))
(list (org-element-begin e)
(org-element-end e)
(org-element-parent e))))
((memq type '(clock diary-sexp keyword))
(let* ((regexp (pcase type
(`clock org-clock-line-re)
(`diary-sexp "%%(")
(_ org-keyword-regexp)))
(end (if (< 0 (org-element-post-blank e))
(org-element-end e)
(org-with-wide-buffer
(forward-line)
(while (looking-at regexp) (forward-line))
(skip-chars-forward " \t\n")
(line-beginning-position))))
(begin (org-with-point-at (org-element-begin e)
(while (and (not (bobp)) (looking-at regexp))
(forward-line -1))
;; We may have gotten one line too far.
(if (looking-at regexp)
(point)
(line-beginning-position 2)))))
(list begin end (org-element-parent e))))
;; Find the full plain list containing point, the check it
;; contains exactly one line per item.
((let ((l (org-element-lineage e 'plain-list t)))
(while (org-element-type-p
(org-element-parent l)
'(item plain-list))
(setq l (org-element-parent l)))
(and l org--single-lines-list-is-paragraph
(org-with-point-at (org-element-post-affiliated l)
(forward-line (length (org-element-property :structure l)))
(= (point) (org-element-contents-end l)))
;; Return value.
(list (org-element-begin l)
(org-element-end l)
(org-element-parent l)))))
(t nil)))) ;no triplet: return element
(pcase triplet
(`(,b ,e ,p)
(org-element-create
'pseudo-paragraph
(list :begin b :end e :parent p :post-blank 0 :post-affiliated b)))
(_ e))))
(defun org--forward-paragraph-once ()
"Move forward to end of paragraph or equivalent, once.
See `org-forward-paragraph'."
(interactive)
(save-restriction
(widen)
(skip-chars-forward " \t\n")
(cond
((eobp) nil)
;; When inside a folded part, move out of it.
((when (org-invisible-p nil t)
(goto-char (cdr (org-fold-get-region-at-point)))
(forward-line)
t))
(t
(let* ((element (org--paragraph-at-point))
(type (org-element-type element))
(contents-begin (org-element-contents-begin element))
(end (org-element-end element))
(post-affiliated (org-element-post-affiliated element)))
(cond
((eq type 'plain-list)
(forward-char)
(org--forward-paragraph-once))
;; If the element is folded, skip it altogether.
((when (org-with-point-at post-affiliated (org-invisible-p (line-end-position) t))
(goto-char (cdr (org-fold-get-region-at-point
nil
(org-with-point-at post-affiliated
(line-end-position)))))
(forward-line)
t))
;; At a greater element, move inside.
((and contents-begin
(> contents-begin (point))
(not (eq type 'paragraph)))
(goto-char contents-begin)
;; Items and footnote definitions contents may not start at
;; the beginning of the line. In this case, skip until the
;; next paragraph.
(cond
((not (bolp)) (org--forward-paragraph-once))
((org-previous-line-empty-p) (forward-line -1))
(t nil)))
;; Move between empty lines in some blocks.
((memq type '(comment-block example-block export-block src-block
verse-block))
(let ((contents-start
(org-with-point-at post-affiliated
(line-beginning-position 2))))
(if (< (point) contents-start)
(goto-char contents-start)
(let ((contents-end
(org-with-point-at end
(skip-chars-backward " \t\n")
(line-beginning-position))))
(cond
((>= (point) contents-end)
(goto-char end)
(skip-chars-backward " \t\n")
(forward-line))
((re-search-forward "^[ \t]*\n" contents-end :move)
(forward-line -1))
(t nil))))))
(t
;; Move to element's end.
(goto-char end)
(skip-chars-backward " \t\n")
(forward-line))))))))
(defun org--backward-paragraph-once ()
"Move backward to start of paragraph or equivalent, once.
See `org-backward-paragraph'."
(interactive)
(save-restriction
(widen)
(cond
((bobp) nil)
;; Blank lines at the beginning of the buffer.
((and (org-match-line "^[ \t]*$")
(save-excursion (skip-chars-backward " \t\n") (bobp)))
(goto-char (point-min)))
;; When inside a folded part, move out of it.
((when (org-invisible-p (1- (point)) t)
(goto-char (1- (car (org-fold-get-region-at-point nil (1- (point))))))
(org--backward-paragraph-once)
t))
(t
(let* ((element (org--paragraph-at-point))
(type (org-element-type element))
(begin (org-element-begin element))
(post-affiliated (org-element-post-affiliated element))
(contents-end (org-element-contents-end element))
(end (org-element-end element))
(parent (org-element-parent element))
(reach
;; Move to the visible empty line above position P, or
;; to position P. Return t.
(lambda (p)
(goto-char p)
(when (and (org-previous-line-empty-p)
(let ((end (line-end-position 0)))
(or (= end (point-min))
(not (org-invisible-p (1- end))))))
(forward-line -1))
t)))
(cond
;; Already at the beginning of an element.
((= begin (point))
(cond
;; There is a blank line above. Move there.
((and (org-previous-line-empty-p)
(not (org-invisible-p (1- (line-end-position 0)))))
(forward-line -1))
;; At the beginning of the first element within a greater
;; element. Move to the beginning of the greater element.
((and parent
(not (org-element-type-p parent 'section))
(= begin (org-element-contents-begin parent)))
(funcall reach (org-element-begin parent)))
;; Since we have to move anyway, find the beginning
;; position of the element above.
(t
(forward-char -1)
(org--backward-paragraph-once))))
;; Skip paragraphs at the very beginning of footnote
;; definitions or items.
((and (eq type 'paragraph)
(org-with-point-at begin (not (bolp))))
(funcall reach (progn (goto-char begin) (line-beginning-position))))
;; If the element is folded, skip it altogether.
((org-with-point-at post-affiliated (org-invisible-p (line-end-position) t))
(funcall reach begin))
;; At the end of a greater element, move inside.
((and contents-end
(<= contents-end (point))
(not (eq type 'paragraph)))
(cond
((memq type '(footnote-definition plain-list))
(skip-chars-backward " \t\n")
(org--backward-paragraph-once))
((= contents-end (point))
(forward-char -1)
(org--backward-paragraph-once))
(t
(goto-char contents-end))))
;; Move between empty lines in some blocks.
((and (memq type '(comment-block example-block export-block src-block
verse-block))
(let ((contents-start
(org-with-point-at post-affiliated
(line-beginning-position 2))))
(when (> (point) contents-start)
(let ((contents-end
(org-with-point-at end
(skip-chars-backward " \t\n")
(line-beginning-position))))
(if (> (point) contents-end)
(progn (goto-char contents-end) t)
(skip-chars-backward " \t\n" begin)
(re-search-backward "^[ \t]*\n" contents-start :move)
t))))))
;; Move to element's start.
(t
(funcall reach begin))))))))
(defun org-forward-element ()
"Move forward by one element.
Move to the next element at the same level, when possible."
(interactive)
(cond ((eobp) (user-error "Cannot move further down"))
((org-with-limited-levels (org-at-heading-p))
(let ((origin (point)))
(goto-char (org-end-of-subtree nil t))
(unless (org-with-limited-levels (org-at-heading-p))
(goto-char origin)
(user-error "Cannot move further down"))))
(t
(let* ((elem (org-element-at-point))
(end (org-element-end elem))
(parent (org-element-parent elem)))
(cond ((and parent (= (org-element-contents-end parent) end))
(goto-char (org-element-end parent)))
((integer-or-marker-p end) (goto-char end))
(t (message "No element at point")))))))
(defun org-backward-element ()
"Move backward by one element.
Move to the previous element at the same level, when possible."
(interactive)
(cond ((bobp) (user-error "Cannot move further up"))
((org-with-limited-levels (org-at-heading-p))
;; At a headline, move to the previous one, if any, or stay
;; here.
(let ((origin (point)))
(org-with-limited-levels (org-backward-heading-same-level 1))
;; When current headline has no sibling above, move to its
;; parent.
(when (= (point) origin)
(or (org-with-limited-levels (org-up-heading-safe))
(progn (goto-char origin)
(user-error "Cannot move further up"))))))
(t
(let* ((elem (org-element-at-point))
(beg (org-element-begin elem)))
(cond
;; Move to beginning of current element if point isn't
;; there already.
((null beg) (message "No element at point"))
((/= (point) beg) (goto-char beg))
(t (goto-char beg)
(skip-chars-backward " \r\t\n")
(unless (bobp)
(let ((prev (org-element-at-point)))
(goto-char (org-element-begin prev))
(while (and (setq prev (org-element-parent prev))
(<= (org-element-end prev) beg))
(goto-char (org-element-begin prev)))))))))))
(defun org-up-element ()
"Move to upper element."
(interactive)
(if (org-with-limited-levels (org-at-heading-p))
(unless (org-up-heading-safe) (user-error "No surrounding element"))
(let* ((elem (org-element-at-point))
(parent (org-element-parent elem)))
;; Skip sections
(when (org-element-type-p parent 'section)
(setq parent (org-element-parent parent)))
(if (and parent
(not (org-element-type-p parent 'org-data)))
(goto-char (org-element-begin parent))
(if (org-with-limited-levels (org-before-first-heading-p))
(user-error "No surrounding element")
(org-with-limited-levels (org-back-to-heading)))))))
(defun org-down-element ()
"Move to inner element."
(interactive)
(let ((element (org-element-at-point)))
(cond
((org-element-type-p element '(plain-list table))
(goto-char (org-element-contents-begin element))
(forward-char))
((org-element-type-p element org-element-greater-elements)
;; If contents are hidden, first disclose them.
(when (org-invisible-p (line-end-position)) (org-cycle))
(goto-char (or (org-element-contents-begin element)
(user-error "No content for this element"))))
(t (user-error "No inner element")))))
(defun org-drag-element-backward ()
"Move backward element at point."
(interactive)
(let ((elem (or (org-element-at-point)
(user-error "No element at point"))))
(if (org-element-type-p elem 'headline)
;; Preserve point when moving a whole tree, even if point was
;; on blank lines below the headline.
(let ((offset (skip-chars-backward " \t\n")))
(unwind-protect (org-move-subtree-up)
(forward-char (- offset))))
(let ((prev-elem
(save-excursion
(goto-char (org-element-begin elem))
(skip-chars-backward " \r\t\n")
(unless (bobp)
(let* ((beg (org-element-begin elem))
(prev (org-element-at-point))
(up prev))
(while (and (setq up (org-element-parent up))
(<= (org-element-end up) beg))
(setq prev up))
prev)))))
;; Error out if no previous element or previous element is
;; a parent of the current one.
(if (or (not prev-elem) (org-element-nested-p elem prev-elem))
(user-error "Cannot drag element backward")
(let ((pos (point)))
(org-element-swap-A-B prev-elem elem)
(goto-char (+ (org-element-begin prev-elem)
(- pos (org-element-begin elem))))))))))
(defun org-drag-element-forward ()
"Move forward element at point."
(interactive)
(let* ((pos (point))
(elem (or (org-element-at-point)
(user-error "No element at point"))))
(when (= (point-max) (org-element-end elem))
(user-error "Cannot drag element forward"))
(goto-char (org-element-end elem))
(let ((next-elem (org-element-at-point)))
(when (or (org-element-nested-p elem next-elem)
(and (org-element-type-p next-elem 'headline)
(not (org-element-type-p elem 'headline))))
(goto-char pos)
(user-error "Cannot drag element forward"))
;; Compute new position of point: it's shifted by NEXT-ELEM
;; body's length (without final blanks) and by the length of
;; blanks between ELEM and NEXT-ELEM.
(let ((size-next (- (save-excursion
(goto-char (org-element-end next-elem))
(skip-chars-backward " \r\t\n")
(forward-line)
;; Small correction if buffer doesn't end
;; with a newline character.
(if (and (eolp) (not (bolp))) (1+ (point)) (point)))
(org-element-begin next-elem)))
(size-blank (- (org-element-end elem)
(save-excursion
(goto-char (org-element-end elem))
(skip-chars-backward " \r\t\n")
(forward-line)
(point)))))
(org-element-swap-A-B elem next-elem)
(goto-char (+ pos size-next size-blank))))))
(defun org-drag-line-forward (arg)
"Drag the line at point ARG lines forward."
(interactive "p")
(dotimes (_ (abs arg))
(let ((c (current-column)))
(if (< 0 arg)
(progn
(forward-line 1)
(transpose-lines 1)
(forward-line -1))
(transpose-lines 1)
(forward-line -2))
(org-move-to-column c))))
(defun org-drag-line-backward (arg)
"Drag the line at point ARG lines backward."
(interactive "p")
(org-drag-line-forward (- arg)))
(defun org-mark-element ()
"Put point at beginning of this element, mark at end.
Interactively, if this command is repeated or (in Transient Mark
mode) if the mark is active, it marks the next element after the
ones already marked."
(interactive)
(let (deactivate-mark)
(if (and (called-interactively-p 'any)
(or (and (eq last-command this-command) (mark t))
(and transient-mark-mode mark-active)))
(set-mark
(save-excursion
(goto-char (mark))
(goto-char (org-element-end (org-element-at-point)))
(point)))
(let ((element (org-element-at-point)))
(end-of-line)
(push-mark (min (point-max) (org-element-end element)) t t)
(goto-char (org-element-begin element))))))
(defun org-narrow-to-element ()
"Narrow buffer to current element.
Use the command `\\[widen]' to see the whole buffer again."
(interactive)
(let ((elem (org-element-at-point)))
(cond
((eq (car elem) 'headline)
(narrow-to-region
(org-element-begin elem)
(org-element-end elem)))
((memq (car elem) org-element-greater-elements)
(narrow-to-region
(org-element-contents-begin elem)
(org-element-contents-end elem)))
(t
(narrow-to-region
(org-element-begin elem)
(org-element-end elem))))))
(defun org-transpose-element ()
"Transpose current and previous elements, keeping blank lines between.
Point is moved after both elements."
(interactive)
(org-skip-whitespace)
(let ((end (org-element-end (org-element-at-point))))
(org-drag-element-backward)
(goto-char end)))
(defun org-unindent-buffer ()
"Un-indent the visible part of the buffer.
Relative indentation (between items, inside blocks, etc.) isn't
modified."
(interactive)
(unless (eq major-mode 'org-mode)
(user-error "Cannot un-indent a buffer not in Org mode"))
(letrec ((parse-tree (org-element-parse-buffer 'greater-element nil 'defer))
(unindent-tree
(lambda (contents)
(dolist (element (reverse contents))
(if (org-element-type-p element '(headline section))
(funcall unindent-tree (org-element-contents element))
(save-excursion
(save-restriction
(narrow-to-region
(org-element-begin element)
(org-element-end element))
(org-do-remove-indentation))))))))
(funcall unindent-tree (org-element-contents parse-tree))))
(defun org-make-options-regexp (kwds &optional extra)
"Make a regular expression for keyword lines.
KWDS is a list of keywords, as strings. Optional argument EXTRA,
when non-nil, is a regexp matching keywords names."
(concat "^[ \t]*#\\+\\("
(regexp-opt kwds)
(and extra (concat (and kwds "\\|") extra))
"\\):[ \t]*\\(.*\\)"))
;;; Conveniently switch to Info nodes
(defun org-info-find-node (&optional nodename)
"Find Info documentation NODENAME or Org documentation according context.
Started from `gnus-info-find-node'."
(interactive)
(Info-goto-node
(or nodename
(let ((default-org-info-node "(org) Top"))
(cond
((eq 'org-agenda-mode major-mode) "(org) Agenda Views")
((eq 'org-mode major-mode)
(let* ((context (org-element-at-point))
(element-info-nodes ; compare to `org-element-all-elements'.
`((babel-call . "(org) Evaluating Code Blocks")
(center-block . "(org) Paragraphs")
(clock . ,default-org-info-node)
(comment . "(org) Comment Lines")
(comment-block . "(org) Comment Lines")
(diary-sexp . ,default-org-info-node)
(drawer . "(org) Drawers")
(dynamic-block . "(org) Dynamic Blocks")
(example-block . "(org) Literal Examples")
(export-block . "(org) ASCII/Latin-1/UTF-8 export")
(fixed-width . ,default-org-info-node)
(footnote-definition . "(org) Creating Footnotes")
(headline . "(org) Document Structure")
(horizontal-rule . "(org) Built-in Table Editor")
(inlinetask . ,default-org-info-node)
(item . "(org) Plain Lists")
(keyword . "(org) Per-file keywords")
(latex-environment . "(org) LaTeX Export")
(node-property . "(org) Properties and Columns")
(paragraph . "(org) Paragraphs")
(plain-list . "(org) Plain Lists")
(planning . "(org) Deadlines and Scheduling")
(property-drawer . "(org) Properties and Columns")
(quote-block . "(org) Paragraphs")
(section . ,default-org-info-node)
(special-block . ,default-org-info-node)
(src-block . "(org) Working with Source Code")
(table . "(org) Tables")
(table-row . "(org) Tables")
(verse-block . "(org) Paragraphs"))))
(or (cdr (assoc (car context) element-info-nodes))
default-org-info-node)))
(t default-org-info-node))))))
;;; Finish up
(add-hook 'org-mode-hook ;remove folds when changing major mode
(lambda () (add-hook 'change-major-mode-hook
'org-fold-show-all 'append 'local)))
(provide 'org)
(run-hooks 'org-load-hook)
;;; org.el ends here
org-mode-9.7.29+dfsg/lisp/ox-ascii.el 0000664 0000000 0000000 00000236340 15004304337 0017266 0 ustar 00root root 0000000 0000000 ;;; ox-ascii.el --- ASCII Backend for Org Export Engine -*- lexical-binding: t; -*-
;; Copyright (C) 2012-2025 Free Software Foundation, Inc.
;; Author: Nicolas Goaziou <n.goaziou at gmail dot com>
;; Keywords: outlines, hypermedia, calendar, text
;; 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; This library implements an ASCII backend for Org generic exporter.
;; See Org manual for more information.
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'ox)
(require 'ox-publish)
(require 'cl-lib)
;;; Function Declarations
(declare-function aa2u "ext:ascii-art-to-unicode" ())
(declare-function org-at-heading-p "org" (&optional _))
(declare-function org-back-to-heading "org" (&optional invisible-ok))
(declare-function org-next-visible-heading "org" (arg))
;;; Define Backend
;;
;; The following setting won't allow modifying preferred charset
;; through a buffer keyword or an option item, but, since the property
;; will appear in communication channel nonetheless, it allows
;; overriding `org-ascii-charset' variable on the fly by the ext-plist
;; mechanism.
;;
;; We also install a filter for headlines and sections, in order to
;; control blank lines separating them in output string.
(org-export-define-backend 'ascii
'((bold . org-ascii-bold)
(center-block . org-ascii-center-block)
(clock . org-ascii-clock)
(code . org-ascii-code)
(drawer . org-ascii-drawer)
(dynamic-block . org-ascii-dynamic-block)
(entity . org-ascii-entity)
(example-block . org-ascii-example-block)
(export-block . org-ascii-export-block)
(export-snippet . org-ascii-export-snippet)
(fixed-width . org-ascii-fixed-width)
(footnote-reference . org-ascii-footnote-reference)
(headline . org-ascii-headline)
(horizontal-rule . org-ascii-horizontal-rule)
(inline-src-block . org-ascii-inline-src-block)
(inlinetask . org-ascii-inlinetask)
(inner-template . org-ascii-inner-template)
(italic . org-ascii-italic)
(item . org-ascii-item)
(keyword . org-ascii-keyword)
(latex-environment . org-ascii-latex-environment)
(latex-fragment . org-ascii-latex-fragment)
(line-break . org-ascii-line-break)
(link . org-ascii-link)
(node-property . org-ascii-node-property)
(paragraph . org-ascii-paragraph)
(plain-list . org-ascii-plain-list)
(plain-text . org-ascii-plain-text)
(planning . org-ascii-planning)
(property-drawer . org-ascii-property-drawer)
(quote-block . org-ascii-quote-block)
(radio-target . org-ascii-radio-target)
(section . org-ascii-section)
(special-block . org-ascii-special-block)
(src-block . org-ascii-src-block)
(statistics-cookie . org-ascii-statistics-cookie)
(strike-through . org-ascii-strike-through)
(subscript . org-ascii-subscript)
(superscript . org-ascii-superscript)
(table . org-ascii-table)
(table-cell . org-ascii-table-cell)
(table-row . org-ascii-table-row)
(target . org-ascii-target)
(template . org-ascii-template)
(timestamp . org-ascii-timestamp)
(underline . org-ascii-underline)
(verbatim . org-ascii-verbatim)
(verse-block . org-ascii-verse-block))
:menu-entry
'(?t "Export to Plain Text"
((?A "As ASCII buffer"
(lambda (a s v b)
(org-ascii-export-as-ascii a s v b '(:ascii-charset ascii))))
(?a "As ASCII file"
(lambda (a s v b)
(org-ascii-export-to-ascii a s v b '(:ascii-charset ascii))))
(?L "As Latin1 buffer"
(lambda (a s v b)
(org-ascii-export-as-ascii a s v b '(:ascii-charset latin1))))
(?l "As Latin1 file"
(lambda (a s v b)
(org-ascii-export-to-ascii a s v b '(:ascii-charset latin1))))
(?U "As UTF-8 buffer"
(lambda (a s v b)
(org-ascii-export-as-ascii a s v b '(:ascii-charset utf-8))))
(?u "As UTF-8 file"
(lambda (a s v b)
(org-ascii-export-to-ascii a s v b '(:ascii-charset utf-8))))))
:filters-alist '((:filter-headline . org-ascii-filter-headline-blank-lines)
(:filter-parse-tree org-ascii-filter-paragraph-spacing
org-ascii-filter-comment-spacing)
(:filter-section . org-ascii-filter-headline-blank-lines))
:options-alist
'((:subtitle "SUBTITLE" nil nil parse)
(:ascii-bullets nil nil org-ascii-bullets)
(:ascii-caption-above nil nil org-ascii-caption-above)
(:ascii-charset nil nil org-ascii-charset)
(:ascii-global-margin nil nil org-ascii-global-margin)
(:ascii-format-drawer-function nil nil org-ascii-format-drawer-function)
(:ascii-format-inlinetask-function
nil nil org-ascii-format-inlinetask-function)
(:ascii-headline-spacing nil nil org-ascii-headline-spacing)
(:ascii-indented-line-width nil nil org-ascii-indented-line-width)
(:ascii-inlinetask-width nil nil org-ascii-inlinetask-width)
(:ascii-inner-margin nil nil org-ascii-inner-margin)
(:ascii-links-to-notes nil nil org-ascii-links-to-notes)
(:ascii-list-margin nil nil org-ascii-list-margin)
(:ascii-paragraph-spacing nil nil org-ascii-paragraph-spacing)
(:ascii-quote-margin nil nil org-ascii-quote-margin)
(:ascii-table-keep-all-vertical-lines
nil nil org-ascii-table-keep-all-vertical-lines)
(:ascii-table-use-ascii-art nil nil org-ascii-table-use-ascii-art)
(:ascii-table-widen-columns nil nil org-ascii-table-widen-columns)
(:ascii-text-width nil nil org-ascii-text-width)
(:ascii-underline nil nil org-ascii-underline)
(:ascii-verbatim-format nil nil org-ascii-verbatim-format)))
;;; User Configurable Variables
(defgroup org-export-ascii nil
"Options for exporting Org mode files to ASCII."
:tag "Org Export ASCII"
:group 'org-export)
(defcustom org-ascii-text-width 72
"Maximum width of exported text.
This number includes margin size, as set in
`org-ascii-global-margin'."
:group 'org-export-ascii
:version "24.4"
:package-version '(Org . "8.0")
:type 'integer)
(defcustom org-ascii-global-margin 0
"Width of the left margin, in number of characters."
:group 'org-export-ascii
:version "24.4"
:package-version '(Org . "8.0")
:type 'integer)
(defcustom org-ascii-inner-margin 2
"Width of the inner margin, in number of characters.
Inner margin is applied between each headline."
:group 'org-export-ascii
:version "24.4"
:package-version '(Org . "8.0")
:type 'integer)
(defcustom org-ascii-quote-margin 6
"Width of margin used for quoting text, in characters.
This margin is applied on both sides of the text. It is also
applied on the left side of contents in descriptive lists."
:group 'org-export-ascii
:version "24.4"
:package-version '(Org . "8.0")
:type 'integer)
(defcustom org-ascii-list-margin 0
"Width of margin used for plain lists, in characters.
This margin applies to top level list only, not to its
sub-lists."
:group 'org-export-ascii
:version "26.1"
:package-version '(Org . "8.3")
:type 'integer)
(defcustom org-ascii-inlinetask-width 30
"Width of inline tasks, in number of characters.
This number ignores any margin."
:group 'org-export-ascii
:version "24.4"
:package-version '(Org . "8.0")
:type 'integer)
(defcustom org-ascii-headline-spacing '(1 . 2)
"Number of blank lines inserted around headlines.
This variable can be set to a cons cell. In that case, its car
represents the number of blank lines present before headline
contents whereas its cdr reflects the number of blank lines after
contents.
A nil value replicates the number of blank lines found in the
original Org buffer at the same place."
:group 'org-export-ascii
:version "24.4"
:package-version '(Org . "8.0")
:type '(choice
(const :tag "Replicate original spacing" nil)
(cons :tag "Set a uniform spacing"
(integer :tag "Number of blank lines before contents")
(integer :tag "Number of blank lines after contents"))))
(defcustom org-ascii-indented-line-width 'auto
"Additional indentation width for the first line in a paragraph.
If the value is an integer, indent the first line of each
paragraph by this width, unless it is located at the beginning of
a section, in which case indentation is removed from that line.
If it is the symbol `auto' preserve indentation from original
document."
:group 'org-export-ascii
:version "24.4"
:package-version '(Org . "8.0")
:type '(choice
(integer :tag "Number of white spaces characters")
(const :tag "Preserve original width" auto)))
(defcustom org-ascii-paragraph-spacing 'auto
"Number of white lines between paragraphs.
If the value is an integer, add this number of blank lines
between contiguous paragraphs. If is it the symbol `auto', keep
the same number of blank lines as in the original document."
:group 'org-export-ascii
:version "24.4"
:package-version '(Org . "8.0")
:type '(choice
(integer :tag "Number of blank lines")
(const :tag "Preserve original spacing" auto)))
(defcustom org-ascii-charset 'ascii
"The charset allowed to represent various elements and objects.
Possible values are:
`ascii' Only use plain ASCII characters
`latin1' Include Latin-1 characters
`utf-8' Use all UTF-8 characters"
:group 'org-export-ascii
:version "24.4"
:package-version '(Org . "8.0")
:type '(choice
(const :tag "ASCII" ascii)
(const :tag "Latin-1" latin1)
(const :tag "UTF-8" utf-8)))
(defcustom org-ascii-underline '((ascii ?= ?~ ?-)
(latin1 ?= ?~ ?-)
(utf-8 ?═ ?─ ?╌ ?┄ ?┈))
"Characters for underlining headings in ASCII export.
Alist whose key is a symbol among `ascii', `latin1' and `utf-8'
and whose value is a list of characters.
For each supported charset, this variable associates a sequence
of underline characters. In a sequence, the characters will be
used in order for headlines level 1, 2, ... If no character is
available for a given level, the headline won't be underlined."
:group 'org-export-ascii
:version "24.4"
:package-version '(Org . "8.0")
:type '(list
(cons :tag "Underline characters sequence"
(const :tag "ASCII charset" ascii)
(repeat character))
(cons :tag "Underline characters sequence"
(const :tag "Latin-1 charset" latin1)
(repeat character))
(cons :tag "Underline characters sequence"
(const :tag "UTF-8 charset" utf-8)
(repeat character))))
(defcustom org-ascii-bullets '((ascii ?* ?+ ?-)
(latin1 ?§ ?¶)
(utf-8 ?◊))
"Bullet characters for headlines converted to lists in ASCII export.
Alist whose key is a symbol among `ascii', `latin1' and `utf-8'
and whose value is a list of characters.
The first character is used for the first level considered as low
level, and so on. If there are more levels than characters given
here, the list will be repeated.
Note that this variable doesn't affect plain lists
representation."
:group 'org-export-ascii
:version "24.4"
:package-version '(Org . "8.0")
:type '(list
(cons :tag "Bullet characters for low level headlines"
(const :tag "ASCII charset" ascii)
(repeat character))
(cons :tag "Bullet characters for low level headlines"
(const :tag "Latin-1 charset" latin1)
(repeat character))
(cons :tag "Bullet characters for low level headlines"
(const :tag "UTF-8 charset" utf-8)
(repeat character))))
(defcustom org-ascii-links-to-notes t
"Non-nil means convert links to notes before the next headline.
When nil, the link will be exported in place. If the line
becomes long in this way, it will be wrapped."
:group 'org-export-ascii
:version "24.4"
:package-version '(Org . "8.0")
:type 'boolean)
(defcustom org-ascii-table-keep-all-vertical-lines nil
"Non-nil means keep all vertical lines in ASCII tables.
When nil, vertical lines will be removed except for those needed
for column grouping."
:group 'org-export-ascii
:version "24.4"
:package-version '(Org . "8.0")
:type 'boolean)
(defcustom org-ascii-table-widen-columns t
"Non-nil means widen narrowed columns for export.
When nil, narrowed columns will look in ASCII export just like in
Org mode, i.e. with \"=>\" as ellipsis."
:group 'org-export-ascii
:version "24.4"
:package-version '(Org . "8.0")
:type 'boolean)
(defcustom org-ascii-table-use-ascii-art nil
"Non-nil means \"table.el\" tables are turned into ASCII art.
It only makes sense when export charset is `utf-8'. It is nil by
default since it requires \"ascii-art-to-unicode.el\" package,
available through, e.g., GNU ELPA."
:group 'org-export-ascii
:version "24.4"
:package-version '(Org . "8.0")
:type 'boolean)
(defcustom org-ascii-caption-above nil
"When non-nil, place caption string before the element.
Otherwise, place it right after it."
:group 'org-export-ascii
:version "24.4"
:package-version '(Org . "8.0")
:type 'boolean)
(defcustom org-ascii-verbatim-format "`%s'"
"Format string used for verbatim text and inline code."
:group 'org-export-ascii
:version "24.4"
:package-version '(Org . "8.0")
:type 'string)
(defcustom org-ascii-format-drawer-function
(lambda (_name contents _width) contents)
"Function called to format a drawer in ASCII.
The function must accept three parameters:
NAME the drawer name, like \"LOGBOOK\"
CONTENTS the contents of the drawer.
WIDTH the text width within the drawer.
The function should return either the string to be exported or
nil to ignore the drawer.
The default value simply returns the value of CONTENTS."
:group 'org-export-ascii
:version "24.4"
:package-version '(Org . "8.0")
:type 'function)
(defcustom org-ascii-format-inlinetask-function
'org-ascii-format-inlinetask-default
"Function called to format an inlinetask in ASCII.
The function must accept nine parameters:
TODO the todo keyword, as a string
TODO-TYPE the todo type, a symbol among `todo', `done' and nil.
PRIORITY the inlinetask priority, as a string
NAME the inlinetask name, as a string.
TAGS the inlinetask tags, as a list of strings.
CONTENTS the contents of the inlinetask, as a string.
WIDTH the width of the inlinetask, as a number.
INLINETASK the inlinetask itself.
INFO the info channel.
The function should return either the string to be exported or
nil to ignore the inline task."
:group 'org-export-ascii
:version "26.1"
:package-version '(Org . "8.3")
:type 'function)
;;; Internal Functions
;; Internal functions fall into three categories.
;; The first one is about text formatting. The core functions are
;; `org-ascii--current-text-width' and
;; `org-ascii--current-justification', which determine, respectively,
;; the current text width allowed to a given element and its expected
;; justification. Once this information is known,
;; `org-ascii--fill-string', `org-ascii--justify-lines',
;; `org-ascii--justify-element' `org-ascii--box-string' and
;; `org-ascii--indent-string' can operate on a given output string.
;; In particular, justification happens at the regular (i.e.,
;; non-greater) element level, which means that when the exporting
;; process reaches a container (e.g., a center block) content are
;; already justified.
;; The second category contains functions handling elements listings,
;; triggered by "#+TOC:" keyword. As such, `org-ascii--build-toc'
;; returns a complete table of contents, `org-ascii--list-listings'
;; returns a list of referenceable src-block elements, and
;; `org-ascii--list-tables' does the same for table elements.
;; The third category includes general helper functions.
;; `org-ascii--build-title' creates the title for a given headline
;; or inlinetask element. `org-ascii--build-caption' returns the
;; caption string associated to a table or a src-block.
;; `org-ascii--describe-links' creates notes about links for
;; insertion at the end of a section. It uses
;; `org-ascii--unique-links' to get the list of links to describe.
;; Eventually, `org-ascii--translate' translates a string according
;; to language and charset specification.
(defun org-ascii--fill-string (s text-width info &optional justify)
"Fill a string with specified text-width and return it.
S is the string being filled. TEXT-WIDTH is an integer
specifying maximum length of a line. INFO is the plist used as
a communication channel.
Optional argument JUSTIFY can specify any type of justification
among `left', `center', `right' or `full'. A nil value is
equivalent to `left'. For a justification that doesn't also fill
string, see `org-ascii--justify-lines' and
`org-ascii--justify-element'.
Return nil if S isn't a string."
(when (stringp s)
(let ((double-space-p sentence-end-double-space))
(with-temp-buffer
(let ((fill-column text-width)
(use-hard-newlines t)
(sentence-end-double-space double-space-p))
(insert (if (plist-get info :preserve-breaks)
(replace-regexp-in-string "\n" hard-newline s)
s))
(fill-region (point-min) (point-max) justify))
(buffer-string)))))
(defun org-ascii--justify-lines (s text-width how)
"Justify all lines in string S.
TEXT-WIDTH is an integer specifying maximum length of a line.
HOW determines the type of justification: it can be `left',
`right', `full' or `center'."
(with-temp-buffer
(insert s)
(goto-char (point-min))
(let ((fill-column text-width)
;; Ensure that `indent-tabs-mode' is nil so that indentation
;; will always be achieved using spaces rather than tabs.
(indent-tabs-mode nil)
;; Disable `adaptive-fill-mode' so it doesn't prevent
;; filling lines matching `adaptive-fill-regexp'.
(adaptive-fill-mode nil))
(while (< (point) (point-max))
(justify-current-line how)
(forward-line)))
(buffer-string)))
(defun org-ascii--justify-element (contents element info)
"Justify CONTENTS of ELEMENT.
INFO is a plist used as a communication channel. Justification
is done according to the type of element. More accurately,
paragraphs are filled and other elements are justified as blocks,
that is according to the widest non blank line in CONTENTS."
(if (not (org-string-nw-p contents)) contents
(let ((text-width (org-ascii--current-text-width element info))
(how (org-ascii--current-justification element)))
(cond
((org-element-type-p element 'paragraph)
;; Paragraphs are treated specially as they need to be filled.
(org-ascii--fill-string contents text-width info how))
((eq how 'left) contents)
(t (with-temp-buffer
(insert contents)
(goto-char (point-min))
(catch 'exit
(let ((max-width 0))
;; Compute maximum width. Bail out if it is greater
;; than page width, since no justification is
;; possible.
(save-excursion
(while (not (eobp))
(unless (looking-at-p "[ \t]*$")
(end-of-line)
(let ((column (current-column)))
(cond
((>= column text-width) (throw 'exit contents))
((> column max-width) (setq max-width column)))))
(forward-line)))
;; Justify every line according to TEXT-WIDTH and
;; MAX-WIDTH.
(let ((offset (/ (- text-width max-width)
(if (eq how 'right) 1 2))))
(if (zerop offset) (throw 'exit contents)
(while (not (eobp))
(unless (looking-at-p "[ \t]*$")
(indent-to-column offset))
(forward-line)))))
(buffer-string))))))))
(defun org-ascii--indent-string (s width)
"Indent string S by WIDTH white spaces.
Empty lines are not indented."
(when (stringp s)
(replace-regexp-in-string
"\\(^\\)[ \t]*\\S-" (make-string width ?\s) s nil nil 1)))
(defun org-ascii--box-string (s info)
"Return string S with a partial box to its left.
INFO is a plist used as a communication channel."
(let ((utf8p (eq (plist-get info :ascii-charset) 'utf-8)))
(format (if utf8p "┌────\n%s\n└────" ",----\n%s\n`----")
(replace-regexp-in-string
"^" (if utf8p "│ " "| ")
;; Remove last newline character.
(replace-regexp-in-string "\n[ \t]*\\'" "" s)))))
(defun org-ascii--current-text-width (element info)
"Return maximum text width for ELEMENT's contents.
INFO is a plist used as a communication channel."
(pcase (org-element-type element)
;; Elements with an absolute width: `headline' and `inlinetask'.
(`inlinetask (plist-get info :ascii-inlinetask-width))
(`headline
(- (plist-get info :ascii-text-width)
(let ((low-level-rank (org-export-low-level-p element info)))
(if low-level-rank (* low-level-rank 2)
(plist-get info :ascii-global-margin)))))
;; Elements with a relative width: store maximum text width in
;; TOTAL-WIDTH.
(_
(let* ((genealogy (org-element-lineage element nil t))
;; Total width is determined by the presence, or not, of an
;; inline task among ELEMENT parents.
(total-width
(if (cl-some (lambda (parent)
(org-element-type-p parent 'inlinetask))
genealogy)
(plist-get info :ascii-inlinetask-width)
;; No inlinetask: Remove global margin from text width.
(- (plist-get info :ascii-text-width)
(plist-get info :ascii-global-margin)
(let ((parent (org-element-lineage element 'headline)))
;; Inner margin doesn't apply to text before first
;; headline.
(if (not parent) 0
(let ((low-level-rank
(org-export-low-level-p parent info)))
;; Inner margin doesn't apply to contents of
;; low level headlines, since they've got their
;; own indentation mechanism.
(if low-level-rank (* low-level-rank 2)
(plist-get info :ascii-inner-margin)))))))))
(- total-width
;; Each `quote-block' and `verse-block' above narrows text
;; width by twice the standard margin size.
(+ (* (cl-count-if (lambda (parent)
(org-element-type-p
parent '(quote-block verse-block)))
genealogy)
2
(plist-get info :ascii-quote-margin))
;; Apply list margin once per "top-level" plain-list
;; containing current line
(* (cl-count-if
(lambda (e)
(and (org-element-type-p e 'plain-list)
(not (org-element-type-p
(org-element-parent e) 'item))))
genealogy)
(plist-get info :ascii-list-margin))
;; Compute indentation offset due to current list. It is
;; `org-ascii-quote-margin' per descriptive item in the
;; genealogy, bullet's length otherwise.
(let ((indentation 0))
(dolist (e genealogy)
(cond
((not (org-element-type-p e 'item)))
((eq (org-element-property :type (org-element-parent e))
'descriptive)
(cl-incf indentation org-ascii-quote-margin))
(t
(cl-incf indentation
(+ (string-width
(or (org-ascii--checkbox e info) ""))
(string-width
(org-element-property :bullet e)))))))
indentation)))))))
(defun org-ascii--current-justification (element)
"Return expected justification for ELEMENT's contents.
Return value is a symbol among `left', `center', `right' and
`full'."
(or (org-element-lineage-map
element
(lambda (el)
(pcase (org-element-type el)
(`center-block 'center)
(`special-block
(let ((name (org-element-property :type el)))
(cond ((string= name "JUSTIFYRIGHT") 'right)
((string= name "JUSTIFYLEFT") 'left))))))
'(center-block special-block)
nil 'first-match)
;; default
'left))
(defun org-ascii--build-title
(element info text-width &optional underline notags toc)
"Format ELEMENT title and return it.
ELEMENT is either an `headline' or `inlinetask' element. INFO is
a plist used as a communication channel. TEXT-WIDTH is an
integer representing the maximum length of a line.
When optional argument UNDERLINE is non-nil, underline title,
without the tags, according to `org-ascii-underline'
specifications.
If optional argument NOTAGS is non-nil, no tags will be added to
the title.
When optional argument TOC is non-nil, use optional title if
possible. It doesn't apply to `inlinetask' elements."
(let* ((headlinep (org-element-type-p element 'headline))
(numbers
;; Numbering is specific to headlines.
(and headlinep
(org-export-numbered-headline-p element info)
(let ((numbering (org-export-get-headline-number element info)))
(if toc (format "%d. " (org-last numbering))
(concat (mapconcat #'number-to-string numbering ".")
" ")))))
(text
(org-trim
(org-export-data
(if (and toc headlinep) (org-export-get-alt-title element info)
(org-element-property :title element))
info)))
(todo
(and (plist-get info :with-todo-keywords)
(let ((todo (org-element-property :todo-keyword element)))
(and todo (concat (org-export-data todo info) " ")))))
(tags (and (not notags)
(plist-get info :with-tags)
(let ((tag-list (org-export-get-tags element info)))
(and tag-list
(org-make-tag-string tag-list)))))
(priority
(and (plist-get info :with-priority)
(let ((char (org-element-property :priority element)))
(and char (format "(#%c) " char)))))
(first-part (concat numbers todo priority text)))
(concat
first-part
;; Align tags, if any.
(when tags
(format
(format " %%%ds"
(max (- text-width (1+ (string-width first-part)))
(string-width tags)))
tags))
;; Maybe underline text, if ELEMENT type is `headline' and an
;; underline character has been defined.
(when (and underline headlinep)
(let ((under-char
(nth (1- (org-export-get-relative-level element info))
(cdr (assq (plist-get info :ascii-charset)
(plist-get info :ascii-underline))))))
(and under-char
(concat "\n"
(make-string (/ (string-width first-part)
(char-width under-char))
under-char))))))))
(defun org-ascii--has-caption-p (element _info)
"Non-nil when ELEMENT has a caption affiliated keyword.
INFO is a plist used as a communication channel. This function
is meant to be used as a predicate for `org-export-get-ordinal'."
(org-element-property :caption element))
(defun org-ascii--build-caption (element info)
"Return caption string for ELEMENT, if applicable.
INFO is a plist used as a communication channel.
The caption string contains the sequence number of ELEMENT along
with its real caption. Return nil when ELEMENT has no affiliated
caption keyword."
(let ((caption (org-export-get-caption element)))
(when caption
;; Get sequence number of current src-block among every
;; src-block with a caption.
(let ((reference
(org-export-get-ordinal
element info nil 'org-ascii--has-caption-p))
(title-fmt (org-ascii--translate
(pcase (org-element-type element)
(`table "Table %d:")
(`src-block "Listing %d:"))
info)))
(org-ascii--fill-string
(concat (format title-fmt reference)
" "
(org-export-data caption info))
(org-ascii--current-text-width element info) info)))))
(defun org-ascii--build-toc (info &optional n keyword scope)
"Return a table of contents.
INFO is a plist used as a communication channel.
Optional argument N, when non-nil, is an integer specifying the
depth of the table.
Optional argument KEYWORD specifies the TOC keyword, if any, from
which the table of contents generation has been initiated.
When optional argument SCOPE is non-nil, build a table of
contents according to the specified scope."
(concat
(unless scope
(let ((title (org-ascii--translate "Table of Contents" info)))
(concat title "\n"
(make-string
(string-width title)
(if (eq (plist-get info :ascii-charset) 'utf-8) ?─ ?_))
"\n\n")))
(let ((text-width
(if keyword (org-ascii--current-text-width keyword info)
(- (plist-get info :ascii-text-width)
(plist-get info :ascii-global-margin)))))
(mapconcat
(lambda (headline)
(let* ((level (org-export-get-relative-level headline info))
(indent (* (1- level) 3)))
(concat
(unless (zerop indent) (concat (make-string (1- indent) ?.) " "))
(org-ascii--build-title
headline info (- text-width indent) nil
(or (not (plist-get info :with-tags))
(eq (plist-get info :with-tags) 'not-in-toc))
'toc))))
(org-export-collect-headlines info n scope) "\n"))))
(defun org-ascii--list-listings (keyword info)
"Return a list of listings.
KEYWORD is the keyword that initiated the list of listings
generation. INFO is a plist used as a communication channel."
(let ((title (org-ascii--translate "List of Listings" info)))
(concat
title "\n"
(make-string (string-width title)
(if (eq (plist-get info :ascii-charset) 'utf-8) ?─ ?_))
"\n\n"
(let ((text-width
(if keyword (org-ascii--current-text-width keyword info)
(- (plist-get info :ascii-text-width)
(plist-get info :ascii-global-margin))))
;; Use a counter instead of retrieving ordinal of each
;; src-block.
(count 0))
(mapconcat
(lambda (src-block)
;; Store initial text so its length can be computed. This is
;; used to properly align caption right to it in case of
;; filling (like contents of a description list item).
(let* ((initial-text
(format (org-ascii--translate "Listing %d:" info)
(cl-incf count)))
(initial-width (string-width initial-text)))
(concat
initial-text " "
(org-trim
(org-ascii--indent-string
(org-ascii--fill-string
;; Use short name in priority, if available.
(let ((caption (or (org-export-get-caption src-block t)
(org-export-get-caption src-block))))
(org-export-data caption info))
(- text-width initial-width) info)
initial-width)))))
(org-export-collect-listings info) "\n")))))
(defun org-ascii--list-tables (keyword info)
"Return a list of tables.
KEYWORD is the keyword that initiated the list of tables
generation. INFO is a plist used as a communication channel."
(let ((title (org-ascii--translate "List of Tables" info)))
(concat
title "\n"
(make-string (string-width title)
(if (eq (plist-get info :ascii-charset) 'utf-8) ?─ ?_))
"\n\n"
(let ((text-width
(if keyword (org-ascii--current-text-width keyword info)
(- (plist-get info :ascii-text-width)
(plist-get info :ascii-global-margin))))
;; Use a counter instead of retrieving ordinal of each
;; src-block.
(count 0))
(mapconcat
(lambda (table)
;; Store initial text so its length can be computed. This is
;; used to properly align caption right to it in case of
;; filling (like contents of a description list item).
(let* ((initial-text
(format (org-ascii--translate "Table %d:" info)
(cl-incf count)))
(initial-width (string-width initial-text)))
(concat
initial-text " "
(org-trim
(org-ascii--indent-string
(org-ascii--fill-string
;; Use short name in priority, if available.
(let ((caption (or (org-export-get-caption table t)
(org-export-get-caption table))))
(org-export-data caption info))
(- text-width initial-width) info)
initial-width)))))
(org-export-collect-tables info) "\n")))))
(defun org-ascii--unique-links (element info)
"Return a list of unique link references in ELEMENT.
ELEMENT is either a headline element or a section element. INFO
is a plist used as a communication channel."
(let* (seen
(unique-link-p
;; Return LINK if it wasn't referenced so far, or nil.
;; Update SEEN links along the way.
(lambda (link)
(let ((footprint
;; Normalize description in footprints.
(cons (org-element-property :raw-link link)
(let ((contents (org-element-contents link)))
(and contents
(replace-regexp-in-string
"[ \r\t\n]+" " "
(org-trim
(org-element-interpret-data contents))))))))
;; Ignore LINK if it hasn't been translated already. It
;; can happen if it is located in an affiliated keyword
;; that was ignored.
(when (and (org-string-nw-p
(gethash link (plist-get info :exported-data)))
(not (member footprint seen)))
(push footprint seen) link)))))
(org-element-map (if (org-element-type-p element 'section)
element
;; In a headline, only retrieve links in title
;; and relative section, not in children.
(list (org-element-property :title element)
(car (org-element-contents element))))
'link unique-link-p info nil 'headline t)))
(defun org-ascii--describe-datum (datum info)
"Describe DATUM object or element.
If DATUM is a string, consider it to be a file name, per
`org-export-resolve-id-link'. INFO is the communication channel,
as a plist."
(pcase (org-element-type datum)
(`plain-text (format "See file %s" datum)) ;External file
(`headline
(format (org-ascii--translate "See section %s" info)
(if (org-export-numbered-headline-p datum info)
(mapconcat #'number-to-string
(org-export-get-headline-number datum info)
".")
(org-export-data (org-element-property :title datum) info))))
(_
(let ((number (org-export-get-ordinal
datum info nil #'org-ascii--has-caption-p))
;; If destination is a target, make sure we can name the
;; container it refers to.
(enumerable
(org-element-lineage datum
'(headline paragraph src-block table) t)))
(pcase (org-element-type enumerable)
(`headline
(format (org-ascii--translate "See section %s" info)
(if (org-export-numbered-headline-p enumerable info)
(mapconcat #'number-to-string number ".")
(org-export-data
(org-element-property :title enumerable) info))))
((guard (not number))
(org-ascii--translate "Unknown reference" info))
(`paragraph
(format (org-ascii--translate "See figure %s" info) number))
(`src-block
(format (org-ascii--translate "See listing %s" info) number))
(`table
(format (org-ascii--translate "See table %s" info) number))
(_ (org-ascii--translate "Unknown reference" info)))))))
(defun org-ascii--describe-links (links width info)
"Return a string describing a list of links.
LINKS is a list of link type objects, as returned by
`org-ascii--unique-links'. WIDTH is the text width allowed for
the output string. INFO is a plist used as a communication
channel."
(mapconcat
(lambda (link)
(let* ((type (org-element-property :type link))
(description (org-element-contents link))
(anchor (org-export-data
(or description (org-element-property :raw-link link))
info)))
(cond
((member type '("coderef" "radio")) nil)
((member type '("custom-id" "fuzzy" "id"))
;; Only links with a description need an entry. Other are
;; already handled in `org-ascii-link'.
(when description
(let ((dest
;; Ignore broken links. On broken link,
;; `org-export-resolve-id-link' will throw an
;; error and we will return nil.
(condition-case nil
(if (equal type "fuzzy")
(org-export-resolve-fuzzy-link link info)
(org-export-resolve-id-link link info))
(org-link-broken nil))))
(when dest
(concat
(org-ascii--fill-string
(format "[%s] %s" anchor (org-ascii--describe-datum dest info))
width info)
"\n\n")))))
;; Do not add a link that cannot be resolved and doesn't have
;; any description: destination is already visible in the
;; paragraph.
((not (org-element-contents link)) nil)
;; Do not add a link already handled by custom export
;; functions.
((org-export-custom-protocol-maybe link anchor 'ascii info) nil)
(t
(concat
(org-ascii--fill-string
(format "[%s] <%s>" anchor (org-element-property :raw-link link))
width info)
"\n\n")))))
links ""))
(defun org-ascii--checkbox (item info)
"Return checkbox string for ITEM or nil.
INFO is a plist used as a communication channel."
(let ((utf8p (eq (plist-get info :ascii-charset) 'utf-8)))
(pcase (org-element-property :checkbox item)
(`on (if utf8p "☑ " "[X] "))
(`off (if utf8p "☐ " "[ ] "))
(`trans (if utf8p "☒ " "[-] ")))))
;;; Template
(defun org-ascii-template--document-title (info)
"Return document title, as a string.
INFO is a plist used as a communication channel."
(let* ((text-width (plist-get info :ascii-text-width))
;; Links in the title will not be resolved later, so we make
;; sure their path is located right after them.
(info (org-combine-plists info '(:ascii-links-to-notes nil)))
(with-title (plist-get info :with-title))
(title (org-export-data
(when with-title (plist-get info :title)) info))
(subtitle (org-export-data
(when with-title (plist-get info :subtitle)) info))
(author (and (plist-get info :with-author)
(let ((auth (plist-get info :author)))
(and auth (org-export-data auth info)))))
(email (and (plist-get info :with-email)
(org-export-data (plist-get info :email) info)))
(date (and (plist-get info :with-date)
(org-export-data (org-export-get-date info) info))))
;; There are two types of title blocks depending on the presence
;; of a title to display.
(if (string= title "")
;; Title block without a title. DATE is positioned at the top
;; right of the document, AUTHOR to the top left and EMAIL
;; just below.
(cond
((and (org-string-nw-p date) (org-string-nw-p author))
(concat
author
(make-string (- text-width (string-width date) (string-width author))
?\s)
date
(when (org-string-nw-p email) (concat "\n" email))
"\n\n\n"))
((and (org-string-nw-p date) (org-string-nw-p email))
(concat
email
(make-string (- text-width (string-width date) (string-width email))
?\s)
date "\n\n\n"))
((org-string-nw-p date)
(concat
(org-ascii--justify-lines date text-width 'right)
"\n\n\n"))
((and (org-string-nw-p author) (org-string-nw-p email))
(concat author "\n" email "\n\n\n"))
((org-string-nw-p author) (concat author "\n\n\n"))
((org-string-nw-p email) (concat email "\n\n\n")))
;; Title block with a title. Document's TITLE, along with the
;; AUTHOR and its EMAIL are both overlined and an underlined,
;; centered. Date is just below, also centered.
(let* ((utf8p (eq (plist-get info :ascii-charset) 'utf-8))
;; Format TITLE. It may be filled if it is too wide,
;; that is wider than the two thirds of the total width.
(title-len (min (apply #'max
(mapcar #'string-width
(org-split-string
(concat title "\n" subtitle) "\n")))
(/ (* 2 text-width) 3)))
(formatted-title (org-ascii--fill-string title title-len info))
(formatted-subtitle (when (org-string-nw-p subtitle)
(org-ascii--fill-string subtitle title-len info)))
(line
(make-string
(min (+ (max title-len
(string-width (or author ""))
(string-width (or email "")))
2)
text-width) (if utf8p ?━ ?_))))
(org-ascii--justify-lines
(concat line "\n"
(unless utf8p "\n")
(upcase formatted-title)
(and formatted-subtitle (concat "\n" formatted-subtitle))
(cond
((and (org-string-nw-p author) (org-string-nw-p email))
(concat "\n\n" author "\n" email))
((org-string-nw-p author) (concat "\n\n" author))
((org-string-nw-p email) (concat "\n\n" email)))
"\n" line
(when (org-string-nw-p date) (concat "\n\n\n" date))
"\n\n\n") text-width 'center)))))
(defun org-ascii-inner-template (contents info)
"Return complete document string after ASCII conversion.
CONTENTS is the transcoded contents string. INFO is a plist
holding export options."
(org-element-normalize-string
(let ((global-margin (plist-get info :ascii-global-margin)))
(org-ascii--indent-string
(concat
;; 1. Document's body.
contents
;; 2. Footnote definitions.
(let ((definitions (org-export-collect-footnote-definitions info))
;; Insert full links right inside the footnote definition
;; as they have no chance to be inserted later.
(info (org-combine-plists info '(:ascii-links-to-notes nil))))
(when definitions
(concat
"\n\n\n"
(let ((title (org-ascii--translate "Footnotes" info)))
(concat
title "\n"
(make-string
(string-width title)
(if (eq (plist-get info :ascii-charset) 'utf-8) ?─ ?_))))
"\n\n"
(let ((text-width (- (plist-get info :ascii-text-width)
global-margin)))
(mapconcat
(lambda (ref)
(let ((id (format "[%s] " (car ref))))
;; Distinguish between inline definitions and
;; full-fledged definitions.
(org-trim
(let ((def (nth 2 ref)))
(if (org-element-map def org-element-all-elements
#'identity info 'first-match)
;; Full-fledged definition: footnote ID is
;; inserted inside the first parsed
;; paragraph (FIRST), if any, to be sure
;; filling will take it into consideration.
(let ((first (car (org-element-contents def))))
(if (not (org-element-type-p first 'paragraph))
(concat id "\n" (org-export-data def info))
(push id (nthcdr 2 first))
(org-export-data def info)))
;; Fill paragraph once footnote ID is inserted
;; in order to have a correct length for first
;; line.
(org-ascii--fill-string
(concat id (org-export-data def info))
text-width info))))))
definitions "\n\n"))))))
global-margin))))
(defun org-ascii-template (contents info)
"Return complete document string after ASCII conversion.
CONTENTS is the transcoded contents string. INFO is a plist
holding export options."
(let ((global-margin (plist-get info :ascii-global-margin)))
(concat
;; Build title block.
(org-ascii--indent-string
(concat (org-ascii-template--document-title info)
;; 2. Table of contents.
(let ((depth (plist-get info :with-toc)))
(when depth
(concat
(org-ascii--build-toc info (and (wholenump depth) depth))
"\n\n\n"))))
global-margin)
;; Document's body.
contents
;; Creator. Justify it to the bottom right.
(and (plist-get info :with-creator)
(org-ascii--indent-string
(let ((text-width
(- (plist-get info :ascii-text-width) global-margin)))
(concat
"\n\n\n"
(org-ascii--fill-string
(plist-get info :creator) text-width info 'right)))
global-margin)))))
(defun org-ascii--translate (s info)
"Translate string S according to specified language and charset.
INFO is a plist used as a communication channel."
(let ((charset (intern (format ":%s" (plist-get info :ascii-charset)))))
(org-export-translate s charset info)))
;;; Transcode Functions
;;;; Bold
(defun org-ascii-bold (_bold contents _info)
"Transcode BOLD from Org to ASCII.
CONTENTS is the text with bold markup. INFO is a plist holding
contextual information."
(format "*%s*" contents))
;;;; Center Block
(defun org-ascii-center-block (_center-block contents _info)
"Transcode a CENTER-BLOCK element from Org to ASCII.
CONTENTS holds the contents of the block. INFO is a plist
holding contextual information."
;; Center has already been taken care of at a lower level, so
;; there's nothing left to do.
contents)
;;;; Clock
(defun org-ascii-clock (clock _contents info)
"Transcode a CLOCK object from Org to ASCII.
CONTENTS is nil. INFO is a plist holding contextual
information."
(org-ascii--justify-element
(concat org-clock-string " "
(org-timestamp-translate (org-element-property :value clock))
(let ((time (org-element-property :duration clock)))
(and time
(concat " => "
(apply 'format
"%2s:%02s"
(org-split-string time ":"))))))
clock info))
;;;; Code
(defun org-ascii-code (code _contents info)
"Return a CODE object from Org to ASCII.
CONTENTS is nil. INFO is a plist holding contextual
information."
(format (plist-get info :ascii-verbatim-format)
(org-element-property :value code)))
;;;; Drawer
(defun org-ascii-drawer (drawer contents info)
"Transcode a DRAWER element from Org to ASCII.
CONTENTS holds the contents of the block. INFO is a plist
holding contextual information."
(let ((name (org-element-property :drawer-name drawer))
(width (org-ascii--current-text-width drawer info)))
(funcall (plist-get info :ascii-format-drawer-function)
name contents width)))
;;;; Dynamic Block
(defun org-ascii-dynamic-block (_dynamic-block contents _info)
"Transcode a DYNAMIC-BLOCK element from Org to ASCII.
CONTENTS holds the contents of the block. INFO is a plist
holding contextual information."
contents)
;;;; Entity
(defun org-ascii-entity (entity _contents info)
"Transcode an ENTITY object from Org to ASCII.
CONTENTS are the definition itself. INFO is a plist holding
contextual information."
(org-element-property
(intern (concat ":" (symbol-name (plist-get info :ascii-charset))))
entity))
;;;; Example Block
(defun org-ascii-example-block (example-block _contents info)
"Transcode a EXAMPLE-BLOCK element from Org to ASCII.
CONTENTS is nil. INFO is a plist holding contextual information."
(org-ascii--justify-element
(org-ascii--box-string
(org-export-format-code-default example-block info) info)
example-block info))
;;;; Export Snippet
(defun org-ascii-export-snippet (export-snippet _contents _info)
"Transcode a EXPORT-SNIPPET object from Org to ASCII.
CONTENTS is nil. INFO is a plist holding contextual information."
(when (eq (org-export-snippet-backend export-snippet) 'ascii)
(org-element-property :value export-snippet)))
;;;; Export Block
(defun org-ascii-export-block (export-block _contents info)
"Transcode a EXPORT-BLOCK element from Org to ASCII.
CONTENTS is nil. INFO is a plist holding contextual information."
(when (string= (org-element-property :type export-block) "ASCII")
(org-ascii--justify-element
(org-element-property :value export-block) export-block info)))
;;;; Fixed Width
(defun org-ascii-fixed-width (fixed-width _contents info)
"Transcode a FIXED-WIDTH element from Org to ASCII.
CONTENTS is nil. INFO is a plist holding contextual information."
(org-ascii--justify-element
(org-ascii--box-string
(org-remove-indentation
(org-element-property :value fixed-width))
info)
fixed-width info))
;;;; Footnote Definition
;; Footnote Definitions are ignored. They are compiled at the end of
;; the document, by `org-ascii-inner-template'.
;;;; Footnote Reference
(defun org-ascii-footnote-reference (footnote-reference _contents info)
"Transcode a FOOTNOTE-REFERENCE element from Org to ASCII.
CONTENTS is nil. INFO is a plist holding contextual information."
(format "[%s]" (org-export-get-footnote-number footnote-reference info)))
;;;; Headline
(defun org-ascii-headline (headline contents info)
"Transcode a HEADLINE element from Org to ASCII.
CONTENTS holds the contents of the headline. INFO is a plist
holding contextual information."
;; Don't export footnote section, which will be handled at the end
;; of the template.
(unless (org-element-property :footnote-section-p headline)
(let* ((low-level (org-export-low-level-p headline info))
(width (org-ascii--current-text-width headline info))
;; Export title early so that any link in it can be
;; exported and seen in `org-ascii--unique-links'.
(title (org-ascii--build-title headline info width (not low-level)))
;; Blank lines between headline and its contents.
;; `org-ascii-headline-spacing', when set, overwrites
;; original buffer's spacing.
(pre-blanks
(make-string (or (car (plist-get info :ascii-headline-spacing))
(org-element-property :pre-blank headline)
0)
?\n))
(links (and (plist-get info :ascii-links-to-notes)
(org-ascii--describe-links
(org-ascii--unique-links headline info) width info)))
;; Re-build contents, inserting section links at the right
;; place. The cost is low since build results are cached.
(body
(if (not (org-string-nw-p links)) contents
(let* ((contents (org-element-contents headline))
(section (let ((first (car contents)))
(and (org-element-type-p first 'section)
first))))
(concat (and section
(concat (org-element-normalize-string
(org-export-data section info))
"\n\n"))
links
(mapconcat (lambda (e) (org-export-data e info))
(if section (cdr contents) contents)
""))))))
;; Deep subtree: export it as a list item.
(if low-level
(let* ((bullets (cdr (assq (plist-get info :ascii-charset)
(plist-get info :ascii-bullets))))
(bullet
(format "%c "
(nth (mod (1- low-level) (length bullets)) bullets))))
(concat bullet title "\n" pre-blanks
;; Contents, indented by length of bullet.
(org-ascii--indent-string body (length bullet))))
;; Else: Standard headline.
(concat title "\n" pre-blanks body)))))
;;;; Horizontal Rule
(defun org-ascii-horizontal-rule (horizontal-rule _contents info)
"Transcode an HORIZONTAL-RULE object from Org to ASCII.
CONTENTS is nil. INFO is a plist holding contextual
information."
(let ((text-width (org-ascii--current-text-width horizontal-rule info))
(spec-width
(org-export-read-attribute :attr_ascii horizontal-rule :width)))
(org-ascii--justify-lines
(make-string (if (and spec-width (string-match "^[0-9]+$" spec-width))
(string-to-number spec-width)
text-width)
(if (eq (plist-get info :ascii-charset) 'utf-8) ?― ?-))
text-width 'center)))
;;;; Inline Src Block
(defun org-ascii-inline-src-block (inline-src-block _contents info)
"Transcode an INLINE-SRC-BLOCK element from Org to ASCII.
CONTENTS holds the contents of the item. INFO is a plist holding
contextual information."
(format (plist-get info :ascii-verbatim-format)
(org-element-property :value inline-src-block)))
;;;; Inlinetask
(defun org-ascii-format-inlinetask-default
(_todo _type _priority _name _tags contents width inlinetask info)
"Format an inline task element for ASCII export.
See `org-ascii-format-inlinetask-function' for a description
of the parameters CONTENTS, WIDTH, INLINETASK, and INFO."
(let* ((utf8p (eq (plist-get info :ascii-charset) 'utf-8))
(width (or width (plist-get info :ascii-inlinetask-width))))
(org-ascii--indent-string
(concat
;; Top line, with an additional blank line if not in UTF-8.
(make-string width (if utf8p ?━ ?_)) "\n"
(unless utf8p (concat (make-string width ? ) "\n"))
;; Add title. Fill it if wider than inlinetask.
(let ((title (org-ascii--build-title inlinetask info width)))
(if (<= (string-width title) width) title
(org-ascii--fill-string title width info)))
"\n"
;; If CONTENTS is not empty, insert it along with
;; a separator.
(when (org-string-nw-p contents)
(concat (make-string width (if utf8p ?─ ?-)) "\n" contents))
;; Bottom line.
(make-string width (if utf8p ?━ ?_)))
;; Flush the inlinetask to the right.
(- (plist-get info :ascii-text-width) (plist-get info :ascii-global-margin)
(if (not (org-element-lineage inlinetask 'headline)) 0
(plist-get info :ascii-inner-margin))
(org-ascii--current-text-width inlinetask info)))))
(defun org-ascii-inlinetask (inlinetask contents info)
"Transcode an INLINETASK element from Org to ASCII.
CONTENTS holds the contents of the block. INFO is a plist
holding contextual information."
(let ((width (org-ascii--current-text-width inlinetask info)))
(funcall (plist-get info :ascii-format-inlinetask-function)
;; todo.
(and (plist-get info :with-todo-keywords)
(let ((todo (org-element-property
:todo-keyword inlinetask)))
(and todo (org-export-data todo info))))
;; todo-type
(org-element-property :todo-type inlinetask)
;; priority
(and (plist-get info :with-priority)
(org-element-property :priority inlinetask))
;; title
(org-export-data (org-element-property :title inlinetask) info)
;; tags
(and (plist-get info :with-tags)
(org-element-property :tags inlinetask))
;; contents and width
contents width inlinetask info)))
;;;; Italic
(defun org-ascii-italic (_italic contents _info)
"Transcode italic from Org to ASCII.
CONTENTS is the text with italic markup. INFO is a plist holding
contextual information."
(format "/%s/" contents))
;;;; Item
(defun org-ascii-item (item contents info)
"Transcode an ITEM element from Org to ASCII.
CONTENTS holds the contents of the item. INFO is a plist holding
contextual information."
(let* ((utf8p (eq (plist-get info :ascii-charset) 'utf-8))
(checkbox (org-ascii--checkbox item info))
(list-type (org-element-property :type (org-element-parent item)))
(bullet
;; First parent of ITEM is always the plain-list. Get
;; `:type' property from it.
(pcase list-type
(`descriptive
(concat checkbox
(org-export-data (org-element-property :tag item)
info)))
(`ordered
;; Return correct number for ITEM, paying attention to
;; counters.
(let* ((struct (org-element-property :structure item))
(bul (org-list-bullet-string
(org-element-property :bullet item)))
(num (number-to-string
(car (last (org-list-get-item-number
(org-element-begin item)
struct
(org-list-prevs-alist struct)
(org-list-parents-alist struct)))))))
(replace-regexp-in-string "[0-9A-Za-z]+" num bul)))
(_ (let ((bul (org-list-bullet-string
(org-element-property :bullet item))))
;; Change bullets into more visible form if UTF-8 is active.
(if (not utf8p) bul
(replace-regexp-in-string
"-" "•"
(replace-regexp-in-string
"\\+" "⁃"
(replace-regexp-in-string "\\*" "‣" bul))))))))
(indentation (if (eq list-type 'descriptive) org-ascii-quote-margin
(string-width bullet))))
(concat
bullet
checkbox
;; Contents: Pay attention to indentation. Note: check-boxes are
;; already taken care of at the paragraph level so they don't
;; interfere with indentation.
(let ((contents (org-ascii--indent-string contents indentation)))
;; Determine if contents should follow the bullet or start
;; a new line. Do the former when the first contributing
;; element to contents is a paragraph. In descriptive lists
;; however, contents always start a new line.
(if (and (not (eq list-type 'descriptive))
(org-string-nw-p contents)
(eq 'paragraph
(org-element-type
(cl-some (lambda (e)
(and (org-string-nw-p (org-export-data e info))
e))
(org-element-contents item)))))
(org-trim contents)
(concat "\n" contents))))))
;;;; Keyword
(defun org-ascii-keyword (keyword _contents info)
"Transcode a KEYWORD element from Org to ASCII.
CONTENTS is nil. INFO is a plist holding contextual
information."
(let ((key (org-element-property :key keyword))
(value (org-element-property :value keyword)))
(cond
((string= key "ASCII") (org-ascii--justify-element value keyword info))
((string= key "TOC")
(org-ascii--justify-element
(let ((case-fold-search t))
(cond
((string-match-p "\\<headlines\\>" value)
(let ((depth (and (string-match "\\<[0-9]+\\>" value)
(string-to-number (match-string 0 value))))
(scope
(cond
((string-match ":target +\\(\".+?\"\\|\\S-+\\)" value) ;link
(org-export-resolve-link
(org-strip-quotes (match-string 1 value)) info))
((string-match-p "\\<local\\>" value) keyword)))) ;local
(org-ascii--build-toc info depth keyword scope)))
((string-match-p "\\<tables\\>" value)
(org-ascii--list-tables keyword info))
((string-match-p "\\<listings\\>" value)
(org-ascii--list-listings keyword info))))
keyword info)))))
;;;; LaTeX Environment
(defun org-ascii-latex-environment (latex-environment _contents info)
"Transcode a LATEX-ENVIRONMENT element from Org to ASCII.
CONTENTS is nil. INFO is a plist holding contextual
information."
(when (plist-get info :with-latex)
(org-ascii--justify-element
(org-remove-indentation (org-element-property :value latex-environment))
latex-environment info)))
;;;; LaTeX Fragment
(defun org-ascii-latex-fragment (latex-fragment _contents info)
"Transcode a LATEX-FRAGMENT object from Org to ASCII.
CONTENTS is nil. INFO is a plist holding contextual
information."
(when (plist-get info :with-latex)
(org-element-property :value latex-fragment)))
;;;; Line Break
(defun org-ascii-line-break (_line-break _contents _info)
"Transcode a LINE-BREAK object from Org to ASCII.
CONTENTS is nil. INFO is a plist holding contextual
information." hard-newline)
;;;; Link
(defun org-ascii-link (link desc info)
"Transcode a LINK object from Org to ASCII.
DESC is the description part of the link, or the empty string.
INFO is a plist holding contextual information."
(let ((type (org-element-property :type link)))
(cond
((org-export-custom-protocol-maybe link desc 'ascii info))
((string= type "coderef")
(let ((ref (org-element-property :path link)))
(format (org-export-get-coderef-format ref desc)
(org-export-resolve-coderef ref info))))
;; Do not apply a special syntax on radio links. Though, use
;; transcoded target's contents as output.
((string= type "radio") desc)
((member type '("custom-id" "fuzzy" "id"))
(let ((destination (if (string= type "fuzzy")
(org-export-resolve-fuzzy-link link info)
(org-export-resolve-id-link link info))))
(pcase (org-element-type destination)
((guard desc)
(if (plist-get info :ascii-links-to-notes)
(format "[%s]" desc)
(format "[%s] (%s)"
desc
(org-ascii--describe-datum destination info))))
;; External file.
(`plain-text destination)
(`headline
(if (org-export-numbered-headline-p destination info)
(mapconcat #'number-to-string
(org-export-get-headline-number destination info)
".")
(org-export-data (org-element-property :title destination) info)))
;; Handle enumerable elements and targets within them.
((and (let number (org-export-get-ordinal
destination info nil #'org-ascii--has-caption-p))
(guard number))
(if (atom number) (number-to-string number)
(mapconcat #'number-to-string number ".")))
;; Don't know what to do. Signal it.
(_ "???"))))
(t
(let ((path (org-element-property :raw-link link)))
(if (not (org-string-nw-p desc)) (format "<%s>" path)
(concat (format "[%s]" desc)
(and (not (plist-get info :ascii-links-to-notes))
(format " (<%s>)" path)))))))))
;;;; Node Properties
(defun org-ascii-node-property (node-property _contents _info)
"Transcode a NODE-PROPERTY element from Org to ASCII.
CONTENTS is nil. INFO is a plist holding contextual
information."
(format "%s:%s"
(org-element-property :key node-property)
(let ((value (org-element-property :value node-property)))
(if value (concat " " value) ""))))
;;;; Paragraph
(defun org-ascii-paragraph (paragraph contents info)
"Transcode a PARAGRAPH element from Org to ASCII.
CONTENTS is the contents of the paragraph, as a string. INFO is
the plist used as a communication channel."
;; Ensure that we do not create multiple paragraphs, when a single
;; paragraph is expected.
;; Multiple newlines may appear in CONTENTS, for example, when
;; certain objects are stripped from export, leaving single newlines
;; before and after.
(setq contents (org-remove-blank-lines contents))
(org-ascii--justify-element
(let ((indented-line-width (plist-get info :ascii-indented-line-width)))
(if (not (wholenump indented-line-width)) contents
(concat
;; Do not indent first paragraph in a section.
(unless (and (not (org-export-get-previous-element paragraph info))
(org-element-type-p
(org-element-parent paragraph) 'section))
(make-string indented-line-width ?\s))
(replace-regexp-in-string "\\`[ \t]+" "" contents))))
paragraph info))
;;;; Plain List
(defun org-ascii-plain-list (plain-list contents info)
"Transcode a PLAIN-LIST element from Org to ASCII.
CONTENTS is the contents of the list. INFO is a plist holding
contextual information."
(let ((margin (plist-get info :ascii-list-margin)))
(if (or (< margin 1)
(org-element-type-p (org-element-parent plain-list) 'item))
contents
(org-ascii--indent-string contents margin))))
;;;; Plain Text
(defun org-ascii-plain-text (text info)
"Transcode a TEXT string from Org to ASCII.
INFO is a plist used as a communication channel."
(let ((utf8p (eq (plist-get info :ascii-charset) 'utf-8)))
(when (and utf8p (plist-get info :with-smart-quotes))
(setq text (org-export-activate-smart-quotes text :utf-8 info)))
(if (not (plist-get info :with-special-strings)) text
(setq text (replace-regexp-in-string "\\\\-" "" text))
(if (not utf8p) text
;; Usual replacements in utf-8 with proper option set.
(replace-regexp-in-string
"\\.\\.\\." "…"
(replace-regexp-in-string
"--" "–"
(replace-regexp-in-string "---" "—" text)))))))
;;;; Planning
(defun org-ascii-planning (planning _contents info)
"Transcode a PLANNING element from Org to ASCII.
CONTENTS is nil. INFO is a plist used as a communication
channel."
(org-ascii--justify-element
(mapconcat
#'identity
(delq nil
(list (let ((closed (org-element-property :closed planning)))
(when closed
(concat org-closed-string " "
(org-timestamp-translate closed))))
(let ((deadline (org-element-property :deadline planning)))
(when deadline
(concat org-deadline-string " "
(org-timestamp-translate deadline))))
(let ((scheduled (org-element-property :scheduled planning)))
(when scheduled
(concat org-scheduled-string " "
(org-timestamp-translate scheduled))))))
" ")
planning info))
;;;; Property Drawer
(defun org-ascii-property-drawer (property-drawer contents info)
"Transcode a PROPERTY-DRAWER element from Org to ASCII.
CONTENTS holds the contents of the drawer. INFO is a plist
holding contextual information."
(and (org-string-nw-p contents)
(org-ascii--justify-element contents property-drawer info)))
;;;; Quote Block
(defun org-ascii-quote-block (_quote-block contents info)
"Transcode a QUOTE-BLOCK element from Org to ASCII.
CONTENTS holds the contents of the block. INFO is a plist
holding contextual information."
(org-ascii--indent-string contents (plist-get info :ascii-quote-margin)))
;;;; Radio Target
(defun org-ascii-radio-target (_radio-target contents _info)
"Transcode a RADIO-TARGET object from Org to ASCII.
CONTENTS is the contents of the target. INFO is a plist holding
contextual information."
contents)
;;;; Section
(defun org-ascii-section (section contents info)
"Transcode a SECTION element from Org to ASCII.
CONTENTS is the contents of the section. INFO is a plist holding
contextual information."
(let ((links
(and (plist-get info :ascii-links-to-notes)
;; Take care of links in first section of the document.
(not (org-element-lineage section 'headline))
(org-ascii--describe-links
(org-ascii--unique-links section info)
(org-ascii--current-text-width section info)
info))))
(org-ascii--indent-string
(if (not (org-string-nw-p links)) contents
(concat (org-element-normalize-string contents) "\n\n" links))
;; Do not apply inner margin if parent headline is low level.
(let ((headline (org-element-lineage section 'headline)))
(if (or (not headline) (org-export-low-level-p headline info)) 0
(plist-get info :ascii-inner-margin))))))
;;;; Special Block
(defun org-ascii-special-block (_special-block contents _info)
"Transcode a SPECIAL-BLOCK element from Org to ASCII.
CONTENTS holds the contents of the block. INFO is a plist
holding contextual information."
;; "JUSTIFYLEFT" and "JUSTIFYRIGHT" have already been taken care of
;; at a lower level. There is no other special block type to
;; handle.
contents)
;;;; Src Block
(defun org-ascii-src-block (src-block _contents info)
"Transcode a SRC-BLOCK element from Org to ASCII.
CONTENTS holds the contents of the item. INFO is a plist holding
contextual information."
(let ((caption (org-ascii--build-caption src-block info))
(caption-above-p (plist-get info :ascii-caption-above))
(code (org-export-format-code-default src-block info)))
(if (equal code "") ""
(org-ascii--justify-element
(concat
(and caption caption-above-p (concat caption "\n"))
(org-ascii--box-string code info)
(and caption (not caption-above-p) (concat "\n" caption)))
src-block info))))
;;;; Statistics Cookie
(defun org-ascii-statistics-cookie (statistics-cookie _contents _info)
"Transcode a STATISTICS-COOKIE object from Org to ASCII.
CONTENTS is nil. INFO is a plist holding contextual information."
(org-element-property :value statistics-cookie))
;;;; Subscript
(defun org-ascii-subscript (subscript contents _info)
"Transcode a SUBSCRIPT object from Org to ASCII.
CONTENTS is the contents of the object. INFO is a plist holding
contextual information."
(if (org-element-property :use-brackets-p subscript)
(format "_{%s}" contents)
(format "_%s" contents)))
;;;; Superscript
(defun org-ascii-superscript (superscript contents _info)
"Transcode a SUPERSCRIPT object from Org to ASCII.
CONTENTS is the contents of the object. INFO is a plist holding
contextual information."
(if (org-element-property :use-brackets-p superscript)
(format "^{%s}" contents)
(format "^%s" contents)))
;;;; Strike-through
(defun org-ascii-strike-through (_strike-through contents _info)
"Transcode STRIKE-THROUGH from Org to ASCII.
CONTENTS is text with strike-through markup. INFO is a plist
holding contextual information."
(format "+%s+" contents))
;;;; Table
(defun org-ascii-table (table contents info)
"Transcode a TABLE element from Org to ASCII.
CONTENTS is the contents of the table. INFO is a plist holding
contextual information."
(let ((caption (org-ascii--build-caption table info))
(caption-above-p (plist-get info :ascii-caption-above)))
(org-ascii--justify-element
(concat
;; Possibly add a caption string above.
(and caption caption-above-p (concat caption "\n"))
;; Insert table. Note: "table.el" tables are left unmodified.
(cond ((eq (org-element-property :type table) 'org) contents)
((and (plist-get info :ascii-table-use-ascii-art)
(eq (plist-get info :ascii-charset) 'utf-8)
(org-require-package 'ascii-art-to-unicode nil 'noerror))
(with-temp-buffer
(insert (org-remove-indentation
(org-element-property :value table)))
(goto-char (point-min))
(aa2u)
(goto-char (point-max))
(skip-chars-backward " \r\t\n")
(buffer-substring (point-min) (point))))
(t (org-remove-indentation (org-element-property :value table))))
;; Possible add a caption string below.
(and (not caption-above-p) caption))
table info)))
;;;; Table Cell
(defun org-ascii--table-cell-width (table-cell info)
"Return width of TABLE-CELL.
INFO is a plist used as a communication channel.
Width of a cell is determined either by a width cookie in the
same column as the cell, or by the maximum cell's length in that
column.
When `org-ascii-table-widen-columns' is non-nil, width cookies
are ignored."
(let* ((row (org-element-parent table-cell))
(table (org-element-parent row))
(col (let ((cells (org-element-contents row)))
(- (length cells) (length (memq table-cell cells)))))
(cache
(or (plist-get info :ascii-table-cell-width-cache)
(plist-get (setq info
(plist-put info :ascii-table-cell-width-cache
(make-hash-table :test 'equal)))
:ascii-table-cell-width-cache)))
(key (cons table col))
(widenp (plist-get info :ascii-table-widen-columns)))
(or (gethash key cache)
(puthash
key
(let ((cookie-width (org-export-table-cell-width table-cell info)))
(or (and (not widenp) cookie-width)
(let ((contents-width
(let ((max-width 0))
(org-element-map table 'table-row
(lambda (row)
(setq max-width
(max (string-width
(org-export-data
(org-element-contents
(elt (org-element-contents row) col))
info))
max-width)))
info)
max-width)))
(cond ((not cookie-width) contents-width)
(widenp (max cookie-width contents-width))
(t cookie-width)))))
cache))))
(defun org-ascii-table-cell (table-cell contents info)
"Transcode a TABLE-CELL object from Org to ASCII.
CONTENTS is the cell contents. INFO is a plist used as
a communication channel."
;; Determine column width. When `org-ascii-table-widen-columns'
;; is nil and some width cookie has set it, use that value.
;; Otherwise, compute the maximum width among transcoded data of
;; each cell in the column.
(let ((width (org-ascii--table-cell-width table-cell info)))
;; When contents are too large, truncate them.
(unless (or (plist-get info :ascii-table-widen-columns)
(<= (string-width (or contents "")) width))
(setq contents (concat (substring contents 0 (- width 2)) "=>")))
;; Align contents correctly within the cell.
(let* ((indent-tabs-mode nil)
(data
(when contents
(org-ascii--justify-lines
contents width
(org-export-table-cell-alignment table-cell info)))))
(setq contents
(concat data
;; FIXME: If CONTENTS was transformed by filters,
;; the whole width calculation can be wrong.
;; At least, make sure that we do not throw error
;; when CONTENTS is larger than width.
(make-string (max 0 (- width (string-width (or data "")))) ?\s))))
;; Return cell.
(concat (format " %s " contents)
(when (memq 'right (org-export-table-cell-borders table-cell info))
(if (eq (plist-get info :ascii-charset) 'utf-8) "│" "|")))))
;;;; Table Row
(defun org-ascii-table-row (table-row contents info)
"Transcode a TABLE-ROW element from Org to ASCII.
CONTENTS is the row contents. INFO is a plist used as
a communication channel."
(when (eq (org-element-property :type table-row) 'standard)
(let ((build-hline
(lambda (lcorner horiz vert rcorner)
(concat
(apply
'concat
(org-element-map table-row 'table-cell
(lambda (cell)
(let ((width (org-ascii--table-cell-width cell info))
(borders (org-export-table-cell-borders cell info)))
(concat
;; In order to know if CELL starts the row, do
;; not compare it with the first cell in the
;; row as there might be a special column.
;; Instead, compare it with first exportable
;; cell, obtained with `org-element-map'.
(when (and (memq 'left borders)
(eq (org-element-map table-row 'table-cell
'identity info t)
cell))
lcorner)
(make-string (+ 2 width) (string-to-char horiz))
(cond
((not (memq 'right borders)) nil)
((eq (car (last (org-element-contents table-row))) cell)
rcorner)
(t vert)))))
info)) "\n")))
(utf8p (eq (plist-get info :ascii-charset) 'utf-8))
(borders (org-export-table-cell-borders
(org-element-map table-row 'table-cell 'identity info t)
info)))
(concat (cond
((and (memq 'top borders) (or utf8p (memq 'above borders)))
(if utf8p (funcall build-hline "┍" "━" "┯" "┑")
(funcall build-hline "+" "-" "+" "+")))
((memq 'above borders)
(if utf8p (funcall build-hline "├" "─" "┼" "┤")
(funcall build-hline "+" "-" "+" "+"))))
(when (memq 'left borders) (if utf8p "│" "|"))
contents "\n"
(when (and (memq 'bottom borders) (or utf8p (memq 'below borders)))
(if utf8p (funcall build-hline "┕" "━" "┷" "┙")
(funcall build-hline "+" "-" "+" "+")))))))
;;;; Timestamp
(defun org-ascii-timestamp (timestamp _contents info)
"Transcode a TIMESTAMP object from Org to ASCII.
CONTENTS is nil. INFO is a plist holding contextual information."
(org-ascii-plain-text (org-timestamp-translate timestamp) info))
;;;; Underline
(defun org-ascii-underline (_underline contents _info)
"Transcode UNDERLINE from Org to ASCII.
CONTENTS is the text with underline markup. INFO is a plist
holding contextual information."
(format "_%s_" contents))
;;;; Verbatim
(defun org-ascii-verbatim (verbatim _contents info)
"Return a VERBATIM object from Org to ASCII.
CONTENTS is nil. INFO is a plist holding contextual information."
(format (plist-get info :ascii-verbatim-format)
(org-element-property :value verbatim)))
;;;; Verse Block
(defun org-ascii-verse-block (verse-block contents info)
"Transcode a VERSE-BLOCK element from Org to ASCII.
CONTENTS is verse block contents. INFO is a plist holding
contextual information."
(org-ascii--indent-string
(org-ascii--justify-element contents verse-block info)
(plist-get info :ascii-quote-margin)))
;;; Filters
(defun org-ascii-filter-headline-blank-lines (headline _backend info)
"Filter controlling number of blank lines after a headline.
HEADLINE is a string representing a transcoded headline. BACKEND
is symbol specifying backend used for export. INFO is plist
containing the communication channel.
This function only applies to `ascii' backend. See
`org-ascii-headline-spacing' for information."
(let ((headline-spacing (plist-get info :ascii-headline-spacing)))
(if (not headline-spacing) headline
(let ((blanks (make-string (1+ (cdr headline-spacing)) ?\n)))
(replace-regexp-in-string "\n\\(?:\n[ \t]*\\)*\\'" blanks headline)))))
(defun org-ascii-filter-paragraph-spacing (tree _backend info)
"Filter controlling number of blank lines between paragraphs.
TREE is the parse tree. BACKEND is the symbol specifying
backend used for export. INFO is a plist used as
a communication channel.
See `org-ascii-paragraph-spacing' for information."
(let ((paragraph-spacing (plist-get info :ascii-paragraph-spacing)))
(when (wholenump paragraph-spacing)
(org-element-map tree 'paragraph
(lambda (p)
(when (org-element-type-p
(org-export-get-next-element p info) 'paragraph)
(org-element-put-property p :post-blank paragraph-spacing))))))
tree)
(defun org-ascii-filter-comment-spacing (tree _backend info)
"Filter removing blank lines between comments.
TREE is the parse tree. BACKEND is the symbol specifying
backend used for export. INFO is a plist used as
a communication channel."
(org-element-map tree '(comment comment-block)
(lambda (c)
(when (org-element-type-p
(org-export-get-next-element c info)
'(comment comment-block))
(org-element-put-property c :post-blank 0))))
tree)
;;; End-user functions
;;;###autoload
(defun org-ascii-convert-region-to-ascii ()
"Assume region has Org syntax, and convert it to plain ASCII."
(interactive)
(let ((org-ascii-charset 'ascii))
(org-export-replace-region-by 'ascii)))
(defalias 'org-export-region-to-ascii #'org-ascii-convert-region-to-ascii)
;;;###autoload
(defun org-ascii-convert-region-to-utf8 ()
"Assume region has Org syntax, and convert it to UTF-8."
(interactive)
(let ((org-ascii-charset 'utf-8))
(org-export-replace-region-by 'ascii)))
(defalias 'org-export-region-to-utf8 #'org-ascii-convert-region-to-utf8)
;;;###autoload
(defun org-ascii-export-as-ascii
(&optional async subtreep visible-only body-only ext-plist)
"Export current buffer to a text buffer.
If narrowing is active in the current buffer, only export its
narrowed part.
If a region is active, export that region.
A non-nil optional argument ASYNC means the process should happen
asynchronously. The resulting buffer should be accessible
through the `org-export-stack' interface.
When optional argument SUBTREEP is non-nil, export the sub-tree
at point, extracting information from the headline properties
first.
When optional argument VISIBLE-ONLY is non-nil, don't export
contents of hidden elements.
When optional argument BODY-ONLY is non-nil, strip title and
table of contents from output.
EXT-PLIST, when provided, is a property list with external
parameters overriding Org default settings, but still inferior to
file-local settings.
Export is done in a buffer named \"*Org ASCII Export*\", which
will be displayed when `org-export-show-temporary-export-buffer'
is non-nil."
(interactive)
(org-export-to-buffer 'ascii "*Org ASCII Export*"
async subtreep visible-only body-only ext-plist (lambda () (text-mode))))
;;;###autoload
(defun org-ascii-export-to-ascii
(&optional async subtreep visible-only body-only ext-plist)
"Export current buffer to a text file.
If narrowing is active in the current buffer, only export its
narrowed part.
If a region is active, export that region.
A non-nil optional argument ASYNC means the process should happen
asynchronously. The resulting file should be accessible through
the `org-export-stack' interface.
When optional argument SUBTREEP is non-nil, export the sub-tree
at point, extracting information from the headline properties
first.
When optional argument VISIBLE-ONLY is non-nil, don't export
contents of hidden elements.
When optional argument BODY-ONLY is non-nil, strip title and
table of contents from output.
EXT-PLIST, when provided, is a property list with external
parameters overriding Org default settings, but still inferior to
file-local settings.
Return output file's name."
(interactive)
(let ((file (org-export-output-file-name ".txt" subtreep)))
(org-export-to-file 'ascii file
async subtreep visible-only body-only ext-plist)))
;;;###autoload
(defun org-ascii-publish-to-ascii (plist filename pub-dir)
"Publish an Org file to ASCII.
FILENAME is the filename of the Org file to be published. PLIST
is the property list for the given project. PUB-DIR is the
publishing directory.
Return output file name."
(org-publish-org-to
'ascii filename ".txt" `(:ascii-charset ascii ,@plist) pub-dir))
;;;###autoload
(defun org-ascii-publish-to-latin1 (plist filename pub-dir)
"Publish an Org file to Latin-1.
FILENAME is the filename of the Org file to be published. PLIST
is the property list for the given project. PUB-DIR is the
publishing directory.
Return output file name."
(org-publish-org-to
'ascii filename ".txt" `(:ascii-charset latin1 ,@plist) pub-dir))
;;;###autoload
(defun org-ascii-publish-to-utf8 (plist filename pub-dir)
"Publish an org file to UTF-8.
FILENAME is the filename of the Org file to be published. PLIST
is the property list for the given project. PUB-DIR is the
publishing directory.
Return output file name."
(org-publish-org-to
'ascii filename ".txt" `(:ascii-charset utf-8 ,@plist) pub-dir))
(provide 'ox-ascii)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; coding: utf-8
;; End:
;;; ox-ascii.el ends here
org-mode-9.7.29+dfsg/lisp/ox-beamer.el 0000664 0000000 0000000 00000133074 15004304337 0017431 0 ustar 00root root 0000000 0000000 ;;; ox-beamer.el --- Beamer Backend for Org Export Engine -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2025 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik AT gmail DOT com>
;; Nicolas Goaziou <n.goaziou AT gmail DOT com>
;; Keywords: org, text, tex
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; This library implements both a Beamer backend, derived from the
;; LaTeX one and a minor mode easing structure edition of the
;; document. See Org manual for more information.
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'cl-lib)
(require 'ox-latex)
;; Install a default set-up for Beamer export.
(unless (assoc "beamer" org-latex-classes)
(add-to-list 'org-latex-classes
'("beamer"
"\\documentclass[presentation]{beamer}"
("\\section{%s}" . "\\section*{%s}")
("\\subsection{%s}" . "\\subsection*{%s}")
("\\subsubsection{%s}" . "\\subsubsection*{%s}"))))
;;; User-Configurable Variables
(defgroup org-export-beamer nil
"Options specific for using the beamer class in LaTeX export."
:tag "Org Beamer"
:group 'org-export
:version "24.2")
(defcustom org-beamer-frame-level 1
"The level at which headlines become frames.
Headlines at a lower level will be translated into a sectioning
structure. At a higher level, they will be translated into
blocks.
If a headline with a \"BEAMER_env\" property set to \"frame\" is
found within a tree, its level locally overrides this number.
This variable has no effect on headlines with the \"BEAMER_env\"
property set to either \"ignoreheading\", \"appendix\", or
\"note\", which will respectively, be invisible, become an
appendix or a note.
This integer is relative to the minimal level of a headline
within the parse tree, defined as 1."
:group 'org-export-beamer
:type 'integer)
(defcustom org-beamer-frame-default-options ""
"Default options string to use for frames.
For example, it could be set to \"allowframebreaks\"."
:group 'org-export-beamer
:type '(string :tag "[options]"))
(defcustom org-beamer-column-view-format
"%45ITEM %10BEAMER_env(Env) %10BEAMER_act(Act) %4BEAMER_col(Col) %8BEAMER_opt(Opt)"
"Column view format that should be used to fill the template."
:group 'org-export-beamer
:version "24.4"
:package-version '(Org . "8.0")
:type '(choice
(const :tag "Do not insert Beamer column view format" nil)
(string :tag "Beamer column view format")))
(defcustom org-beamer-theme "default"
"Default theme used in Beamer presentations."
:group 'org-export-beamer
:version "24.4"
:package-version '(Org . "8.0")
:type '(choice
(const :tag "Do not insert a Beamer theme" nil)
(string :tag "Beamer theme")))
(defcustom org-beamer-environments-extra nil
"Environments triggered by tags in Beamer export.
Each entry has 4 elements:
name Name of the environment
key Selection key for `org-beamer-select-environment'
open The opening template for the environment, with the following escapes
%a the action/overlay specification
%A the default action/overlay specification
%R the raw BEAMER_act value
%o the options argument, with square brackets
%O the raw BEAMER_opt value
%h the headline text
%r the raw headline text (i.e. without any processing)
%H if there is headline text, that raw text in {} braces
%U if there is headline text, that raw text in [] brackets
%l the label, obtained from `org-beamer--get-label'
close The closing string of the environment."
:group 'org-export-beamer
:package-version '(Org . "9.7")
:type '(repeat
(list
(string :tag "Environment")
(string :tag "Selection key")
(string :tag "Begin")
(string :tag "End"))))
(defcustom org-beamer-outline-frame-title "Outline"
"Default title of a frame containing an outline."
:group 'org-export-beamer
:type '(string :tag "Outline frame title"))
(defcustom org-beamer-outline-frame-options ""
"Outline frame options appended after \\begin{frame}.
You might want to put e.g. \"allowframebreaks=0.9\" here."
:group 'org-export-beamer
:type '(string :tag "Outline frame options"))
(defcustom org-beamer-subtitle-format "\\subtitle{%s}"
"Format string used for transcoded subtitle.
The format string should have at most one \"%s\"-expression,
which is replaced with the subtitle."
:group 'org-export-beamer
:version "26.1"
:package-version '(Org . "8.3")
:type '(string :tag "Format string"))
(defcustom org-beamer-frame-environment "orgframe"
"Name of the alternative beamer frame environment.
In frames marked as fragile, this environment is used in place of
the usual frame environment.
This permits insertion of a beamer frame inside example blocks,
working around beamer limitations. See
https://list.orgmode.org/87a5nux3zr.fsf@t14.reltub.ca/T/#mc7221e93f138bdd56c916b194b9230d3a6c3de09
This option may need to be changed when \"\\end{orgframe}\" string is
used inside beamer slides."
:group 'org-export-beamer
:package-version '(Org . "9.7")
:type '(string :tag "Beamer frame")
:safe (lambda (str) (string-match-p "^[A-Za-z]+$" str)))
;;; Internal Variables
(defconst org-beamer-column-widths
"0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 0.0 :ETC"
"The column widths that should be installed as allowed property values.")
(defconst org-beamer-environments-special
'(("againframe" "A")
("appendix" "x")
("column" "c")
("columns" "C")
("frame" "f")
("fullframe" "F")
("ignoreheading" "i")
("note" "n")
("noteNH" "N"))
"Alist of environments treated in a special way by the backend.
Keys are environment names, as strings, values are bindings used
in `org-beamer-select-environment'. Environments listed here,
along with their binding, are hard coded and cannot be modified
through `org-beamer-environments-extra' variable.")
(defconst org-beamer-environments-default
'(("block" "b" "\\begin{block}%a{%h}" "\\end{block}")
("alertblock" "a" "\\begin{alertblock}%a{%h}" "\\end{alertblock}")
("verse" "v" "\\begin{verse}%a %% %h" "\\end{verse}")
("quotation" "q" "\\begin{quotation}%a %% %h" "\\end{quotation}")
("quote" "Q" "\\begin{quote}%a %% %h" "\\end{quote}")
("structureenv" "s" "\\begin{structureenv}%a %% %h" "\\end{structureenv}")
("theorem" "t" "\\begin{theorem}%a[%h]%l" "\\end{theorem}")
("definition" "d" "\\begin{definition}%a[%h]%l" "\\end{definition}")
("example" "e" "\\begin{example}%a[%h]%l" "\\end{example}")
("exampleblock" "E" "\\begin{exampleblock}%a{%h}%l" "\\end{exampleblock}")
("proof" "p" "\\begin{proof}%a[%h]" "\\end{proof}")
("beamercolorbox" "o" "\\begin{beamercolorbox}%o{%h}" "\\end{beamercolorbox}"))
"Environments triggered by properties in Beamer export.
These are the defaults - for user definitions, see
`org-beamer-environments-extra'.")
(defconst org-beamer-verbatim-elements
'(code example-block fixed-width inline-src-block src-block verbatim)
"List of element or object types producing verbatim text.
This is used internally to determine when a frame should have the
\"fragile\" option.")
;;; Internal functions
(defun org-beamer--normalize-argument (argument type)
"Return ARGUMENT string with proper boundaries.
TYPE is a symbol among the following:
`action' Return ARGUMENT within angular brackets.
`defaction' Return ARGUMENT within both square and angular brackets.
`option' Return ARGUMENT within square brackets."
(if (not (string-match "\\S-" argument)) ""
(cl-case type
(action (format "<%s>" (org-unbracket-string "<" ">" argument)))
(defaction
(format "[<%s>]"
(org-unbracket-string "<" ">" (org-unbracket-string "[" "]" argument))))
(option (format "[%s]" (org-unbracket-string "[" "]" argument)))
(otherwise (error "Invalid `type' argument to `org-beamer--normalize-argument': %s"
type)))))
(defun org-beamer--element-has-overlay-p (element)
"Non-nil when ELEMENT has an overlay specified.
An element has an overlay specification when it starts with an
`beamer' export-snippet whose value is between angular brackets.
Return overlay specification, as a string, or nil."
(let ((first-object (car (org-element-contents element))))
(when (org-element-type-p first-object 'export-snippet)
(let ((value (org-element-property :value first-object)))
(and (string-prefix-p "<" value) (string-suffix-p ">" value)
value)))))
;;; Define Backend
(org-export-define-derived-backend 'beamer 'latex
:menu-entry
'(?l 1
((?B "As LaTeX buffer (Beamer)" org-beamer-export-as-latex)
(?b "As LaTeX file (Beamer)" org-beamer-export-to-latex)
(?P "As PDF file (Beamer)" org-beamer-export-to-pdf)
(?O "As PDF file and open (Beamer)"
(lambda (a s v b)
(if a (org-beamer-export-to-pdf t s v b)
(org-open-file (org-beamer-export-to-pdf nil s v b)))))))
:options-alist
'((:headline-levels nil "H" org-beamer-frame-level)
(:latex-class "LATEX_CLASS" nil "beamer" t)
(:beamer-subtitle-format nil nil org-beamer-subtitle-format)
(:beamer-column-view-format "COLUMNS" nil org-beamer-column-view-format)
(:beamer-theme "BEAMER_THEME" nil org-beamer-theme)
(:beamer-color-theme "BEAMER_COLOR_THEME" nil nil t)
(:beamer-font-theme "BEAMER_FONT_THEME" nil nil t)
(:beamer-inner-theme "BEAMER_INNER_THEME" nil nil t)
(:beamer-outer-theme "BEAMER_OUTER_THEME" nil nil t)
(:beamer-header "BEAMER_HEADER" nil nil newline)
(:beamer-environments-extra nil nil org-beamer-environments-extra)
(:beamer-frame-default-options nil nil org-beamer-frame-default-options)
(:beamer-outline-frame-options nil nil org-beamer-outline-frame-options)
(:beamer-outline-frame-title nil nil org-beamer-outline-frame-title))
:translate-alist '((bold . org-beamer-bold)
(export-block . org-beamer-export-block)
(export-snippet . org-beamer-export-snippet)
(headline . org-beamer-headline)
(item . org-beamer-item)
(keyword . org-beamer-keyword)
(link . org-beamer-link)
(plain-list . org-beamer-plain-list)
(radio-target . org-beamer-radio-target)
(template . org-beamer-template)))
;;; Transcode Functions
;;;; Bold
(defun org-beamer-bold (bold contents _info)
"Transcode BOLD object into Beamer code.
CONTENTS is the text being bold. INFO is a plist used as
a communication channel."
(format "\\alert%s{%s}"
(or (org-beamer--element-has-overlay-p bold) "")
contents))
;;;; Export Block
(defun org-beamer-export-block (export-block _contents _info)
"Transcode an EXPORT-BLOCK element into Beamer code.
CONTENTS is nil. INFO is a plist used as a communication
channel."
(when (member (org-element-property :type export-block) '("BEAMER" "LATEX"))
(org-remove-indentation (org-element-property :value export-block))))
;;;; Export Snippet
(defun org-beamer-export-snippet (export-snippet _contents info)
"Transcode an EXPORT-SNIPPET object into Beamer code.
CONTENTS is nil. INFO is a plist used as a communication
channel."
(let ((backend (org-export-snippet-backend export-snippet))
(value (org-element-property :value export-snippet)))
;; Only "latex" and "beamer" snippets are retained.
(cond ((eq backend 'latex) value)
;; Ignore "beamer" snippets specifying overlays.
((and (eq backend 'beamer)
(or (org-export-get-previous-element export-snippet info)
(not (string-match "\\`<.*>\\'" value))))
value))))
;;;; Headline
;;
;; The main function to translate a headline is
;; `org-beamer-headline'.
;;
;; Depending on the level at which a headline is considered as
;; a frame (given by `org-beamer--frame-level'), the headline is
;; either a section (`org-beamer--format-section'), a frame
;; (`org-beamer--format-frame') or a block
;; (`org-beamer--format-block').
;;
;; `org-beamer-headline' also takes care of special environments
;; like "ignoreheading", "note", "noteNH", "appendix" and
;; "againframe".
(defun org-beamer--get-label (headline info)
"Return label for HEADLINE, as a string.
INFO is a plist used as a communication channel.
The value is either the label specified in \"BEAMER_opt\"
property, the custom ID, if there is one and
`:latex-prefer-user-labels' property has a non-nil value, or
a unique internal label. This function assumes HEADLINE will be
treated as a frame."
(cond
((let ((opt (org-element-property :BEAMER_OPT headline)))
(and (stringp opt)
(string-match "\\(?:^\\|,\\)label=\\(.*?\\)\\(?:$\\|,\\)" opt)
(let ((label (match-string 1 opt)))
(if (string-match-p "\\`{.*}\\'" label)
(substring label 1 -1)
label)))))
((and (plist-get info :latex-prefer-user-labels)
(org-element-property :CUSTOM_ID headline)))
(t (format "sec:%s" (org-export-get-reference headline info)))))
(defun org-beamer--frame-level (headline info)
"Return frame level in subtree containing HEADLINE.
INFO is a plist used as a communication channel."
(or
;; 1. Look for "frame" environment in parents, starting from the
;; farthest.
(catch 'exit
(dolist (parent (nreverse (org-element-lineage headline)))
(let ((env (org-element-property :BEAMER_ENV parent)))
(when (and env (member-ignore-case env '("frame" "fullframe")))
(throw 'exit (org-export-get-relative-level parent info))))))
;; 2. Look for "frame" environment in HEADLINE.
(let ((env (org-element-property :BEAMER_ENV headline)))
(and env (member-ignore-case env '("frame" "fullframe"))
(org-export-get-relative-level headline info)))
;; 3. Look for "frame" environment in sub-tree.
(org-element-map headline 'headline
(lambda (hl)
(let ((env (org-element-property :BEAMER_ENV hl)))
(when (and env (member-ignore-case env '("frame" "fullframe")))
(org-export-get-relative-level hl info))))
info 'first-match)
;; 4. No "frame" environment in tree: use default value.
(plist-get info :headline-levels)))
(defun org-beamer--format-section (headline contents info)
"Format HEADLINE as a sectioning part.
CONTENTS holds the contents of the headline. INFO is a plist
used as a communication channel."
(let ((latex-headline
(org-export-with-backend
;; We create a temporary export backend which behaves the
;; same as current one, but adds "\protect" in front of the
;; output of some objects.
(org-export-create-backend
:parent 'latex
:transcoders
(let ((protected-output
(lambda (object contents info)
(let ((code (org-export-with-backend
'beamer object contents info)))
(if (org-string-nw-p code) (concat "\\protect" code)
code)))))
(mapcar (lambda (type) (cons type protected-output))
'(bold footnote-reference italic strike-through timestamp
underline))))
headline
contents
info))
(mode-specs (org-element-property :BEAMER_ACT headline)))
(if (and mode-specs
(string-match "\\`\\\\\\(.*?\\)\\(?:\\*\\|\\[.*\\]\\)?{"
latex-headline))
;; Insert overlay specifications.
(replace-match (concat (match-string 1 latex-headline)
(format "<%s>" mode-specs))
nil nil latex-headline 1)
latex-headline)))
(defun org-beamer--format-frame (headline contents info)
"Format HEADLINE as a frame.
CONTENTS holds the contents of the headline. INFO is a plist
used as a communication channel."
(let* ((fragilep
;; FRAGILEP is non-nil when HEADLINE contains an element
;; among `org-beamer-verbatim-elements'.
(org-element-map headline org-beamer-verbatim-elements 'identity
info 'first-match))
;; If FRAGILEP is non-nil and CONTENTS contains an occurrence
;; of \begin{frame} or \end{frame}, then set the FRAME
;; environment to be `org-beamer-frame-environment';
;; otherwise, use "frame". If the selected environment is not
;; "frame", then add the property :beamer-define-frame to
;; INFO and set it to t.
(frame (let ((selection
(or (and fragilep
(or (string-match-p "\\\\begin{frame}" contents)
(string-match-p "\\\\end{frame}" contents))
org-beamer-frame-environment)
"frame")))
(unless (string= selection "frame")
(setq info (plist-put info :beamer-define-frame t)))
selection)))
(concat "\\begin{" frame "}"
;; Overlay specification, if any. When surrounded by
;; square brackets, consider it as a default
;; specification.
(let ((action (org-element-property :BEAMER_ACT headline)))
(cond
((not action) "")
((string-match "\\`\\[.*\\]\\'" action )
(org-beamer--normalize-argument action 'defaction))
(t (org-beamer--normalize-argument action 'action))))
;; Options, if any.
(let* ((beamer-opt (org-element-property :BEAMER_OPT headline))
(options
;; Collect nonempty options from default value and
;; headline's properties.
(cl-remove-if-not #'org-string-nw-p
(append
(org-split-string
(plist-get info :beamer-frame-default-options) ",")
(and beamer-opt
(org-split-string
;; Remove square brackets if user provided
;; them.
(and (string-match "^\\[?\\(.*\\)\\]?$" beamer-opt)
(match-string 1 beamer-opt))
",")))))
(fragile
;; Add "fragile" option if necessary.
(and fragilep
(not (member "fragile" options))
(list "fragile")))
(label
;; Provide an automatic label for the frame unless
;; the user specified one. Also refrain from
;; labeling `allowframebreaks' frames; this is not
;; allowed by Beamer.
(and (not (member "allowframebreaks" options))
(not (cl-some (lambda (s) (string-match-p "^label=" s))
options))
(list
(let ((label (org-beamer--get-label headline info)))
;; Labels containing colons need to be
;; wrapped within braces.
(format (if (string-match-p ":" label)
"label={%s}"
"label=%s")
label))))))
;; Change options list into a string.
(org-beamer--normalize-argument
(mapconcat #'identity (append label fragile options) ",")
'option))
;; Title.
(let ((env (org-element-property :BEAMER_ENV headline)))
(format "{%s}"
(if (and env (equal (downcase env) "fullframe")) ""
(org-export-data
(org-element-property :title headline) info))))
"\n"
;; The following workaround is required in fragile frames
;; as Beamer will append "\par" to the beginning of the
;; contents. So we need to make sure the command is
;; separated from the contents by at least one space. If
;; it isn't, it will create "\parfirst-word" command and
;; remove the first word from the contents in the PDF
;; output.
(if (not fragilep) contents
(replace-regexp-in-string "\\`\n*" "\\& " (or contents "")))
"\\end{" frame "}")))
(defun org-beamer--format-block (headline contents info)
"Format HEADLINE as a block.
CONTENTS holds the contents of the headline. INFO is a plist
used as a communication channel."
(let* ((column-width (org-element-property :BEAMER_COL headline))
;; ENVIRONMENT defaults to "block" if none is specified and
;; there is no column specification. If there is a column
;; specified but still no explicit environment, ENVIRONMENT
;; is "column".
(environment (let ((env (org-element-property :BEAMER_ENV headline)))
(cond
;; "block" is the fallback environment.
((and (not env) (not column-width)) "block")
;; "column" only.
((not env) "column")
;; Use specified environment.
(t env))))
(raw-title (org-element-property :raw-value headline))
(env-format
(cond ((member environment '("column" "columns")) nil)
((assoc environment
(append (plist-get info :beamer-environments-extra)
org-beamer-environments-default)))
(t (user-error "Wrong block type at a headline named \"%s\""
raw-title))))
(title (org-export-data (org-element-property :title headline) info))
(raw-options (org-element-property :BEAMER_OPT headline))
(options (if raw-options
(org-beamer--normalize-argument raw-options 'option)
""))
;; also process actions
(raw-action (org-element-property :BEAMER_ACT headline))
(action (if raw-action
;; If BEAMER_act property has its value enclosed in square
;; brackets, it is a default overlay specification and
;; overlay specification is empty. Otherwise, it is an
;; overlay specification and the default one is nil.
(org-beamer--normalize-argument
raw-action
(if (string-match "\\`\\[.*\\]\\'" raw-action) 'defaction
'action))
""))
;; Start a "columns" environment when explicitly requested or
;; when there is no previous headline or the previous
;; headline do not have a BEAMER_column property.
(parent-env (org-element-property
:BEAMER_ENV (org-element-lineage headline 'headline)))
(start-columns-p
(or (equal environment "columns")
(and column-width
(not (and parent-env
(equal (downcase parent-env) "columns")))
(or (org-export-first-sibling-p headline info)
(not (org-element-property
:BEAMER_COL
(org-export-get-previous-element
headline info)))))))
;; End the "columns" environment when explicitly requested or
;; when there is no next headline or the next headline do not
;; have a BEAMER_column property.
(end-columns-p
(or (equal environment "columns")
(and column-width
(not (and parent-env
(equal (downcase parent-env) "columns")))
(or (org-export-last-sibling-p headline info)
(not (org-element-property
:BEAMER_COL
(org-export-get-next-element headline info))))))))
(concat
(when start-columns-p
;; Column can accept options only when the environment is
;; explicitly defined.
(if (not (equal environment "columns")) "\\begin{columns}\n"
(format "\\begin{columns}%s\n" options)))
(when column-width
(format "\\begin{column}%s%s{%s}\n"
;; One can specify placement for column only when
;; HEADLINE stands for a column on its own.
options
(if env-format
"" ; Inner environment is specified - pass actions later.
action)
(format "%s\\columnwidth" column-width)))
;; Block's opening string.
(when (nth 2 env-format)
(concat
(org-fill-template
(nth 2 env-format)
(nconc
(cond
((not action) (list (cons "a" "") (cons "A" "") (cons "R" "")))
((and (string-prefix-p "[" action)
(string-suffix-p "]" action))
(list
(cons "A" (org-beamer--normalize-argument action 'defaction))
(cons "a" "")
(cons "R" raw-action)))
(t
(list (cons "a" action)
(cons "A" "")
(cons "R" raw-action))))
(list (cons "o" options)
(cons "O" (or raw-options ""))
(cons "h" title)
(cons "r" raw-title)
(cons "l" (format "\\label{%s}" (org-beamer--get-label headline info)))
(cons "H" (if (equal raw-title "") ""
(format "{%s}" raw-title)))
(cons "U" (if (equal raw-title "") ""
(format "[%s]" raw-title))))))
"\n"))
contents
;; Block's closing string, if any.
(and (nth 3 env-format) (concat (nth 3 env-format) "\n"))
(when column-width "\\end{column}\n")
(when end-columns-p "\\end{columns}"))))
(defun org-beamer-headline (headline contents info)
"Transcode HEADLINE element into Beamer code.
CONTENTS is the contents of the headline. INFO is a plist used
as a communication channel."
(unless (org-element-property :footnote-section-p headline)
(let ((level (org-export-get-relative-level headline info))
(frame-level (org-beamer--frame-level headline info))
(environment (let ((env (org-element-property :BEAMER_ENV headline)))
(or (org-string-nw-p env) "block"))))
(cond
;; Case 1: Resume frame specified by "BEAMER_ref" property.
((equal environment "againframe")
(let ((ref (org-element-property :BEAMER_REF headline)))
;; Reference to frame being resumed is mandatory. Ignore
;; the whole headline if it isn't provided.
(when (org-string-nw-p ref)
(concat "\\againframe"
;; Overlay specification.
(let ((overlay (org-element-property :BEAMER_ACT headline)))
(when overlay
(org-beamer--normalize-argument
overlay
(if (string-match "\\`\\[.*\\]\\'" overlay) 'defaction
'action))))
;; Options.
(let ((options (org-element-property :BEAMER_OPT headline)))
(when options
(org-beamer--normalize-argument options 'option)))
;; Resolve reference provided by "BEAMER_ref"
;; property. This is done by building a minimal
;; fake link and calling the appropriate resolve
;; function, depending on the reference syntax.
(let ((target
(if (string-match "\\`\\(id:\\|#\\)" ref)
(org-export-resolve-id-link
`(link (:path ,(substring ref (match-end 0))))
info)
(org-export-resolve-fuzzy-link
`(link (:path
;; Look for headlines only.
,(if (eq (string-to-char ref) ?*) ref
(concat "*" ref))))
info))))
;; Now use user-defined label provided in TARGET
;; headline, or fallback to standard one.
(format "{%s}" (org-beamer--get-label target info)))))))
;; Case 2: Creation of an appendix is requested.
((equal environment "appendix")
(concat "\\appendix"
(org-element-property :BEAMER_ACT headline)
"\n"
(make-string (org-element-property :pre-blank headline) ?\n)
contents))
;; Case 3: Ignore heading.
((equal environment "ignoreheading")
(concat (make-string (org-element-property :pre-blank headline) ?\n)
contents))
;; Case 4: HEADLINE is a note.
((member environment '("note" "noteNH"))
(concat "\\note"
;; Overlay specification.
(let ((overlay (org-element-property :BEAMER_ACT headline)))
(when overlay
(org-beamer--normalize-argument
overlay
(if (string-match "\\`\\[.*\\]\\'" overlay)
'defaction 'action))))
(format "{%s}"
(concat (and (equal environment "note")
(concat
(org-export-data
(org-element-property :title headline)
info)
"\n"))
(org-trim contents)))))
;; Case 5: HEADLINE is a frame.
((= level frame-level)
(org-beamer--format-frame headline contents info))
;; Case 6: Regular section, extracted from
;; `org-latex-classes'.
((< level frame-level)
(org-beamer--format-section headline contents info))
;; Case 7: Otherwise, HEADLINE is a block.
(t (org-beamer--format-block headline contents info))))))
;;;; Item
(defun org-beamer-item (item contents info)
"Transcode an ITEM element into Beamer code.
CONTENTS holds the contents of the item. INFO is a plist holding
contextual information."
(org-export-with-backend
;; Delegate item export to `latex'. However, we use `beamer'
;; transcoders for objects in the description tag.
(org-export-create-backend
:parent 'beamer
:transcoders
(list
(cons
'item
(lambda (item _c _i)
(let ((action
(let ((first (car (org-element-contents item))))
(and (org-element-type-p first 'paragraph)
(org-beamer--element-has-overlay-p first))))
(output (org-latex-item item contents info)))
(if (not (and action (string-match "\\\\item" output))) output
;; If the item starts with a paragraph and that paragraph
;; starts with an export snippet specifying an overlay,
;; append it to the \item command.
(replace-match (concat "\\\\item" action) nil nil output)))))))
item contents info))
;;;; Keyword
(defun org-beamer-keyword (keyword contents info)
"Transcode a KEYWORD element into Beamer code.
CONTENTS is nil. INFO is a plist used as a communication
channel."
(let ((key (org-element-property :key keyword))
(value (org-element-property :value keyword)))
;; Handle specifically BEAMER and TOC (headlines only) keywords.
;; Otherwise, fallback to `latex' backend.
(cond
((equal key "BEAMER") value)
((and (equal key "TOC") (string-match "\\<headlines\\>" value))
(let ((depth (or (and (string-match "[0-9]+" value)
(string-to-number (match-string 0 value)))
(plist-get info :with-toc)))
(options (and (string-match "\\[.*?\\]" value)
(match-string 0 value))))
(concat
(when (wholenump depth) (format "\\setcounter{tocdepth}{%s}\n" depth))
"\\tableofcontents" options)))
(t (org-export-with-backend 'latex keyword contents info)))))
;;;; Link
(defun org-beamer-link (link contents info)
"Transcode a LINK object into Beamer code.
CONTENTS is the description part of the link. INFO is a plist
used as a communication channel."
(or (org-export-custom-protocol-maybe link contents 'beamer info)
;; Fall-back to LaTeX export. However, prefer "\hyperlink" over
;; "\hyperref" since the former handles overlay specifications.
(let* ((latex-link (org-export-with-backend 'latex link contents info))
(parent (org-element-parent-element link))
(attr (org-export-read-attribute :attr_beamer parent))
(overlay (plist-get attr :overlay)))
(cond ((string-match "\\`\\\\hyperref\\[\\(.*?\\)\\]" latex-link)
(replace-match
(format "\\\\hyperlink%s{\\1}"
(or (org-beamer--element-has-overlay-p link) ""))
nil nil latex-link))
((string-match "\\\\include\\(graphics\\|svg\\)\\([[{]?\\)" latex-link)
;; Check for overlay specification and insert if
;; present.
(replace-match
(format "\\\\include\\1%s\\2"
(if overlay overlay ""))
nil nil latex-link))
(t latex-link)))))
;;;; Plain List
;;
;; Plain lists support `:environment', `:overlay' and `:options'
;; attributes.
(defun org-beamer-plain-list (plain-list contents info)
"Transcode a PLAIN-LIST element into Beamer code.
CONTENTS is the contents of the list. INFO is a plist holding
contextual information."
(let* ((type (org-element-property :type plain-list))
(attributes (org-combine-plists
(org-export-read-attribute :attr_latex plain-list)
(org-export-read-attribute :attr_beamer plain-list)))
(latex-type (let ((env (plist-get attributes :environment)))
(cond (env)
((eq type 'ordered) "enumerate")
((eq type 'descriptive) "description")
(t "itemize")))))
(org-latex--wrap-label
plain-list
(format "\\begin{%s}%s%s\n%s\\end{%s}"
latex-type
;; Default overlay specification, if any.
(org-beamer--normalize-argument
(or (plist-get attributes :overlay) "")
'defaction)
;; Second optional argument depends on the list type.
(org-beamer--normalize-argument
(or (plist-get attributes :options) "")
'option)
;; Eventually insert contents and close environment.
contents
latex-type)
info)))
;;;; Radio Target
(defun org-beamer-radio-target (radio-target text info)
"Transcode a RADIO-TARGET object into Beamer code.
TEXT is the text of the target. INFO is a plist holding
contextual information."
(format "\\hypertarget%s{%s}{%s}"
(or (org-beamer--element-has-overlay-p radio-target) "")
(org-export-get-reference radio-target info)
text))
;;;; Template
;;
;; Template used is similar to the one used in `latex' backend,
;; excepted for the table of contents and Beamer themes.
(defun org-beamer-template (contents info)
"Return complete document string after Beamer conversion.
CONTENTS is the transcoded contents string. INFO is a plist
holding export options."
(let ((title (org-export-data (plist-get info :title) info))
(subtitle (org-export-data (plist-get info :subtitle) info)))
(concat
;; Timestamp.
(and (plist-get info :time-stamp-file)
(format-time-string "%% Created %Y-%m-%d %a %H:%M\n"))
;; LaTeX compiler
(org-latex--insert-compiler info)
;; Document class and packages.
(org-latex-make-preamble info)
;; Define the alternative frame environment, if needed.
(when (plist-get info :beamer-define-frame)
(format "\\newenvironment<>{%s}[1][]{\\begin{frame}#2[environment=%1$s,#1]}{\\end{frame}}\n"
org-beamer-frame-environment))
;; Insert themes.
(let ((format-theme
(lambda (prop command)
(let ((theme (plist-get info prop)))
(when theme
(concat command
(if (not (string-match "\\[.*\\]" theme))
(format "{%s}\n" theme)
(format "%s{%s}\n"
(match-string 0 theme)
(org-trim
(replace-match "" nil nil theme))))))))))
(mapconcat (lambda (args) (apply format-theme args))
'((:beamer-theme "\\usetheme")
(:beamer-color-theme "\\usecolortheme")
(:beamer-font-theme "\\usefonttheme")
(:beamer-inner-theme "\\useinnertheme")
(:beamer-outer-theme "\\useoutertheme"))
""))
;; Possibly limit depth for headline numbering.
(let ((sec-num (plist-get info :section-numbers)))
(when (integerp sec-num)
(format "\\setcounter{secnumdepth}{%d}\n" sec-num)))
;; Author.
(let ((author (and (plist-get info :with-author)
(let ((auth (plist-get info :author)))
(and auth (org-export-data auth info)))))
(email (and (plist-get info :with-email)
(org-export-data (plist-get info :email) info))))
(cond ((and author email (not (string= "" email)))
(format "\\author{%s\\thanks{%s}}\n" author email))
((or author email) (format "\\author{%s}\n" (or author email)))))
;; Date.
(let ((date (and (plist-get info :with-date) (org-export-get-date info))))
(format "\\date{%s}\n" (org-export-data date info)))
;; Title
(format "\\title{%s}\n" title)
(when (org-string-nw-p subtitle)
(concat (format (plist-get info :beamer-subtitle-format) subtitle) "\n"))
;; Beamer-header
(let ((beamer-header (plist-get info :beamer-header)))
(when beamer-header
(format "%s\n" (plist-get info :beamer-header))))
;; 9. Hyperref options.
(let ((template (plist-get info :latex-hyperref-template)))
(and (stringp template)
(format-spec template (org-latex--format-spec info))))
;; engrave-faces-latex preamble
(when (and (eq (plist-get info :latex-src-block-backend) 'engraved)
(org-element-map (plist-get info :parse-tree)
'(src-block inline-src-block) #'identity
info t))
(org-latex-generate-engraved-preamble info))
;; Document start.
"\\begin{document}\n\n"
;; Title command.
(org-element-normalize-string
(cond ((not (plist-get info :with-title)) nil)
((string= "" title) nil)
((not (stringp org-latex-title-command)) nil)
((string-match "\\(?:[^%]\\|^\\)%s"
org-latex-title-command)
(format org-latex-title-command title))
(t org-latex-title-command)))
;; Table of contents.
(let ((depth (plist-get info :with-toc)))
(when depth
(concat
(format "\\begin{frame}%s{%s}\n"
(org-beamer--normalize-argument
(plist-get info :beamer-outline-frame-options) 'option)
(plist-get info :beamer-outline-frame-title))
(when (wholenump depth)
(format "\\setcounter{tocdepth}{%d}\n" depth))
"\\tableofcontents\n"
"\\end{frame}\n\n")))
;; Document's body.
contents
;; Creator.
(if (plist-get info :with-creator)
(concat (plist-get info :creator) "\n")
"")
;; Document end.
"\\end{document}")))
;;; Minor Mode
(defvar org-beamer-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "\C-c\C-b" 'org-beamer-select-environment)
map)
"The keymap for `org-beamer-mode'.")
;;;###autoload
(define-minor-mode org-beamer-mode
"Support for editing Beamer oriented Org mode files."
:lighter " Bm")
(font-lock-add-keywords
'org-mode
'((":\\(B_[a-z]+\\|BMCOL\\):" 1 'org-beamer-tag prepend))
'prepend)
(defface org-beamer-tag '((t (:box (:line-width 1 :color "grey40"))))
"The special face for beamer tags."
:group 'org-export-beamer)
(defun org-beamer-property-changed (property value)
"Track the BEAMER_env property with tags.
PROPERTY is the name of the modified property. VALUE is its new
value."
(cond
((equal property "BEAMER_env")
(save-excursion
(org-back-to-heading t)
;; Filter out Beamer-related tags and install environment tag.
(let ((tags (cl-remove-if (lambda (x) (string-match "^B_" x))
(org-get-tags nil t)))
(env-tag (and (org-string-nw-p value) (concat "B_" value))))
(org-set-tags (if env-tag (cons env-tag tags) tags))
(when env-tag (org-toggle-tag env-tag 'on)))))
((equal property "BEAMER_col")
(org-toggle-tag "BMCOL" (if (org-string-nw-p value) 'on 'off)))))
(add-hook 'org-property-changed-functions 'org-beamer-property-changed)
(defun org-beamer-allowed-property-values (property)
"Supply allowed values for PROPERTY."
(cond
((and (equal property "BEAMER_env")
(not (org-entry-get nil (concat property "_ALL") 'inherit)))
;; If no allowed values for BEAMER_env have been defined,
;; supply all defined environments
(mapcar 'car (append org-beamer-environments-special
org-beamer-environments-extra
org-beamer-environments-default)))
((and (equal property "BEAMER_col")
(not (org-entry-get nil (concat property "_ALL") 'inherit)))
;; If no allowed values for BEAMER_col have been defined, supply
;; some.
(split-string org-beamer-column-widths " "))))
(add-hook 'org-property-allowed-value-functions
'org-beamer-allowed-property-values)
;;; Commands
;;;###autoload
(defun org-beamer-export-as-latex
(&optional async subtreep visible-only body-only ext-plist)
"Export current buffer as a Beamer buffer.
If narrowing is active in the current buffer, only export its
narrowed part.
If a region is active, export that region.
A non-nil optional argument ASYNC means the process should happen
asynchronously. The resulting buffer should be accessible
through the `org-export-stack' interface.
When optional argument SUBTREEP is non-nil, export the sub-tree
at point, extracting information from the headline properties
first.
When optional argument VISIBLE-ONLY is non-nil, don't export
contents of hidden elements.
When optional argument BODY-ONLY is non-nil, only write code
between \"\\begin{document}\" and \"\\end{document}\".
EXT-PLIST, when provided, is a property list with external
parameters overriding Org default settings, but still inferior to
file-local settings.
Export is done in a buffer named \"*Org BEAMER Export*\", which
will be displayed when `org-export-show-temporary-export-buffer'
is non-nil."
(interactive)
(org-export-to-buffer 'beamer "*Org BEAMER Export*"
async subtreep visible-only body-only ext-plist
(if (fboundp 'major-mode-remap)
(major-mode-remap 'latex-mode)
#'LaTeX-mode)))
;;;###autoload
(defun org-beamer-export-to-latex
(&optional async subtreep visible-only body-only ext-plist)
"Export current buffer as a Beamer presentation (tex).
If narrowing is active in the current buffer, only export its
narrowed part.
If a region is active, export that region.
A non-nil optional argument ASYNC means the process should happen
asynchronously. The resulting file should be accessible through
the `org-export-stack' interface.
When optional argument SUBTREEP is non-nil, export the sub-tree
at point, extracting information from the headline properties
first.
When optional argument VISIBLE-ONLY is non-nil, don't export
contents of hidden elements.
When optional argument BODY-ONLY is non-nil, only write code
between \"\\begin{document}\" and \"\\end{document}\".
EXT-PLIST, when provided, is a property list with external
parameters overriding Org default settings, but still inferior to
file-local settings.
Return output file's name."
(interactive)
(let ((file (org-export-output-file-name ".tex" subtreep)))
(org-export-to-file 'beamer file
async subtreep visible-only body-only ext-plist)))
;;;###autoload
(defun org-beamer-export-to-pdf
(&optional async subtreep visible-only body-only ext-plist)
"Export current buffer as a Beamer presentation (PDF).
If narrowing is active in the current buffer, only export its
narrowed part.
If a region is active, export that region.
A non-nil optional argument ASYNC means the process should happen
asynchronously. The resulting file should be accessible through
the `org-export-stack' interface.
When optional argument SUBTREEP is non-nil, export the sub-tree
at point, extracting information from the headline properties
first.
When optional argument VISIBLE-ONLY is non-nil, don't export
contents of hidden elements.
When optional argument BODY-ONLY is non-nil, only write code
between \"\\begin{document}\" and \"\\end{document}\".
EXT-PLIST, when provided, is a property list with external
parameters overriding Org default settings, but still inferior to
file-local settings.
Return PDF file's name."
(interactive)
(let ((file (org-export-output-file-name ".tex" subtreep)))
(org-export-to-file 'beamer file
async subtreep visible-only body-only ext-plist
#'org-latex-compile)))
;;;###autoload
(defun org-beamer-select-environment ()
"Select the environment to be used by beamer for this entry.
While this uses (for convenience) a tag selection interface, the
result of this command will be that the BEAMER_env *property* of
the entry is set.
In addition to this, the command will also set a tag as a visual
aid, but the tag does not have any semantic meaning."
(interactive)
;; Make sure `org-beamer-environments-special' has a higher
;; priority than `org-beamer-environments-extra'.
(let* ((envs (append org-beamer-environments-special
org-beamer-environments-extra
org-beamer-environments-default))
(org-current-tag-alist
(append '((:startgroup))
(mapcar (lambda (e) (cons (concat "B_" (car e))
(string-to-char (nth 1 e))))
envs)
'((:endgroup))
'(("BMCOL" . ?|))))
(org-tag-persistent-alist nil)
(org-use-fast-tag-selection t)
(org-fast-tag-selection-single-key t))
(org-set-tags-command)
(let ((tags (org-get-tags nil t)))
(cond
;; For a column, automatically ask for its width.
((eq org-last-tag-selection-key ?|)
(if (member "BMCOL" tags)
(org-set-property "BEAMER_col" (read-string "Column width: "))
(org-delete-property "BEAMER_col")))
;; For an "againframe" section, automatically ask for reference
;; to resumed frame and overlay specifications.
((eq org-last-tag-selection-key ?A)
(if (equal (org-entry-get nil "BEAMER_env") "againframe")
(progn (org-entry-delete nil "BEAMER_env")
(org-entry-delete nil "BEAMER_ref")
(org-entry-delete nil "BEAMER_act"))
(org-entry-put nil "BEAMER_env" "againframe")
(org-set-property
"BEAMER_ref"
(read-string "Frame reference (*Title, #custom-id, id:...): "))
(org-set-property "BEAMER_act"
(read-string "Overlay specification: "))))
((let* ((tags-re (concat "B_" (regexp-opt (mapcar #'car envs) t)))
(env (cl-some (lambda (tag)
(and (string-match tags-re tag)
(match-string 1 tag)))
tags)))
(and env (progn (org-entry-put nil "BEAMER_env" env) t))))
(t (org-entry-delete nil "BEAMER_env"))))))
;;;###autoload
(defun org-beamer-publish-to-latex (plist filename pub-dir)
"Publish an Org file to a Beamer presentation (LaTeX).
FILENAME is the filename of the Org file to be published. PLIST
is the property list for the given project. PUB-DIR is the
publishing directory.
Return output file name."
(org-publish-org-to 'beamer filename ".tex" plist pub-dir))
;;;###autoload
(defun org-beamer-publish-to-pdf (plist filename pub-dir)
"Publish an Org file to a Beamer presentation (PDF, via LaTeX).
FILENAME is the filename of the Org file to be published. PLIST
is the property list for the given project. PUB-DIR is the
publishing directory.
Return output file name."
;; Unlike to `org-beamer-publish-to-latex', PDF file is generated in
;; working directory and then moved to publishing directory.
(org-publish-attachment
plist
;; Default directory could be anywhere when this function is
;; called. We ensure it is set to source file directory during
;; compilation so as to not break links to external documents.
(let ((default-directory (file-name-directory filename)))
(org-latex-compile
(org-publish-org-to
'beamer filename ".tex" plist (file-name-directory filename))))
pub-dir))
(provide 'ox-beamer)
;; Local variables:
;; generated-autoload-file: "org-loaddefs.el"
;; End:
;;; ox-beamer.el ends here
org-mode-9.7.29+dfsg/lisp/ox-html.el 0000664 0000000 0000000 00000462134 15004304337 0017144 0 ustar 00root root 0000000 0000000 ;;; ox-html.el --- HTML Backend for Org Export Engine -*- lexical-binding: t; -*-
;; Copyright (C) 2011-2025 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
;; Jambunathan K <kjambunathan at gmail dot com>
;; Maintainer: TEC <orgmode@tec.tecosaur.net>
;; Keywords: outlines, hypermedia, calendar, text
;; 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;; This library implements a HTML backend for Org generic exporter.
;; See Org manual for more information.
;;; Code:
;;; Dependencies
(require 'org-macs)
(org-assert-version)
(require 'cl-lib)
(require 'format-spec)
(require 'ox)
(require 'ox-publish)
(require 'table)
;;; Function Declarations
(declare-function org-id-find-id-file "org-id" (id))
(declare-function htmlize-region "ext:htmlize" (beg end))
(declare-function mm-url-decode-entities "mm-url" ())
(declare-function org-at-heading-p "org" (&optional _))
(declare-function org-back-to-heading "org" (&optional invisible-ok))
(declare-function org-next-visible-heading "org" (arg))
(defvar htmlize-css-name-prefix)
(defvar htmlize-output-type)
(defvar htmlize-output-type)
(defvar htmlize-css-name-prefix)
;;; Define Backend
(org-export-define-backend 'html
'((bold . org-html-bold)
(center-block . org-html-center-block)
(clock . org-html-clock)
(code . org-html-code)
(drawer . org-html-drawer)
(dynamic-block . org-html-dynamic-block)
(entity . org-html-entity)
(example-block . org-html-example-block)
(export-block . org-html-export-block)
(export-snippet . org-html-export-snippet)
(fixed-width . org-html-fixed-width)
(footnote-reference . org-html-footnote-reference)
(headline . org-html-headline)
(horizontal-rule . org-html-horizontal-rule)
(inline-src-block . org-html-inline-src-block)
(inlinetask . org-html-inlinetask)
(inner-template . org-html-inner-template)
(italic . org-html-italic)
(item . org-html-item)
(keyword . org-html-keyword)
(latex-environment . org-html-latex-environment)
(latex-fragment . org-html-latex-fragment)
(line-break . org-html-line-break)
(link . org-html-link)
(node-property . org-html-node-property)
(paragraph . org-html-paragraph)
(plain-list . org-html-plain-list)
(plain-text . org-html-plain-text)
(planning . org-html-planning)
(property-drawer . org-html-property-drawer)
(quote-block . org-html-quote-block)
(radio-target . org-html-radio-target)
(section . org-html-section)
(special-block . org-html-special-block)
(src-block . org-html-src-block)
(statistics-cookie . org-html-statistics-cookie)
(strike-through . org-html-strike-through)
(subscript . org-html-subscript)
(superscript . org-html-superscript)
(table . org-html-table)
(table-cell . org-html-table-cell)
(table-row . org-html-table-row)
(target . org-html-target)
(template . org-html-template)
(timestamp . org-html-timestamp)
(underline . org-html-underline)
(verbatim . org-html-verbatim)
(verse-block . org-html-verse-block))
:filters-alist '((:filter-options . org-html-infojs-install-script)
(:filter-parse-tree . org-html-image-link-filter)
(:filter-final-output . org-html-final-function))
:menu-entry
'(?h "Export to HTML"
((?H "As HTML buffer" org-html-export-as-html)
(?h "As HTML file" org-html-export-to-html)
(?o "As HTML file and open"
(lambda (a s v b)
(if a (org-html-export-to-html t s v b)
(org-open-file (org-html-export-to-html nil s v b)))))))
:options-alist
'((:html-doctype "HTML_DOCTYPE" nil org-html-doctype)
(:html-container "HTML_CONTAINER" nil org-html-container-element)
(:html-content-class "HTML_CONTENT_CLASS" nil org-html-content-class)
(:description "DESCRIPTION" nil nil newline)
(:keywords "KEYWORDS" nil nil space)
(:html-html5-fancy nil "html5-fancy" org-html-html5-fancy)
(:html-link-use-abs-url nil "html-link-use-abs-url" org-html-link-use-abs-url)
(:html-link-home "HTML_LINK_HOME" nil org-html-link-home)
(:html-link-up "HTML_LINK_UP" nil org-html-link-up)
(:html-mathjax "HTML_MATHJAX" nil "" space)
(:html-equation-reference-format "HTML_EQUATION_REFERENCE_FORMAT" nil org-html-equation-reference-format t)
(:html-postamble nil "html-postamble" org-html-postamble)
(:html-preamble nil "html-preamble" org-html-preamble)
(:html-head "HTML_HEAD" nil org-html-head newline)
(:html-head-extra "HTML_HEAD_EXTRA" nil org-html-head-extra newline)
(:subtitle "SUBTITLE" nil nil parse)
(:html-head-include-default-style
nil "html-style" org-html-head-include-default-style)
(:html-head-include-scripts nil "html-scripts" org-html-head-include-scripts)
(:html-allow-name-attribute-in-anchors
nil nil org-html-allow-name-attribute-in-anchors)
(:html-divs nil nil org-html-divs)
(:html-checkbox-type nil nil org-html-checkbox-type)
(:html-extension nil nil org-html-extension)
(:html-footnote-format nil nil org-html-footnote-format)
(:html-footnote-separator nil nil org-html-footnote-separator)
(:html-footnotes-section nil nil org-html-footnotes-section)
(:html-format-drawer-function nil nil org-html-format-drawer-function)
(:html-format-headline-function nil nil org-html-format-headline-function)
(:html-format-inlinetask-function
nil nil org-html-format-inlinetask-function)
(:html-home/up-format nil nil org-html-home/up-format)
(:html-indent nil nil org-html-indent)
(:html-infojs-options nil nil org-html-infojs-options)
(:html-infojs-template nil nil org-html-infojs-template)
(:html-inline-image-rules nil nil org-html-inline-image-rules)
(:html-link-org-files-as-html nil nil org-html-link-org-files-as-html)
(:html-mathjax-options nil nil org-html-mathjax-options)
(:html-mathjax-template nil nil org-html-mathjax-template)
(:html-metadata-timestamp-format nil nil org-html-metadata-timestamp-format)
(:html-postamble-format nil nil org-html-postamble-format)
(:html-preamble-format nil nil org-html-preamble-format)
(:html-prefer-user-labels nil nil org-html-prefer-user-labels)
(:html-self-link-headlines nil nil org-html-self-link-headlines)
(:html-table-align-individual-fields
nil nil org-html-table-align-individual-fields)
(:html-table-caption-above nil nil org-html-table-caption-above)
(:html-table-data-tags nil nil org-html-table-data-tags)
(:html-table-header-tags nil nil org-html-table-header-tags)
(:html-table-use-header-tags-for-first-column
nil nil org-html-table-use-header-tags-for-first-column)
(:html-tag-class-prefix nil nil org-html-tag-class-prefix)
(:html-text-markup-alist nil nil org-html-text-markup-alist)
(:html-todo-kwd-class-prefix nil nil org-html-todo-kwd-class-prefix)
(:html-toplevel-hlevel nil nil org-html-toplevel-hlevel)
(:html-use-infojs nil nil org-html-use-infojs)
(:html-validation-link nil nil org-html-validation-link)
(:html-viewport nil nil org-html-viewport)
(:html-inline-images nil nil org-html-inline-images)
(:html-table-attributes nil nil org-html-table-default-attributes)
(:html-table-row-open-tag nil nil org-html-table-row-open-tag)
(:html-table-row-close-tag nil nil org-html-table-row-close-tag)
(:html-xml-declaration nil nil org-html-xml-declaration)
(:html-wrap-src-lines nil nil org-html-wrap-src-lines)
(:html-klipsify-src nil nil org-html-klipsify-src)
(:html-klipse-css nil nil org-html-klipse-css)
(:html-klipse-js nil nil org-html-klipse-js)
(:html-klipse-selection-script nil nil org-html-klipse-selection-script)
(:infojs-opt "INFOJS_OPT" nil nil)
;; Redefine regular options.
(:creator "CREATOR" nil org-html-creator-string)
(:with-latex nil "tex" org-html-with-latex)
;; Retrieve LaTeX header for fragments.
(:latex-header "LATEX_HEADER" nil nil newline)))
;;; Internal Variables
(defvar org-html-format-table-no-css)
(defvar htmlize-buffer-places) ; from htmlize.el
(defvar org-html--pre/postamble-class "status"
"CSS class used for pre/postamble.")
(defconst org-html-doctype-alist
'(("html4-strict" . "<!DOCTYPE html PUBLIC \"-//W3C//DTD HTML 4.01//EN\"
\"http://www.w3.org/TR/html4/strict.dtd\">")
("html4-transitional" . "<!DOCTYPE html PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
\"http://www.w3.org/TR/html4/loose.dtd\">")
("html4-frameset" . "<!DOCTYPE html PUBLIC \"-//W3C//DTD HTML 4.01 Frameset//EN\"
\"http://www.w3.org/TR/html4/frameset.dtd\">")
("xhtml-strict" . "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"
\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
("xhtml-transitional" . "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\"
\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">")
("xhtml-frameset" . "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Frameset//EN\"
\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd\">")
("xhtml-11" . "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\"
\"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">")
("html5" . "<!DOCTYPE html>")
("xhtml5" . "<!DOCTYPE html>"))
"An alist mapping (x)html flavors to specific doctypes.")
(defconst org-html-html5-elements
'("article" "aside" "audio" "canvas" "details" "figcaption"
"figure" "footer" "header" "menu" "meter" "nav" "output"
"progress" "section" "summary" "video")
"New elements in html5.
For blocks that should contain headlines, use the HTML_CONTAINER
property on the headline itself.")
(defconst org-html-special-string-regexps
'(("\\\\-" . "") ; shy
("---\\([^-]\\)" . "—\\1") ; mdash
("--\\([^-]\\)" . "–\\1") ; ndash
("\\.\\.\\." . "…")) ; hellip
"Regular expressions for special string conversion.")
(defvar org-html--id-attr-prefix "ID-"
"Prefix to use in ID attributes.
This affects IDs that are determined from the ID property.")
(defcustom org-html-scripts
"<script>
// @license magnet:?xt=urn:btih:1f739d935676111cfff4b4693e3816e664797050&dn=gpl-3.0.txt GPL-v3-or-Later
function CodeHighlightOn(elem, id)
{
var target = document.getElementById(id);
if(null != target) {
elem.classList.add(\"code-highlighted\");
target.classList.add(\"code-highlighted\");
}
}
function CodeHighlightOff(elem, id)
{
var target = document.getElementById(id);
if(null != target) {
elem.classList.remove(\"code-highlighted\");
target.classList.remove(\"code-highlighted\");
}
}
// @license-end
</script>"
"Basic JavaScript to allow highlighting references in code blocks."
:group 'org-export-html
:package-version '(Org . "9.5")
:type 'string)
(defcustom org-html-style-default
"<style type=\"text/css\">
#content { max-width: 60em; margin: auto; }
.title { text-align: center;
margin-bottom: .2em; }
.subtitle { text-align: center;
font-size: medium;
font-weight: bold;
margin-top:0; }
.todo { font-family: monospace; color: red; }
.done { font-family: monospace; color: green; }
.priority { font-family: monospace; color: orange; }
.tag { background-color: #eee; font-family: monospace;
padding: 2px; font-size: 80%; font-weight: normal; }
.timestamp { color: #bebebe; }
.timestamp-kwd { color: #5f9ea0; }
.org-right { margin-left: auto; margin-right: 0px; text-align: right; }
.org-left { margin-left: 0px; margin-right: auto; text-align: left; }
.org-center { margin-left: auto; margin-right: auto; text-align: center; }
.underline { text-decoration: underline; }
#postamble p, #preamble p { font-size: 90%; margin: .2em; }
p.verse { margin-left: 3%; }
pre {
border: 1px solid #e6e6e6;
border-radius: 3px;
background-color: #f2f2f2;
padding: 8pt;
font-family: monospace;
overflow: auto;
margin: 1.2em;
}
pre.src {
position: relative;
overflow: auto;
}
pre.src:before {
display: none;
position: absolute;
top: -8px;
right: 12px;
padding: 3px;
color: #555;
background-color: #f2f2f299;
}
pre.src:hover:before { display: inline; margin-top: 14px;}
/* Languages per Org manual */
pre.src-asymptote:before { content: 'Asymptote'; }
pre.src-awk:before { content: 'Awk'; }
pre.src-authinfo::before { content: 'Authinfo'; }
pre.src-C:before { content: 'C'; }
/* pre.src-C++ doesn't work in CSS */
pre.src-clojure:before { content: 'Clojure'; }
pre.src-css:before { content: 'CSS'; }
pre.src-D:before { content: 'D'; }
pre.src-ditaa:before { content: 'ditaa'; }
pre.src-dot:before { content: 'Graphviz'; }
pre.src-calc:before { content: 'Emacs Calc'; }
pre.src-emacs-lisp:before { content: 'Emacs Lisp'; }
pre.src-fortran:before { content: 'Fortran'; }
pre.src-gnuplot:before { content: 'gnuplot'; }
pre.src-haskell:before { content: 'Haskell'; }
pre.src-hledger:before { content: 'hledger'; }
pre.src-java:before { content: 'Java'; }
pre.src-js:before { content: 'Javascript'; }
pre.src-latex:before { content: 'LaTeX'; }
pre.src-ledger:before { content: 'Ledger'; }
pre.src-lisp:before { content: 'Lisp'; }
pre.src-lilypond:before { content: 'Lilypond'; }
pre.src-lua:before { content: 'Lua'; }
pre.src-matlab:before { content: 'MATLAB'; }
pre.src-mscgen:before { content: 'Mscgen'; }
pre.src-ocaml:before { content: 'Objective Caml'; }
pre.src-octave:before { content: 'Octave'; }
pre.src-org:before { content: 'Org mode'; }
pre.src-oz:before { content: 'OZ'; }
pre.src-plantuml:before { content: 'Plantuml'; }
pre.src-processing:before { content: 'Processing.js'; }
pre.src-python:before { content: 'Python'; }
pre.src-R:before { content: 'R'; }
pre.src-ruby:before { content: 'Ruby'; }
pre.src-sass:before { content: 'Sass'; }
pre.src-scheme:before { content: 'Scheme'; }
pre.src-screen:before { content: 'Gnu Screen'; }
pre.src-sed:before { content: 'Sed'; }
pre.src-sh:before { content: 'shell'; }
pre.src-sql:before { content: 'SQL'; }
pre.src-sqlite:before { content: 'SQLite'; }
/* additional languages in org.el's org-babel-load-languages alist */
pre.src-forth:before { content: 'Forth'; }
pre.src-io:before { content: 'IO'; }
pre.src-J:before { content: 'J'; }
pre.src-makefile:before { content: 'Makefile'; }
pre.src-maxima:before { content: 'Maxima'; }
pre.src-perl:before { content: 'Perl'; }
pre.src-picolisp:before { content: 'Pico Lisp'; }
pre.src-scala:before { content: 'Scala'; }
pre.src-shell:before { content: 'Shell Script'; }
pre.src-ebnf2ps:before { content: 'ebfn2ps'; }
/* additional language identifiers per \"defun org-babel-execute\"
in ob-*.el */
pre.src-cpp:before { content: 'C++'; }
pre.src-abc:before { content: 'ABC'; }
pre.src-coq:before { content: 'Coq'; }
pre.src-groovy:before { content: 'Groovy'; }
/* additional language identifiers from org-babel-shell-names in
ob-shell.el: ob-shell is the only babel language using a lambda to put
the execution function name together. */
pre.src-bash:before { content: 'bash'; }
pre.src-csh:before { content: 'csh'; }
pre.src-ash:before { content: 'ash'; }
pre.src-dash:before { content: 'dash'; }
pre.src-ksh:before { content: 'ksh'; }
pre.src-mksh:before { content: 'mksh'; }
pre.src-posh:before { content: 'posh'; }
/* Additional Emacs modes also supported by the LaTeX listings package */
pre.src-ada:before { content: 'Ada'; }
pre.src-asm:before { content: 'Assembler'; }
pre.src-caml:before { content: 'Caml'; }
pre.src-delphi:before { content: 'Delphi'; }
pre.src-html:before { content: 'HTML'; }
pre.src-idl:before { content: 'IDL'; }
pre.src-mercury:before { content: 'Mercury'; }
pre.src-metapost:before { content: 'MetaPost'; }
pre.src-modula-2:before { content: 'Modula-2'; }
pre.src-pascal:before { content: 'Pascal'; }
pre.src-ps:before { content: 'PostScript'; }
pre.src-prolog:before { content: 'Prolog'; }
pre.src-simula:before { content: 'Simula'; }
pre.src-tcl:before { content: 'tcl'; }
pre.src-tex:before { content: 'TeX'; }
pre.src-plain-tex:before { content: 'Plain TeX'; }
pre.src-verilog:before { content: 'Verilog'; }
pre.src-vhdl:before { content: 'VHDL'; }
pre.src-xml:before { content: 'XML'; }
pre.src-nxml:before { content: 'XML'; }
/* add a generic configuration mode; LaTeX export needs an additional
(add-to-list 'org-latex-listings-langs '(conf \" \")) in .emacs */
pre.src-conf:before { content: 'Configuration File'; }
table { border-collapse:collapse; }
caption.t-above { caption-side: top; }
caption.t-bottom { caption-side: bottom; }
td, th { vertical-align:top; }
th.org-right { text-align: center; }
th.org-left { text-align: center; }
th.org-center { text-align: center; }
td.org-right { text-align: right; }
td.org-left { text-align: left; }
td.org-center { text-align: center; }
dt { font-weight: bold; }
.footpara { display: inline; }
.footdef { margin-bottom: 1em; }
.figure { padding: 1em; }
.figure p { text-align: center; }
.equation-container {
display: table;
text-align: center;
width: 100%;
}
.equation {
vertical-align: middle;
}
.equation-label {
display: table-cell;
text-align: right;
vertical-align: middle;
}
.inlinetask {
padding: 10px;
border: 2px solid gray;
margin: 10px;
background: #ffffcc;
}
#org-div-home-and-up
{ text-align: right; font-size: 70%; white-space: nowrap; }
textarea { overflow-x: auto; }
.linenr { font-size: smaller }
.code-highlighted { background-color: #ffff00; }
.org-info-js_info-navigation { border-style: none; }
#org-info-js_console-label
{ font-size: 10px; font-weight: bold; white-space: nowrap; }
.org-info-js_search-highlight
{ background-color: #ffff00; color: #000000; font-weight: bold; }
.org-svg { }
</style>"
"The default style specification for exported HTML files.
You can use `org-html-head' and `org-html-head-extra' to add to
this style. If you don't want to include this default style,
customize `org-html-head-include-default-style'."
:group 'org-export-html
:package-version '(Org . "9.5")
:type 'string)
;;; User Configuration Variables
(defgroup org-export-html nil
"Options for exporting Org mode files to HTML."
:tag "Org Export HTML"
:group 'org-export)
;;;; Handle infojs
(defvar org-html-infojs-opts-table
'((path PATH "https://orgmode.org/org-info.js")
(view VIEW "info")
(toc TOC :with-toc)
(ftoc FIXED_TOC "0")
(tdepth TOC_DEPTH "max")
(sdepth SECTION_DEPTH "max")
(mouse MOUSE_HINT "underline")
(buttons VIEW_BUTTONS "0")
(ltoc LOCAL_TOC "1")
(up LINK_UP :html-link-up)
(home LINK_HOME :html-link-home))
"JavaScript options, long form for script, default values.")
(defcustom org-html-use-infojs 'when-configured
"Non-nil when Sebastian Rose's Java Script org-info.js should be active.
This option can be nil or t to never or always use the script.
It can also be the symbol `when-configured', meaning that the
script will be linked into the export file if and only if there
is a \"#+INFOJS_OPT:\" line in the buffer. See also the variable
`org-html-infojs-options'."
:group 'org-export-html
:version "24.4"
:package-version '(Org . "8.0")
:type '(choice
(const :tag "Never" nil)
(const :tag "When configured in buffer" when-configured)
(const :tag "Always" t)))
(defcustom org-html-infojs-options
(mapcar (lambda (x) (cons (car x) (nth 2 x))) org-html-infojs-opts-table)
"Options settings for the INFOJS JavaScript.
Each of the options must have an entry in `org-html-infojs-opts-table'.
The value can either be a string that will be passed to the script, or
a property. This property is then assumed to be a property that is defined
by the Export/Publishing setup of Org.
The `sdepth' and `tdepth' parameters can also be set to \"max\", which
means to use the maximum value consistent with other options."
:group 'org-export-html
:version "24.4"
:package-version '(Org . "8.0")
:type
`(set :greedy t :inline t
,@(mapcar
(lambda (x)
(list 'cons (list 'const (car x))
'(choice
(symbol :tag "Publishing/Export property")
(string :tag "Value"))))
org-html-infojs-opts-table)))
(defcustom org-html-infojs-template
"<script src=\"%SCRIPT_PATH\">
// @license magnet:?xt=urn:btih:1f739d935676111cfff4b4693e3816e664797050&dn=gpl-3.0.txt GPL-v3-or-Later
// @license-end
</script>
<script>
// @license magnet:?xt=urn:btih:1f739d935676111cfff4b4693e3816e664797050&dn=gpl-3.0.txt GPL-v3-or-Later
%MANAGER_OPTIONS
org_html_manager.setup(); // activate after the parameters are set
// @license-end
</script>"
"The template for the export style additions when org-info.js is used.
Option settings will replace the %MANAGER-OPTIONS cookie."
:group 'org-export-html
:package-version '(Org . "9.4")
:type 'string)
(defun org-html-infojs-install-script (exp-plist _backend)
"Install script in export options when appropriate.
EXP-PLIST is a plist containing export options. BACKEND is the
export backend currently used."
(unless (or (memq 'body-only (plist-get exp-plist :export-options))
(not (plist-get exp-plist :html-use-infojs))
(and (eq (plist-get exp-plist :html-use-infojs) 'when-configured)
(let ((opt (plist-get exp-plist :infojs-opt)))
(or (not opt)
(string= "" opt)
(string-match "\\<view:nil\\>" opt)))))
(let* ((template (plist-get exp-plist :html-infojs-template))
(ptoc (plist-get exp-plist :with-toc))
(hlevels (plist-get exp-plist :headline-levels))
(sdepth hlevels)
(tdepth (if (integerp ptoc) (min ptoc hlevels) hlevels))
(options (plist-get exp-plist :infojs-opt))
(infojs-opt (plist-get exp-plist :html-infojs-options))
(table org-html-infojs-opts-table)
style)
(dolist (entry table)
(let* ((opt (car entry))
(var (nth 1 entry))
;; Compute default values for script option OPT from
;; `org-html-infojs-options' variable.
(default
(let ((default (cdr (assq opt infojs-opt))))
(if (and (symbolp default) (not (memq default '(t nil))))
(plist-get exp-plist default)
default)))
;; Value set through INFOJS_OPT keyword has precedence
;; over the default one.
(val (if (and options
(string-match (format "\\<%s:\\(\\S-+\\)" opt)
options))
(match-string 1 options)
default)))
(pcase opt
(`path (setq template
(replace-regexp-in-string
"%SCRIPT_PATH" val template t t)))
(`sdepth (when (integerp (read val))
(setq sdepth (min (read val) sdepth))))
(`tdepth (when (integerp (read val))
(setq tdepth (min (read val) tdepth))))
(_ (setq val
(cond
((or (eq val t) (equal val "t")) "1")
((or (eq val nil) (equal val "nil")) "0")
((stringp val) val)
(t (format "%s" val))))
(push (cons var val) style)))))
;; Now we set the depth of the *generated* TOC to SDEPTH,
;; because the toc will actually determine the splitting. How
;; much of the toc will actually be displayed is governed by the
;; TDEPTH option.
(setq exp-plist (plist-put exp-plist :with-toc sdepth))
;; The table of contents should not show more sections than we
;; generate.
(setq tdepth (min tdepth sdepth))
(push (cons "TOC_DEPTH" tdepth) style)
;; Build style string.
(setq style (mapconcat
(lambda (x)
(format "org_html_manager.set(\"%s\", \"%s\");"
(car x) (cdr x)))
style "\n"))
(when (and style (> (length style) 0))
(and (string-match "%MANAGER_OPTIONS" template)
(setq style (replace-match style t t template))
(setq exp-plist
(plist-put
exp-plist :html-head-extra
(concat (or (plist-get exp-plist :html-head-extra) "")
"\n"
style)))))
;; This script absolutely needs the table of contents, so we
;; change that setting.
(unless (plist-get exp-plist :with-toc)
(setq exp-plist (plist-put exp-plist :with-toc t)))
;; Return the modified property list.
exp-plist)))
;;;; Bold, etc.
(defcustom org-html-text-markup-alist
'((bold . "<b>%s</b>")
(code . "<code>%s</code>")
(italic . "<i>%s</i>")
(strike-through . "<del>%s</del>")
(underline . "<span class=\"underline\">%s</span>")
(verbatim . "<code>%s</code>"))
"Alist of HTML expressions to convert text markup.
The key must be a symbol among `bold', `code', `italic',
`strike-through', `underline' and `verbatim'. The value is
a formatting string to wrap fontified text with.
If no association can be found for a given markup, text will be
returned as-is."
:group 'org-export-html
:version "24.4"
:package-version '(Org . "8.0")
:type '(alist :key-type (symbol :tag "Markup type")
:value-type (string :tag "Format string"))
:options '(bold code italic strike-through underline verbatim))
(defcustom org-html-indent nil
"Non-nil means to indent the generated HTML.
Warning: non-nil may break indentation of source code blocks."
:group 'org-export-html
:version "24.4"
:package-version '(Org . "8.0")
:type 'boolean)
;;;; Drawers
(defcustom org-html-format-drawer-function (lambda (_name contents) contents)
"Function called to format a drawer in HTML code.
The function must accept two parameters:
NAME the drawer name, like \"LOGBOOK\"
CONTENTS the contents of the drawer.
The function should return the string to be exported.
The default value simply returns the value of CONTENTS."
:group 'org-export-html
:version "24.4"
:package-version '(Org . "8.0")
:type 'function)
;;;; Footnotes
(defcustom org-html-footnotes-section "<div id=\"footnotes\">
<h2 class=\"footnotes\">%s: </h2>
<div id=\"text-footnotes\">
%s
</div>
</div>"
"Format for the footnotes section.
Should contain a two instances of %s. The first will be replaced with the
language-specific word for \"Footnotes\", the second one will be replaced
by the footnotes themselves."
:group 'org-export-html
:type 'string)
(defcustom org-html-footnote-format "<sup>%s</sup>"
"The format for the footnote reference.
%s will be replaced by the footnote reference itself."
:group 'org-export-html
:type 'string)
(defcustom org-html-footnote-separator "<sup>, </sup>"
"Text used to separate footnotes."
:group 'org-export-html
:type 'string)
;;;; Headline
(defcustom org-html-toplevel-hlevel 2
"The <H> level for level 1 headings in HTML export.
This is also important for the classes that will be wrapped around headlines
and outline structure. If this variable is 1, the top-level headlines will
be <h1>, and the corresponding classes will be outline-1, section-number-1,
and outline-text-1. If this is 2, all of these will get a 2 instead.
The default for this variable is 2, because we use <h1> for formatting the
document title."
:group 'org-export-html
:type 'integer)
(defcustom org-html-format-headline-function
'org-html-format-headline-default-function
"Function to format headline text.
This function will be called with six arguments:
TODO the todo keyword (string or nil).
TODO-TYPE the type of todo (symbol: `todo', `done', nil)
PRIORITY the priority of the headline (integer or nil)
TEXT the main headline text (string).
TAGS the tags (string or nil).
INFO the export options (plist).
The function result will be used in the section format string."
:group 'org-export-html
:version "26.1"
:package-version '(Org . "8.3")
:type 'function)
;;;; HTML-specific
(defcustom org-html-allow-name-attribute-in-anchors nil
"When nil, do not set \"name\" attribute in anchors.
By default, when appropriate, anchors are formatted with \"id\"
but without \"name\" attribute."
:group 'org-export-html
:version "24.4"
:package-version '(Org . "8.0")
:type 'boolean)
(defcustom org-html-self-link-headlines nil
"When non-nil, the headlines contain a hyperlink to themselves."
:group 'org-export-html
:package-version '(Org . "9.3")
:type 'boolean
:safe #'booleanp)
(defcustom org-html-prefer-user-labels nil
"When non-nil use user-defined names and ID over internal ones.
By default, Org generates its own internal ID values during HTML
export. This process ensures that these values are unique and
valid, but the keys are not available in advance of the export
process, and not so readable.
When this variable is non-nil, Org will use NAME keyword, or the
real name of the target to create the ID attribute.
Independently of this variable, however, CUSTOM_ID are always
used as a reference."
:group 'org-export-html
:package-version '(Org . "9.4")
:type 'boolean
:safe #'booleanp)
;;;; Inlinetasks
(defcustom org-html-format-inlinetask-function
'org-html-format-inlinetask-default-function
"Function called to format an inlinetask in HTML code.
The function must accept seven parameters:
TODO the todo keyword, as a string
TODO-TYPE the todo type, a symbol among `todo', `done' and nil.
PRIORITY the inlinetask priority, as a string
NAME the inlinetask name, as a string.
TAGS the inlinetask tags, as a list of strings.
CONTENTS the contents of the inlinetask, as a string.
INFO the export options, as a plist
The function should return the string to be exported."
:group 'org-export-html
:version "26.1"
:package-version '(Org . "8.3")
:type 'function)
;;;; LaTeX
(defcustom org-html-equation-reference-format "\\eqref{%s}"
"The MathJax command to use when referencing equations.
This is a format control string that expects a single string argument
specifying the label that is being referenced. The argument is
generated automatically on export.
The default is to wrap equations in parentheses (using \"\\eqref{%s}\)\".
Most common values are:
\\eqref{%s} Wrap the equation in parentheses
\\ref{%s} Do not wrap the equation in parentheses"
:group 'org-export-html
:package-version '(Org . "9.4")
:type 'string
:safe #'stringp)
(defcustom org-html-with-latex org-export-with-latex
"Non-nil means process LaTeX math snippets.
When set, the exporter will process LaTeX environments and
fragments.
This option can also be set with the +OPTIONS line,
e.g. \"tex:mathjax\". Allowed values are:
nil Ignore math snippets.
`verbatim' Keep everything in verbatim
`mathjax', t Do MathJax preprocessing and arrange for MathJax.js to
be loaded.
`html' Use `org-latex-to-html-convert-command' to convert
LaTeX fragments to HTML.
SYMBOL Any symbol defined in `org-preview-latex-process-alist',
e.g., `dvipng'."
:group 'org-export-html
:version "24.4"
:package-version '(Org . "8.0")
:type '(choice
(const :tag "Do not process math in any way" nil)
(const :tag "Leave math verbatim" verbatim)
(const :tag "Use MathJax to display math" mathjax)
(symbol :tag "Convert to image to display math" :value dvipng)))
;;;; Links :: Generic
(defcustom org-html-link-org-files-as-html t
"Non-nil means make file links to \"file.org\" point to \"file.html\".
When Org mode is exporting an Org file to HTML, links to non-HTML files
are directly put into a \"href\" tag in HTML. However, links to other Org files
\(recognized by the extension \".org\") should become links to the corresponding
HTML file, assuming that the linked Org file will also be converted to HTML.
Links to \"file.org.gpg\" are also converted.
When nil, the links still point to the plain \".org\" file."
:group 'org-export-html
:type 'boolean)
;;;; Links :: Inline images
(defcustom org-html-inline-images t
"Non-nil means inline images into exported HTML pages.
This is done using an <img> tag. When nil, an anchor with href is used to
link to the image."
:group 'org-export-html
:version "24.4"
:package-version '(Org . "8.1")
:type 'boolean)
(defcustom org-html-inline-image-rules
`(("file" . ,(regexp-opt '(".jpeg" ".jpg" ".png" ".gif" ".svg" ".webp" ".avif")))
("http" . ,(regexp-opt '(".jpeg" ".jpg" ".png" ".gif" ".svg" ".webp" ".avif")))
("https" . ,(regexp-opt '(".jpeg" ".jpg" ".png" ".gif" ".svg" ".webp" ".avif"))))
"Rules characterizing image files that can be inlined into HTML.
A rule consists in an association whose key is the type of link
to consider, and value is a regexp that will be matched against
link's path."
:group 'org-export-html
:package-version '(Org . "9.7")
:type '(alist :key-type (string :tag "Type")
:value-type (regexp :tag "Path")))
;;;; Plain Text
(defvar org-html-protect-char-alist
'(("&" . "&")
("<" . "<")
(">" . ">"))
"Alist of characters to be converted by `org-html-encode-plain-text'.")
;;;; Src Block
(defcustom org-html-htmlize-output-type 'inline-css
"Output type to be used by htmlize when formatting code snippets.
Choices are `css' to export the CSS selectors only,`inline-css'
to export the CSS attribute values inline in the HTML or nil to
export plain text. We use as default `inline-css', in order to
make the resulting HTML self-containing.
However, this will fail when using Emacs in batch mode for export, because
then no rich font definitions are in place. It will also not be good if
people with different Emacs setup contribute HTML files to a website,
because the fonts will represent the individual setups. In these cases,
it is much better to let Org/Htmlize assign classes only, and to use
a style file to define the look of these classes.
To get a start for your css file, start Emacs session and make sure that
all the faces you are interested in are defined, for example by loading files
in all modes you want. Then, use the command
`\\[org-html-htmlize-generate-css]' to extract class definitions."
:group 'org-export-html
:type '(choice (const css) (const inline-css) (const nil))
:safe #'symbolp)
(defcustom org-html-htmlize-font-prefix "org-"
"The prefix for CSS class names for htmlize font specifications."
:group 'org-export-html
:type 'string)
(defcustom org-html-wrap-src-lines nil
"If non-nil, wrap individual lines of source blocks in \"code\" elements.
In this case, add line number in attribute \"data-ox-html-linenr\" when line
numbers are enabled."
:group 'org-export-html
:package-version '(Org . "9.3")
:type 'boolean
:safe #'booleanp)
;;;; Table
(defcustom org-html-table-default-attributes
'(:border "2" :cellspacing "0" :cellpadding "6" :rules "groups" :frame "hsides")
"Default attributes and values which will be used in table tags.
This is a plist where attributes are symbols, starting with
colons, and values are strings.
When exporting to HTML5, these values will be disregarded."
:group 'org-export-html
:version "24.4"
:package-version '(Org . "8.0")
:type '(plist :key-type (symbol :tag "Property")
:value-type (string :tag "Value")))
(defcustom org-html-table-header-tags '("<th scope=\"%s\"%s>" . "</th>")
"The opening and ending tags for table header fields.
This is customizable so that alignment options can be specified.
The first %s will be filled with the scope of the field, either row or col.
The second %s will be replaced by a style entry to align the field.
See also the variable `org-html-table-use-header-tags-for-first-column'.
See also the variable `org-html-table-align-individual-fields'."
:group 'org-export-html
:type '(cons (string :tag "Opening tag") (string :tag "Closing tag")))
(defcustom org-html-table-data-tags '("<td%s>" . "</td>")
"The opening and ending tags for table data fields.
This is customizable so that alignment options can be specified.
The first %s will be filled with the scope of the field, either row or col.
The second %s will be replaced by a style entry to align the field.
See also the variable `org-html-table-align-individual-fields'."
:group 'org-export-html
:type '(cons (string :tag "Opening tag") (string :tag "Closing tag")))
(defcustom org-html-table-row-open-tag "<tr>"
"The opening tag for table rows.
This is customizable so that alignment options can be specified.
Instead of strings, these can be a Lisp function that will be
evaluated for each row in order to construct the table row tags.
The function will be called with these arguments:
`number': row number (0 is the first row)
`group-number': group number of current row
`start-group?': non-nil means the row starts a group
`end-group?': non-nil means the row ends a group
`top?': non-nil means this is the top row
`bottom?': non-nil means this is the bottom row
For example:
(setq org-html-table-row-open-tag
(lambda (number group-number start-group? end-group-p top? bottom?)
(cond (top? \"<tr class=\\\"tr-top\\\">\")
(bottom? \"<tr class=\\\"tr-bottom\\\">\")
(t (if (= (mod number 2) 1)
\"<tr class=\\\"tr-odd\\\">\"
\"<tr class=\\\"tr-even\\\">\")))))
will use the \"tr-top\" and \"tr-bottom\" classes for the top row
and the bottom row, and otherwise alternate between \"tr-odd\" and
\"tr-even\" for odd and even rows."
:group 'org-export-html
:type '(choice :tag "Opening tag"
(string :tag "Specify")
(function)))
(defcustom org-html-table-row-close-tag "</tr>"
"The closing tag for table rows.
This is customizable so that alignment options can be specified.
Instead of strings, this can be a Lisp function that will be
evaluated for each row in order to construct the table row tags.
See documentation of `org-html-table-row-open-tag'."
:group 'org-export-html
:type '(choice :tag "Closing tag"
(string :tag "Specify")
(function)))
(defcustom org-html-table-align-individual-fields t
"Non-nil means attach style attributes for alignment to each table field.
When nil, alignment will only be specified in the column tags, but this
is ignored by some browsers (like Firefox, Safari). Opera does it right
though."
:group 'org-export-html
:type 'boolean)
(defcustom org-html-table-use-header-tags-for-first-column nil
"Non-nil means format column one in tables with header tags.
When nil, also column one will use data tags."
:group 'org-export-html
:type 'boolean)
(defcustom org-html-table-caption-above t
"When non-nil, place caption string at the beginning of the table.
Otherwise, place it near the end."
:group 'org-export-html
:type 'boolean)
;;;; Tags
(defcustom org-html-tag-class-prefix ""
"Prefix to class names for TODO keywords.
Each tag gets a class given by the tag itself, with this prefix.
The default prefix is empty because it is nice to just use the keyword
as a class name. But if you get into conflicts with other, existing
CSS classes, then this prefix can be very useful."
:group 'org-export-html
:type 'string)
;;;; Template :: Generic
(defcustom org-html-extension "html"
"The extension for exported HTML files."
:group 'org-export-html
:type 'string)
(defcustom org-html-xml-declaration
'(("html" . "<?xml version=\"1.0\" encoding=\"%s\"?>")
("php" . "<?php echo \"<?xml version=\\\"1.0\\\" encoding=\\\"%s\\\" ?>\"; ?>"))
"The extension for exported HTML files.
%s will be replaced with the charset of the exported file.
This may be a string, or an alist with export extensions
and corresponding declarations.
This declaration only applies when exporting to XHTML."
:group 'org-export-html
:type '(choice
(string :tag "Single declaration")
(repeat :tag "Dependent on extension"
(cons (string :tag "Extension")
(string :tag "Declaration")))))
(defcustom org-html-coding-system 'utf-8
"Coding system for HTML export.
Use utf-8 as the default value."
:group 'org-export-html
:version "24.4"
:package-version '(Org . "8.0")
:type 'coding-system)
(defcustom org-html-doctype "xhtml-strict"
"Document type definition to use for exported HTML files.
Can be set with the in-buffer HTML_DOCTYPE property or for
publishing, with :html-doctype."
:group 'org-export-html
:version "24.4"
:package-version '(Org . "8.0")
:type (append
'(choice)
(mapcar (lambda (x) `(const ,(car x))) org-html-doctype-alist)
'((string :tag "Custom doctype" ))))
(defcustom org-html-html5-fancy nil
"Non-nil means using new HTML5 elements.
This variable is ignored for anything other than HTML5 export."
:group 'org-export-html
:version "24.4"
:package-version '(Org . "8.0")
:type 'boolean)
(defcustom org-html-container-element "div"
"HTML element to use for wrapping top level sections.
Can be set with the in-buffer HTML_CONTAINER property or for
publishing, with :html-container.
Note that changing the default will prevent you from using
org-info.js for your website."
:group 'org-export-html
:version "24.4"
:package-version '(Org . "8.0")
:type 'string)
(defcustom org-html-content-class "content"
"CSS class name to use for the top level content wrapper.
Can be set with the in-buffer HTML_CONTENT_CLASS property or for
publishing, with :html-content-class."
:group 'org-export-html
:version "27.2"
:package-version '(Org . "9.5")
:type 'string)
(defcustom org-html-divs
'((preamble "div" "preamble")
(content "div" "content")
(postamble "div" "postamble"))
"Alist of the three section elements for HTML export.
The car of each entry is one of `preamble', `content' or `postamble'.
The cdrs of each entry are the ELEMENT_TYPE and ID for each
section of the exported document.
Note that changing the default will prevent you from using
org-info.js for your website."
:group 'org-export-html
:version "24.4"
:package-version '(Org . "8.0")
:type '(list :greedy t
(list :tag "Preamble"
(const :format "" preamble)
(string :tag "element") (string :tag " id"))
(list :tag "Content"
(const :format "" content)
(string :tag "element") (string :tag " id"))
(list :tag "Postamble" (const :format "" postamble)
(string :tag " id") (string :tag "element"))))
(defconst org-html-checkbox-types
'((unicode .
((on . "☑") (off . "☐") (trans . "☐")))
(ascii .
((on . "<code>[X]</code>")
(off . "<code>[ ]</code>")
(trans . "<code>[-]</code>")))
(html .
((on . "<input type='checkbox' checked='checked' />")
(off . "<input type='checkbox' />")
(trans . "<input type='checkbox' />"))))
"Alist of checkbox types.
The cdr of each entry is an alist list three checkbox types for
HTML export: `on', `off' and `trans'.
The choices are:
`unicode' Unicode characters (HTML entities)
`ascii' ASCII characters
`html' HTML checkboxes
Note that only the ascii characters implement tri-state
checkboxes. The other two use the `off' checkbox for `trans'.")
(defcustom org-html-checkbox-type 'ascii
"The type of checkboxes to use for HTML export.
See `org-html-checkbox-types' for the values used for each
option."
:group 'org-export-html
:version "24.4"
:package-version '(Org . "8.0")
:type '(choice
(const :tag "ASCII characters" ascii)
(const :tag "Unicode characters" unicode)
(const :tag "HTML checkboxes" html)))
(defcustom org-html-metadata-timestamp-format "%Y-%m-%d %a %H:%M"
"Format used for timestamps in preamble, postamble and metadata.
See `format-time-string' for more information on its components."
:group 'org-export-html
:version "24.4"
:package-version '(Org . "8.0")
:type 'string)
;;;; Template :: Mathjax
(defcustom org-html-mathjax-options
'((path "https://cdn.jsdelivr.net/npm/mathjax@3/es5/tex-mml-chtml.js")
(scale 1.0)
(align "center")
(font "mathjax-modern")
(overflow "overflow")
(tags "ams")
(indent "0em")
(multlinewidth "85%")
(tagindent ".8em")
(tagside "right"))
"Options for MathJax setup.
Alist of the following elements.
path The path to MathJax version 3 or later.
scale Scaling with HTML-CSS, MathML and SVG output engines.
align How to align display math: left, center, or right.
font The font to use with HTML-CSS and SVG output. Needs
MathJax version 4+. MathJax 4 provides 11 fonts:
\"mathjax-modern\" Latin-Modern font, default in MathJax 4+
\"mathjax-asana\" Asana-Math font
\"mathjax-bonum\" Gyre Bonum font
\"mathjax-dejavu\" Gyre DejaVu font
\"mathjax-pagella\" Gyre Pagella font
\"mathjax-schola\" Gyre Schola font
\"mathjax-termes\" Gyre Termes font
\"mathjax-stix2\" STIX2 font
\"mathjax-fira\" Fira and Fira-Math fonts
\"mathjax-euler\" Neo Euler font that extends Latin-Modern
\"mathjax-tex\" The original MathJax TeX font
overflow How to break displayed equations when too large. Needs
MathJax 4 or newer. Supported options include
\"overflow\", \"scale\", \"scroll\", \"truncate\",
\"linebreak\", and \"elide\".
linebreaks Let MathJax perform automatic linebreaks. Valid values
are \"true\" and \"false\".
indent If align is not center, how far from the left/right side? For
example, \"1em\".
multlinewidth The width of the multline environment.
tags How to number equations. Valid values are \"none\",
\"all\" and \"ams\".
tagindent The amount tags are indented.
tagside Which side to show tags/labels on. Valid values are
\"left\" and \"right\"
You can also customize this for some buffer, using something like
#+HTML_MATHJAX: align: left indent: 5em tagside: left
For further information about MathJax options, see the MathJax documentation:
https://docs.mathjax.org/
To maintain compatibility with pre-9.6 Org that used MathJax 2,
the following conversions take place.
The legacy \"autonumber\" option, with the value \"AMS\",
\"None\", or \"All\", becomes the \"tags\" option set to the
value \"ams\", \"none\", or \"all\", respectively.
Any legacy values of the \"scale\" option, specified as
percentage strings, become converted to unit-interval numbers.
For example, a legacy scale of \"150\" becomes a scale of 1.5.
The legacy \"linebreaks\" option, with the value \"true\" or
\"false\", becomes the \"overflow\" option set to the value
\"linebreak\" or \"overflow\", respectively.
The legacy values of the \"font\" option, namely \"TeX\",
\"STIX-Web\", \"Asana-Math\", \"Neo-Euler\", \"Gyre-Pagella\",
\"Gyre-Termes\", \"Latin-Modern\", become converted to the
corresponding MathJax 4+ font names.
Legacy options and values always take precedence."
:group 'org-export-html
:package-version '(Org . "9.6")
:type '(list :greedy t
(list :tag "path (the path from where to load MathJax.js)"
(const :format " " path) (string))
(list :tag "scale (scaling for the displayed math)"
(const :format " " scale) (float))
(list :tag "align (alignment of displayed equations)"
(const :format " " align) (string))
(list :tag "font (used to typeset math)"
(const :format " " font)
(choice (const "mathjax-modern")
(const "mathjax-asana")
(const "mathjax-bonum")
(const "mathjax-dejavu")
(const "mathjax-pagella")
(const "mathjax-schola")
(const "mathjax-termes")
(const "mathjax-stix2")
(const "mathjax-fira")
(const "mathjax-euler")
(const "mathjax-tex")))
(list :tag "overflow (how to break displayed math)"
(const :format " " overflow)
(choice (const "overflow")
(const "scale")
(const "scroll")
(const "truncate")
(const "linebreak")
(const "elide")))
(list :tag "tags (whether equations are numbered and how)"
(const :format " " tags)
(choice (const "ams")
(const "none")
(const "all")))
(list :tag "indent (indentation with left or right alignment)"
(const :format " " indent) (string))
(list :tag "multlinewidth (width to use for the multline environment)"
(const :format " " multlinewidth) (string))
(list :tag "tagindent (the indentation of tags from left or right)"
(const :format " " tagindent) (string))
(list :tag "tagside (location of tags)"
(const :format " " tagside)
(choice (const "left")
(const "right")))))
(defcustom org-html-mathjax-template
"<script>
window.MathJax = {
tex: {
ams: {
multlineWidth: '%MULTLINEWIDTH'
},
tags: '%TAGS',
tagSide: '%TAGSIDE',
tagIndent: '%TAGINDENT'
},
chtml: {
scale: %SCALE,
displayAlign: '%ALIGN',
displayIndent: '%INDENT'
},
svg: {
scale: %SCALE,
displayAlign: '%ALIGN',
displayIndent: '%INDENT'
},
output: {
font: '%FONT',
displayOverflow: '%OVERFLOW'
}
};
</script>
<script
id=\"MathJax-script\"
async
src=\"%PATH\">
</script>"
"The MathJax template. See also `org-html-mathjax-options'."
:group 'org-export-html
:type 'string)
;;;; Template :: Postamble
(defcustom org-html-postamble 'auto
"Non-nil means insert a postamble in HTML export.
When set to `auto', check against the
`org-export-with-author/email/creator/date' variables to set the
content of the postamble. When t, insert a string as defined by the
formatting string in `org-html-postamble-format'. When set to a
string, use this formatting string instead (see
`org-html-postamble-format' for an example of such a formatting
string).
When set to a function, apply this function and insert the
returned string. The function takes the property list of export
options as its only argument.
Setting :html-postamble in publishing projects will take
precedence over this variable."
:group 'org-export-html
:type '(choice (const :tag "No postamble" nil)
(const :tag "Auto postamble" auto)
(const :tag "Default formatting string" t)
(string :tag "Custom formatting string")
(function :tag "Function (must return a string)")))
(defcustom org-html-postamble-format
'(("en" "<p class=\"author\">Author: %a (%e)</p>
<p class=\"date\">Date: %d</p>
<p class=\"creator\">%c</p>
<p class=\"validation\">%v</p>"))
"Alist of languages and format strings for the HTML postamble.
The first element of each list is the language code, as used for
the LANGUAGE keyword. See `org-export-default-language'.
The second element of each list is a format string to format the
postamble itself. This format string can contain these elements:
%t stands for the title.
%s stands for the subtitle.
%a stands for the author's name.
%e stands for the author's email.
%d stands for the date.
%c will be replaced by `org-html-creator-string'.
%v will be replaced by `org-html-validation-link'.
%T will be replaced by the export time.
%C will be replaced by the last modification time.
If you need to use a \"%\" character, you need to escape it
like that: \"%%\"."
:group 'org-export-html
:type '(repeat
(list (string :tag "Language")
(string :tag "Format string"))))
(defcustom org-html-validation-link
"<a href=\"https://validator.w3.org/check?uri=referer\">Validate</a>"
"Link to HTML validation service."
:group 'org-export-html
:package-version '(Org . "9.4")
:type 'string)
(defcustom org-html-creator-string
(format "<a href=\"https://www.gnu.org/software/emacs/\">Emacs</a> %s (<a href=\"https://orgmode.org\">Org</a> mode %s)"
emacs-version
(if (fboundp 'org-version) (org-version) "unknown version"))
"Information about the creator of the HTML document.
This option can also be set on with the CREATOR keyword."
:group 'org-export-html
:version "24.4"
:package-version '(Org . "8.0")
:type '(string :tag "Creator string"))
;;;; Template :: Preamble
(defcustom org-html-preamble t
"Non-nil means insert a preamble in HTML export.
When t, insert a string as defined by the formatting string in
`org-html-preamble-format'. When set to a string, use this
formatting string instead (see `org-html-postamble-format' for an
example of such a formatting string).
When set to a function, apply this function and insert the
returned string. The function takes the property list of export
options as its only argument.
Setting :html-preamble in publishing projects will take
precedence over this variable."
:group 'org-export-html
:type '(choice (const :tag "No preamble" nil)
(const :tag "Default preamble" t)
(string :tag "Custom formatting string")
(function :tag "Function (must return a string)")))
(defcustom org-html-preamble-format '(("en" ""))
"Alist of languages and format strings for the HTML preamble.
The first element of each list is the language code, as used for
the LANGUAGE keyword. See `org-export-default-language'.
The second element of each list is a format string to format the
preamble itself. This format string can contain these elements:
%t stands for the title.
%s stands for the subtitle.
%a stands for the author's name.
%e stands for the author's email.
%d stands for the date.
%c will be replaced by `org-html-creator-string'.
%v will be replaced by `org-html-validation-link'.
%T will be replaced by the export time.
%C will be replaced by the last modification time.
If you need to use a \"%\" character, you need to escape it
like that: \"%%\".
See the default value of `org-html-postamble-format' for an
example."
:group 'org-export-html
:type '(repeat
(list (string :tag "Language")
(string :tag "Format string"))))
(defcustom org-html-link-up ""
"Where should the \"UP\" link of exported HTML pages lead?"
:group 'org-export-html
:type '(string :tag "File or URL"))
(defcustom org-html-link-home ""
"Where should the \"HOME\" link of exported HTML pages lead?"
:group 'org-export-html
:type '(string :tag "File or URL"))
(defcustom org-html-link-use-abs-url nil
"Should we prepend relative links with HTML_LINK_HOME?"
:group 'org-export-html
:version "24.4"
:package-version '(Org . "8.1")
:type 'boolean)
(defcustom org-html-home/up-format
"<div id=\"org-div-home-and-up\">
<a accesskey=\"h\" href=\"%s\"> UP </a>
|
<a accesskey=\"H\" href=\"%s\"> HOME </a>
</div>"
"Snippet used to insert the HOME and UP links.
This is a format string, the first %s will receive the UP link,
the second the HOME link. If both `org-html-link-up' and
`org-html-link-home' are empty, the entire snippet will be
ignored."
:group 'org-export-html
:type 'string)
;;;; Template :: Scripts
(defcustom org-html-head-include-scripts nil
"Non-nil means include the JavaScript snippets in exported HTML files.
The actual script is defined in `org-html-scripts'."
:group 'org-export-html
:version "24.4"
:package-version '(Org . "8.0")
:type 'boolean)
;;;; Template :: Styles
(defcustom org-html-meta-tags #'org-html-meta-tags-default
"Form that is used to produce meta tags in the HTML head.
Can be a list where each item is a list of arguments to be passed
to `org-html--build-meta-entry'. Any nil items are ignored.
Also accept a function which gives such a list when called with a
single argument (INFO, a communication plist)."
:group 'org-export-html
:package-version '(Org . "9.5")
:type '(choice
(repeat
(list (string :tag "Meta label")
(string :tag "label value")
(string :tag "Content value")))
function))
(defcustom org-html-head-include-default-style t
"Non-nil means include the default style in exported HTML files.
The actual style is defined in `org-html-style-default' and
should not be modified. Use `org-html-head' to use your own
style information."
:group 'org-export-html
:version "24.4"
:package-version '(Org . "8.0")
:type 'boolean)
;;;###autoload
(put 'org-html-head-include-default-style 'safe-local-variable 'booleanp)
(defcustom org-html-head ""
"Org-wide head definitions for exported HTML files.
This variable can contain the full HTML structure to provide a
style, including the surrounding HTML tags. You can consider
including definitions for the following classes: title, todo,
done, timestamp, timestamp-kwd, tag, target.
For example, a valid value would be:
<style>
p { font-weight: normal; color: gray; }
h1 { color: black; }
.title { text-align: center; }
.todo, .timestamp-kwd { color: red; }
.done { color: green; }
</style>
If you want to refer to an external style, use something like
<link rel=\"stylesheet\" type=\"text/css\" href=\"mystyles.css\" />
As the value of this option simply gets inserted into the HTML
<head> header, you can use it to add any arbitrary text to the
header.
You can set this on a per-file basis using #+HTML_HEAD:,
or for publication projects using the :html-head property."
:group 'org-export-html
:version "24.4"
:package-version '(Org . "8.0")
:type 'string)
;;;###autoload
(put 'org-html-head 'safe-local-variable 'stringp)
(defcustom org-html-head-extra ""
"More head information to add in the HTML output.
You can set this on a per-file basis using #+HTML_HEAD_EXTRA:,
or for publication projects using the :html-head-extra property."
:group 'org-export-html
:version "24.4"
:package-version '(Org . "8.0")
:type 'string)
;;;###autoload
(put 'org-html-head-extra 'safe-local-variable 'stringp)
;;;; Template :: Viewport
(defcustom org-html-viewport '((width "device-width")
(initial-scale "1")
(minimum-scale "")
(maximum-scale "")
(user-scalable ""))
"Viewport options for mobile-optimized sites.
The following values are recognized
width Size of the viewport.
initial-scale Zoom level when the page is first loaded.
minimum-scale Minimum allowed zoom level.
maximum-scale Maximum allowed zoom level.
user-scalable Whether zoom can be changed.
The viewport meta tag is inserted if this variable is non-nil.
See the following site for a reference:
https://developer.mozilla.org/en-US/docs/Mozilla/Mobile/Viewport_meta_tag"
:group 'org-export-html
:version "26.1"
:package-version '(Org . "8.3")
:type '(choice (const :tag "Disable" nil)
(list :tag "Enable"
(list :tag "Width of viewport"
(const :format " " width)
(choice (const :tag "unset" "")
(string)))
(list :tag "Initial scale"
(const :format " " initial-scale)
(choice (const :tag "unset" "")
(string)))
(list :tag "Minimum scale/zoom"
(const :format " " minimum-scale)
(choice (const :tag "unset" "")
(string)))
(list :tag "Maximum scale/zoom"
(const :format " " maximum-scale)
(choice (const :tag "unset" "")
(string)))
(list :tag "User scalable/zoomable"
(const :format " " user-scalable)
(choice (const :tag "unset" "")
(const "true")
(const "false"))))))
;; Handle source code blocks with Klipse
(defcustom org-html-klipsify-src nil
"When non-nil, source code blocks are editable in exported presentation."
:group 'org-export-html
:package-version '(Org . "9.1")
:type 'boolean)
(defcustom org-html-klipse-css
"https://storage.googleapis.com/app.klipse.tech/css/codemirror.css"
"Location of the codemirror CSS file for use with klipse."
:group 'org-export-html
:package-version '(Org . "9.1")
:type 'string)
(defcustom org-html-klipse-js
"https://storage.googleapis.com/app.klipse.tech/plugin_prod/js/klipse_plugin.min.js"
"Location of the klipse javascript file."
:group 'org-export-html
:type 'string)
(defcustom org-html-klipse-selection-script
"window.klipse_settings = {selector_eval_html: '.src-html',
selector_eval_js: '.src-js',
selector_eval_python_client: '.src-python',
selector_eval_scheme: '.src-scheme',
selector: '.src-clojure',
selector_eval_ruby: '.src-ruby'};"
"Javascript snippet to activate klipse."
:group 'org-export-html
:package-version '(Org . "9.1")
:type 'string)
;;;; Todos
(defcustom org-html-todo-kwd-class-prefix ""
"Prefix to class names for TODO keywords.
Each TODO keyword gets a class given by the keyword itself, with this prefix.
The default prefix is empty because it is nice to just use the keyword
as a class name. But if you get into conflicts with other, existing
CSS classes, then this prefix can be very useful."
:group 'org-export-html
:type 'string)
;;; Internal Functions
(defun org-html-xhtml-p (info)
"Return non-nil when :html-doctype property in INFO plist is xhtml."
(let ((dt (downcase (plist-get info :html-doctype))))
(string-match-p "xhtml" dt)))
(defun org-html-html5-p (info)
"Return non-nil when :html-doctype property in INFO plist is html5 or equivalent."
(let ((dt (downcase (plist-get info :html-doctype))))
(member dt '("html5" "xhtml5" "<!doctype html>"))))
(defun org-html--html5-fancy-p (info)
"Non-nil when exporting to HTML5 with fancy elements.
INFO is the current state of the export process, as a plist."
(and (plist-get info :html-html5-fancy)
(org-html-html5-p info)))
(defun org-html-close-tag (tag attr info)
"Return close-tag for string TAG.
ATTR specifies additional attributes. INFO is a property list
containing current export state."
(concat "<" tag
(org-string-nw-p (concat " " attr))
(if (org-html-xhtml-p info) " />" ">")))
(defun org-html-doctype (info)
"Return correct HTML doctype tag.
INFO is a plist used as a communication channel. Doctype tag is
extracted from `org-html-doctype-alist', or the literal value
of :html-doctype from INFO if :html-doctype is not found in the
alist."
(let ((dt (plist-get info :html-doctype)))
(or (cdr (assoc dt org-html-doctype-alist)) dt)))
(defun org-html--make-attribute-string (attributes)
"Return a list of attributes, as a string.
ATTRIBUTES is a plist where values are either strings or nil. An
attribute with a nil value will be omitted from the result."
(let (output)
(dolist (item attributes (mapconcat 'identity (nreverse output) " "))
(cond ((null item) (pop output))
((symbolp item) (push (substring (symbol-name item) 1) output))
(t (let ((key (car output))
(value (replace-regexp-in-string
"\"" """ (org-html-encode-plain-text item))))
(setcar output (format "%s=\"%s\"" key value))))))))
(defun org-html--reference (datum info &optional named-only)
"Return an appropriate reference for DATUM.
DATUM is an element or a `target' type object. INFO is the
current export state, as a plist.
When NAMED-ONLY is non-nil and DATUM has no NAME keyword, return
nil. This doesn't apply to headlines, inline tasks, radio
targets and targets."
(let* ((type (org-element-type datum))
(custom-id (and (memq type '(headline inlinetask))
(org-element-property :CUSTOM_ID datum)))
(user-label
(or
custom-id
(and (memq type '(radio-target target))
(org-element-property :value datum))
(org-element-property :name datum)
(when-let* ((id (org-element-property :ID datum)))
(concat org-html--id-attr-prefix id)))))
(cond
((and user-label
(or (plist-get info :html-prefer-user-labels)
;; Used CUSTOM_ID property unconditionally.
custom-id))
user-label)
((and named-only
(not (memq type '(headline inlinetask radio-target target)))
(not user-label))
nil)
(t
(org-export-get-reference datum info)))))
(defun org-html--wrap-image (contents info &optional caption label)
"Wrap CONTENTS string within an appropriate environment for images.
INFO is a plist used as a communication channel. When optional
arguments CAPTION and LABEL are given, use them for caption and
\"id\" attribute."
(let ((html5-fancy (org-html--html5-fancy-p info)))
(format (if html5-fancy "\n<figure%s>\n%s%s\n</figure>"
"\n<div%s class=\"figure\">\n%s%s\n</div>")
;; ID.
(if (org-string-nw-p label) (format " id=\"%s\"" label) "")
;; Contents.
(if html5-fancy contents (format "<p>%s</p>" contents))
;; Caption.
(if (not (org-string-nw-p caption)) ""
(format (if html5-fancy "\n<figcaption>%s</figcaption>"
"\n<p>%s</p>")
caption)))))
(defun org-html--format-image (source attributes info)
"Return \"img\" tag with given SOURCE and ATTRIBUTES.
SOURCE is a string specifying the location of the image.
ATTRIBUTES is a plist, as returned by
`org-export-read-attribute'. INFO is a plist used as
a communication channel."
(org-html-close-tag
"img"
(org-html--make-attribute-string
(org-combine-plists
(list :src source
:alt (if (string-match-p
(concat "^" org-preview-latex-image-directory) source)
(org-html-encode-plain-text
(org-find-text-property-in-string 'org-latex-src source))
(file-name-nondirectory source)))
(if (string= "svg" (file-name-extension source))
(org-combine-plists '(:class "org-svg") attributes '(:fallback nil))
attributes)))
info))
(defun org-html--textarea-block (element)
"Transcode ELEMENT into a textarea block.
ELEMENT is either a source or an example block."
(let* ((code (car (org-export-unravel-code element)))
(attr (org-export-read-attribute :attr_html element)))
(format "<p>\n<textarea cols=\"%s\" rows=\"%s\">\n%s</textarea>\n</p>"
(or (plist-get attr :width) 80)
(or (plist-get attr :height) (org-count-lines code))
code)))
(defun org-html--has-caption-p (element &optional _info)
"Non-nil when ELEMENT has a caption affiliated keyword.
INFO is a plist used as a communication channel. This function
is meant to be used as a predicate for `org-export-get-ordinal' or
a value to `org-html-standalone-image-predicate'."
(org-element-property :caption element))
;;;; Table
(defun org-html-htmlize-region-for-paste (beg end)
"Convert the region between BEG and END to HTML, using htmlize.el.
This is much like `htmlize-region-for-paste', only that it uses
the settings define in the org-... variables."
(let* ((htmlize-output-type org-html-htmlize-output-type)
(htmlize-css-name-prefix org-html-htmlize-font-prefix)
(htmlbuf (htmlize-region beg end)))
(unwind-protect
(with-current-buffer htmlbuf
(buffer-substring (plist-get htmlize-buffer-places 'content-start)
(plist-get htmlize-buffer-places 'content-end)))
(kill-buffer htmlbuf))))
;;;###autoload
(defun org-html-htmlize-generate-css ()
"Create the CSS for all font definitions in the current Emacs session.
Use this to create face definitions in your CSS style file that can then
be used by code snippets transformed by htmlize.
This command just produces a buffer that contains class definitions for all
faces used in the current Emacs session. You can copy and paste the ones you
need into your CSS file.
The face definitions are prepended with
`org-html-htmlize-font-prefix'.
If you then set `org-html-htmlize-output-type' to `css', calls
to the function `org-html-htmlize-region-for-paste' will
produce code that uses these same face definitions."
(interactive)
(org-require-package 'htmlize)
(and (get-buffer "*html*") (kill-buffer "*html*"))
(with-temp-buffer
(let ((fl (face-list))
(htmlize-css-name-prefix org-html-htmlize-font-prefix)
(htmlize-output-type 'css)
f i)
(while fl
(setq f (pop fl)
i (and f (face-attribute f :inherit)))
(when (and (symbolp f) (or (not i) (not (listp i))))
(insert (org-add-props (copy-sequence "1") nil 'face f))))
(htmlize-region (point-min) (point-max))))
(pop-to-buffer-same-window "*html*")
(goto-char (point-min))
(when (re-search-forward "<style" nil t)
(delete-region (point-min) (match-beginning 0)))
(when (re-search-forward "</style>" nil t)
(delete-region (1+ (match-end 0)) (point-max)))
(forward-line 0)
(when (looking-at " +") (replace-match ""))
(goto-char (point-min)))
(defun org-html--make-string (n string)
"Build a string by concatenating N times STRING."
(let (out) (dotimes (_ n out) (setq out (concat string out)))))
(defun org-html-fix-class-name (kwd) ; audit callers of this function
"Turn todo keyword KWD into a valid class name.
Replaces invalid characters with \"_\"."
(replace-regexp-in-string "[^a-zA-Z0-9_]" "_" kwd nil t))
(defun org-html-footnote-section (info)
"Format the footnote section.
INFO is a plist used as a communication channel."
(pcase (org-export-collect-footnote-definitions info)
(`nil nil)
(definitions
(format
(plist-get info :html-footnotes-section)
(org-html--translate "Footnotes" info)
(format
"\n%s\n"
(mapconcat
(lambda (definition)
(pcase definition
(`(,n ,label ,def)
;; Do not assign number labels as they appear in Org mode
;; - the footnotes are re-numbered by
;; `org-export-get-footnote-number'. If the label is not
;; a number, keep it.
(when (and (stringp label)
(equal label (number-to-string (string-to-number label))))
(setq label nil))
;; `org-export-collect-footnote-definitions' can return
;; two kinds of footnote definitions: inline and blocks.
;; Since this should not make any difference in the HTML
;; output, we wrap the inline definitions within
;; a "footpara" class paragraph.
(let ((inline? (not (org-element-map def org-element-all-elements
#'identity nil t)))
(anchor (org-html--anchor
(format "fn.%s" (or label n))
n
(format " class=\"footnum\" href=\"#fnr.%s\" role=\"doc-backlink\"" (or label n))
info))
(contents (org-trim (org-export-data def info))))
(format "<div class=\"footdef\">%s %s</div>\n"
(format (plist-get info :html-footnote-format) anchor)
(format "<div class=\"footpara\" role=\"doc-footnote\">%s</div>"
(if (not inline?) contents
(format "<p class=\"footpara\">%s</p>"
contents))))))))
definitions
"\n"))))))
;;; Template
(defun org-html-meta-tags-default (info)
"A default value for `org-html-meta-tags'.
Generate a list items, each of which is a list of arguments that can
be passed to `org-html--build-meta-entry', to generate meta tags to be
included in the HTML head.
Use document's plist INFO to derive relevant information for the tags."
(let ((author (and (plist-get info :with-author)
(let ((auth (plist-get info :author)))
;; Return raw Org syntax.
(and auth (org-element-interpret-data auth))))))
(list
(when (org-string-nw-p author)
(list "name" "author" author))
(when (org-string-nw-p (plist-get info :description))
(list "name" "description"
(plist-get info :description)))
(when (org-string-nw-p (plist-get info :keywords))
(list "name" "keywords" (plist-get info :keywords)))
'("name" "generator" "Org Mode"))))
(defun org-html--build-meta-entry
(label identity &optional content-format &rest content-formatters)
"Build a meta tag using the provided information.
Construct <meta> tag of form <meta LABEL=\"IDENTITY\" />, or when CONTENT-FORMAT
is present: <meta LABEL=\"IDENTITY\" content=\"{content}\" />
Here {content} is determined by applying any CONTENT-FORMATTERS to the
CONTENT-FORMAT and encoding the result as plain text."
(concat "<meta "
(format "%s=\"%s" label identity)
(when content-format
(concat "\" content=\""
(replace-regexp-in-string
"\"" """
(org-html-encode-plain-text
(if content-formatters
(apply #'format content-format content-formatters)
content-format)))))
"\" />\n"))
(defun org-html--build-meta-info (info)
"Return meta tags for exported document.
INFO is a plist used as a communication channel."
(let* ((title (org-html-plain-text
(org-element-interpret-data (plist-get info :title)) info))
;; Set title to an invisible character instead of leaving it
;; empty, which is invalid.
(title (if (org-string-nw-p title) title ""))
(charset (or (and org-html-coding-system
(symbol-name
(coding-system-get org-html-coding-system
'mime-charset)))
"iso-8859-1")))
(concat
(when (plist-get info :time-stamp-file)
(format-time-string
(concat "<!-- "
(plist-get info :html-metadata-timestamp-format)
" -->\n")))
(if (org-html-html5-p info)
(org-html--build-meta-entry "charset" charset)
(org-html--build-meta-entry "http-equiv" "Content-Type"
(concat "text/html;charset=" charset)))
(let ((viewport-options
(cl-remove-if-not (lambda (cell) (org-string-nw-p (cadr cell)))
(plist-get info :html-viewport))))
(if viewport-options
(org-html--build-meta-entry "name" "viewport"
(mapconcat
(lambda (elm)
(format "%s=%s" (car elm) (cadr elm)))
viewport-options ", "))))
(format "<title>%s \n" title)
(mapconcat
(lambda (args) (apply #'org-html--build-meta-entry args))
(delq nil (if (functionp org-html-meta-tags)
(funcall org-html-meta-tags info)
org-html-meta-tags))
""))))
(defun org-html--build-head (info)
"Return information for the .. of the HTML output.
INFO is a plist used as a communication channel."
(org-element-normalize-string
(concat
(when (plist-get info :html-head-include-default-style)
(org-element-normalize-string org-html-style-default))
(org-element-normalize-string (plist-get info :html-head))
(org-element-normalize-string (plist-get info :html-head-extra))
(when (and (plist-get info :html-htmlized-css-url)
(eq org-html-htmlize-output-type 'css))
(org-html-close-tag "link"
(format "rel=\"stylesheet\" href=\"%s\" type=\"text/css\""
(plist-get info :html-htmlized-css-url))
info))
(when (plist-get info :html-head-include-scripts) org-html-scripts))))
(defun org-html--build-mathjax-config (info)
"Insert the user setup into the mathjax template.
INFO is a plist used as a communication channel."
(when (and (memq (plist-get info :with-latex) '(mathjax t))
(org-element-map (plist-get info :parse-tree)
'(latex-fragment latex-environment) #'identity info t nil t))
(let ((template (plist-get info :html-mathjax-template))
(options (let ((options (plist-get info :html-mathjax-options)))
;; If the user customized some legacy option, set
;; the corresponding new option to nil, so that
;; the legacy user choice overrides the default.
;; Otherwise, the user did not set the legacy
;; option, in which case still set the legacy
;; option but to no value, so that the code can
;; find its in-buffer value, if set.
`((,(if (plist-member options 'autonumber)
'tags 'autonumber)
nil)
(,(if (plist-member options 'linebreaks)
'overflow 'linebreaks)
nil)
,@options)))
(in-buffer (or (plist-get info :html-mathjax) "")))
(dolist (e options (org-element-normalize-string template))
(let ((symbol (car e))
(value (nth 1 e)))
(when (string-match (concat "\\<" (symbol-name symbol) ":")
in-buffer)
(setq value
(car (split-string (substring in-buffer
(match-end 0))))))
(when value
(pcase symbol
(`font
(when-let*
((value-new
(pcase value
("TeX" "mathjax-tex")
("STIX-Web" "mathjax-stix2")
("Asana-Math" "mathjax-asana")
("Neo-Euler" "mathjax-euler")
("Gyre-Pagella" "mathjax-pagella")
("Gyre-Termes" "mathjax-termes")
("Latin-Modern" "mathjax-modern"))))
(setq value value-new)))
(`linebreaks
(org-display-warning
"Converting legacy MathJax option: linebreaks")
(setq symbol 'overflow
value (if (string= value "true")
"linebreak"
"overflow")))
(`scale
(when (stringp value)
(let ((value-maybe (string-to-number value)))
(setq value
(if (= value-maybe 0)
(progn
(org-display-warning
(format "Non-numerical MathJax scale: %s"
value))
1.0)
value-maybe))))
(when (>= value 10)
(setq value
(let ((value-new (/ (float value) 100)))
(org-display-warning
(format "Converting legacy MathJax scale: %s to %s"
value
value-new))
value-new))))
(`autonumber
(org-display-warning
"Converting legacy MathJax option: autonumber")
(setq symbol 'tags
value (downcase value))))
(while (string-match (format "\\(%%%s\\)[^A-Z]"
(upcase (symbol-name symbol)))
template)
(setq template
(replace-match (format "%s" value)
t
t template 1)))))))))
(defun org-html-format-spec (info)
"Return format specification for preamble and postamble.
INFO is a plist used as a communication channel."
(let ((timestamp-format (plist-get info :html-metadata-timestamp-format)))
`((?t . ,(org-export-data (plist-get info :title) info))
(?s . ,(org-export-data (plist-get info :subtitle) info))
(?d . ,(org-export-data (org-export-get-date info timestamp-format)
info))
(?T . ,(format-time-string timestamp-format))
(?a . ,(org-export-data (plist-get info :author) info))
(?e . ,(mapconcat
(lambda (e) (format "%s " e e))
(split-string (plist-get info :email) ",+ *")
", "))
(?c . ,(plist-get info :creator))
(?C . ,(let ((file (plist-get info :input-file)))
(format-time-string timestamp-format
(and file (file-attribute-modification-time
(file-attributes file))))))
(?v . ,(or (plist-get info :html-validation-link) "")))))
(defun org-html--build-pre/postamble (type info)
"Return document preamble or postamble as a string, or nil.
TYPE is either `preamble' or `postamble', INFO is a plist used as a
communication channel."
(let ((section (plist-get info (intern (format ":html-%s" type))))
(spec (org-html-format-spec info)))
(when section
(let ((section-contents
(if (functionp section) (funcall section info)
(cond
((stringp section) (format-spec section spec))
((and (eq section 'auto) (eq type 'postamble))
(let ((date (cdr (assq ?d spec)))
(author (cdr (assq ?a spec)))
(email (cdr (assq ?e spec)))
(creator (cdr (assq ?c spec)))
(validation-link (cdr (assq ?v spec))))
(concat
(and (plist-get info :with-date)
(org-string-nw-p date)
(format "%s: %s
\n"
(org-html--translate "Date" info)
date))
(and (plist-get info :with-author)
(org-string-nw-p author)
(format "%s: %s
\n"
(org-html--translate "Author" info)
author))
(and (plist-get info :with-email)
(org-string-nw-p email)
(format "%s: %s
\n"
(org-html--translate "Email" info)
email))
(and (plist-get info :time-stamp-file)
(format
"%s: %s
\n"
(org-html--translate "Created" info)
(format-time-string
(plist-get info :html-metadata-timestamp-format))))
(and (plist-get info :with-creator)
(org-string-nw-p creator)
(format "%s
\n" creator))
(and (org-string-nw-p validation-link)
(format "%s
\n"
validation-link)))))
(t
(let ((formats (plist-get info (if (eq type 'preamble)
:html-preamble-format
:html-postamble-format)))
(language (plist-get info :language)))
(format-spec
(cadr (or (assoc-string language formats t)
(assoc-string "en" formats t)))
spec)))))))
(let ((div (assq type (plist-get info :html-divs))))
(when (org-string-nw-p section-contents)
(concat
(format "<%s id=\"%s\" class=\"%s\">\n"
(nth 1 div)
(nth 2 div)
org-html--pre/postamble-class)
(org-element-normalize-string section-contents)
(format "\n" (nth 1 div)))))))))
(defun org-html-inner-template (contents info)
"Return body of document string after HTML conversion.
CONTENTS is the transcoded contents string. INFO is a plist
holding export options."
(concat
;; Table of contents.
(let ((depth (plist-get info :with-toc)))
(when depth (org-html-toc depth info)))
;; Document contents.
contents
;; Footnotes section.
(org-html-footnote-section info)))
(defun org-html-template (contents info)
"Return complete document string after HTML conversion.
CONTENTS is the transcoded contents string. INFO is a plist
holding export options."
(concat
(when (and (not (org-html-html5-p info)) (org-html-xhtml-p info))
(let* ((xml-declaration (plist-get info :html-xml-declaration))
(decl (or (and (stringp xml-declaration) xml-declaration)
(cdr (assoc (plist-get info :html-extension)
xml-declaration))
(cdr (assoc "html" xml-declaration))
"")))
(when (not (or (not decl) (string= "" decl)))
(format "%s\n"
(format decl
(or (and org-html-coding-system
(coding-system-get org-html-coding-system :mime-charset))
"iso-8859-1"))))))
(org-html-doctype info)
"\n"
(concat "\n")
"\n"
(org-html--build-meta-info info)
(org-html--build-head info)
(org-html--build-mathjax-config info)
"\n"
"\n"
(let ((link-up (org-trim (plist-get info :html-link-up)))
(link-home (org-trim (plist-get info :html-link-home))))
(unless (and (string= link-up "") (string= link-home ""))
(format (plist-get info :html-home/up-format)
(or link-up link-home)
(or link-home link-up))))
;; Preamble.
(org-html--build-pre/postamble 'preamble info)
;; Document contents.
(let ((div (assq 'content (plist-get info :html-divs))))
(format "<%s id=\"%s\" class=\"%s\">\n"
(nth 1 div)
(nth 2 div)
(plist-get info :html-content-class)))
;; Document title.
(when (plist-get info :with-title)
(let ((title (and (plist-get info :with-title)
(plist-get info :title)))
(subtitle (plist-get info :subtitle))
(html5-fancy (org-html--html5-fancy-p info)))
(when title
(format
(if html5-fancy
""
"%s%s \n")
(org-export-data title info)
(if subtitle
(format
(if html5-fancy
"%s
\n"
(concat "\n" (org-html-close-tag "br" nil info) "\n"
"%s \n"))
(org-export-data subtitle info))
"")))))
contents
(format "\n" (nth 1 (assq 'content (plist-get info :html-divs))))
;; Postamble.
(org-html--build-pre/postamble 'postamble info)
;; Possibly use the Klipse library live code blocks.
(when (plist-get info :html-klipsify-src)
(concat "%s" attributes (or desc ""))))
;;;; Todo
(defun org-html--todo (todo info)
"Format TODO keywords into HTML.
TODO is the keyword, as a string.
INFO is the info plist."
(when todo
(format "%s "
(if (member todo org-done-keywords) "done" "todo")
(or (plist-get info :html-todo-kwd-class-prefix) "")
(org-html-fix-class-name todo)
todo)))
;;;; Priority
(defun org-html--priority (priority _info)
"Format a priority into HTML.
PRIORITY is the character code of the priority or nil. INFO is
a plist containing export options."
(and priority (format "[%c] " priority)))
;;;; Tags
(defun org-html--tags (tags info)
"Format TAGS into HTML.
INFO is a plist containing export options."
(when tags
(format "%s "
(mapconcat
(lambda (tag)
(format "%s "
(concat (plist-get info :html-tag-class-prefix)
(org-html-fix-class-name tag))
tag))
tags " "))))
;;;; Src Code
(defun org-html-fontify-code (code lang)
"Color CODE with htmlize library.
CODE is a string representing the source code to colorize. LANG
is the language used for CODE, as a string, or nil."
(when code
(cond
;; No language. Possibly an example block.
((not lang) (org-html-encode-plain-text code))
;; Plain text explicitly set.
((not org-html-htmlize-output-type) (org-html-encode-plain-text code))
;; No htmlize library or an inferior version of htmlize.
((not (progn (require 'htmlize nil t)
(fboundp 'htmlize-region-for-paste)))
;; Emit a warning.
(warn "Cannot fontify source block (htmlize.el >= 1.34 required). Falling back to plain text. (see `org-html-htmlize-output-type')")
(org-html-encode-plain-text code))
(t
;; Map language
(setq lang (or (assoc-default lang org-src-lang-modes) lang))
(let* ((lang-mode (and lang (intern (format "%s-mode" lang)))))
(cond
;; Case 1: Language is not associated with any Emacs mode
((not (functionp lang-mode))
(org-html-encode-plain-text code))
;; Case 2: Default. Fontify code.
(t
;; htmlize
(setq code
(let ((output-type org-html-htmlize-output-type)
(font-prefix org-html-htmlize-font-prefix)
(inhibit-read-only t))
(with-temp-buffer
;; Switch to language-specific mode.
(funcall lang-mode)
(insert code)
;; Fontify buffer.
(font-lock-ensure)
;; Remove formatting on newline characters.
(save-excursion
(let ((beg (point-min))
(end (point-max)))
(goto-char beg)
(while (progn (end-of-line) (< (point) end))
(put-text-property (point) (1+ (point)) 'face nil)
(forward-char 1))))
(org-src-mode)
(set-buffer-modified-p nil)
;; Htmlize region.
(let ((org-html-htmlize-output-type output-type)
(org-html-htmlize-font-prefix font-prefix))
(org-html-htmlize-region-for-paste
(point-min) (point-max))))))
;; Strip any enclosing ]*>\n?" code) (match-end 0)))
(end (and beg (string-match "\\'" code))))
(if (and beg end) (substring code beg end) code)))))))))
(defun org-html-do-format-code
(code &optional lang refs retain-labels num-start wrap-lines)
"Format CODE string as source code.
Optional arguments LANG, REFS, RETAIN-LABELS, NUM-START, WRAP-LINES
are, respectively, the language of the source code, as a string, an
alist between line numbers and references (as returned by
`org-export-unravel-code'), a boolean specifying if labels should
appear in the source code, the number associated to the first
line of code, and a boolean specifying if lines of code should be
wrapped in code elements."
(let* ((code-lines (split-string code "\n"))
(code-length (length code-lines))
(num-fmt
(and num-start
(format "%%%ds: "
(length (number-to-string (+ code-length num-start))))))
(code (org-html-fontify-code code lang)))
(org-export-format-code
code
(lambda (loc line-num ref)
(setq loc
(concat
;; Add line number, if needed.
(when num-start
(format "%s "
(format num-fmt line-num)))
;; Transcoded src line.
(if wrap-lines
(format "%s"
(if num-start
(format " data-ox-html-linenr=\"%s\"" line-num)
"")
loc)
loc)
;; Add label, if needed.
(when (and ref retain-labels) (format " (%s)" ref))))
;; Mark transcoded line as an anchor, if needed.
(if (not ref) loc
(format "