commit f30a74ae51395c7c01494b0ea912a0111c94ce3a
parent ee865fb065c7b71b6a595414145d2bff1a8f3cd5
Author: Vincent Demeester <vincent@sbr.pm>
Date: Mon, 20 Nov 2023 12:51:18 +0100
tools/emacs: some org-mode and denote configuration
Signed-off-by: Vincent Demeester <vincent@sbr.pm>
Diffstat:
4 files changed, 1339 insertions(+), 6 deletions(-)
diff --git a/tools/emacs/config/config-org.el b/tools/emacs/config/config-org.el
@@ -9,7 +9,7 @@
(defconst org-directory "~/desktop/org/"
"org-mode directory, where most of the org-mode file lives")
;; P.A.R.A. setup
-(defconst org-inbox-file (expand-file-name "inbox.org" org-directory)
+(defconst org-inbox-file (expand-file-name "20231120T124316--inbox__inbox.org" org-directory)
"New stuff collected in this file.")
(defconst org-archive-dir (expand-file-name "archive" org-directory)
@@ -19,7 +19,7 @@
"Project files directory.")
(defconst org-projects-completed-dir (expand-file-name "projects" org-archive-dir)
"Directory of completed project files.")
-(defconst org-projects-future-file (expand-file-name "future.org" org-projects-dir)
+(defconst org-projects-future-file (expand-file-name "20231120T124316--future-projects-incubation__project_future.org" org-projects-dir)
"Future projects are collected in this file.")
(defconst org-areas-dir (expand-file-name "areas" org-directory)
@@ -48,6 +48,16 @@
(set-register ?a `(file . ,org-areas-dir))
(set-register ?r `(file . ,org-resources-dir))
+(defun vde/org-mode-hook ()
+ "Org-mode hook"
+ (setq show-trailing-whitespace t)
+ (when (not (eq major-mode 'org-agenda-mode))
+ (setq fill-column 90)
+ (auto-revert-mode)
+ (auto-fill-mode)
+ (org-indent-mode)
+ (add-hook 'before-save-hook #'save-and-update-includes nil 'make-it-local)))
+
(use-package org
:mode (("\\.org$" . org-mode)
("\\.org.draft$" . org-mode))
@@ -57,8 +67,9 @@
("C-c o a a" . org-agenda)
("C-c o s" . org-sort)
("<f12>" . org-agenda))
+ :hook (org-mode . vde/org-mode-hook)
:custom
- (org-reverse-note-order '(("inbox.org" . t) ;; Insert items on top of inbox
+ (org-reverse-note-order '((org-inbox-file . t) ;; Insert items on top of inbox
(".*" . nil))) ;; On any other file, insert at the bottom
(org-archive-location (concat org-archive-dir "/%s::datetree/"))
(org-agenda-file-regexp "^[a-zA-Z0-9-_]+.org$")
@@ -90,7 +101,24 @@
:after org)
(use-package org-tempo
- :after (org))
+ :after (org)
+ :custom
+ (org-structure-template-alist '(("a" . "aside")
+ ("c" . "center")
+ ("C" . "comment")
+ ("e" . "example")
+ ("E" . "export")
+ ("Ea" . "export ascii")
+ ("Eh" . "export html")
+ ("El" . "export latex")
+ ("q" . "quote")
+ ("s" . "src")
+ ("se" . "src emacs-lisp")
+ ("sE" . "src emacs-lisp :results value code :lexical t")
+ ("sg" . "src go")
+ ("sr" . "src rust")
+ ("sp" . "src python")
+ ("v" . "verse"))))
;; (use-package org-bullets
;; :if (not window-system)
@@ -137,8 +165,15 @@
;; Using denote as the "source" of my second brain *in* org-mode.
(use-package denote
- :commands (denote denote-date denote-link-or-create denote-open-or-create denote-signature)
- :after org)
+ :after org
+ :custom
+ (denote-directory org-directory)
+ (denote-rename-buffer-format "📝 %t")
+ :config
+ (denote-rename-buffer-mode 1)
+ (require 'denote-journal-extras)
+ (setq denote-journal-extras-directory (expand-file-name "journal" org-directory)
+ denote-journal-extras-title-format 'day-date-month-year))
;; (use-package org
;; ;; :ensure org-plus-contrib ;; load from the package instead of internal
diff --git a/tools/emacs/lisp/denote-journal-extras.el b/tools/emacs/lisp/denote-journal-extras.el
@@ -0,0 +1,213 @@
+;;; denote-journal-extras.el --- Convenience functions for daily journaling -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;; Author: Protesilaos Stavrou <info@protesilaos.com>
+;; Maintainer: Denote Development <~protesilaos/denote@lists.sr.ht>
+;; URL: https://git.sr.ht/~protesilaos/denote
+;; Mailing-List: https://lists.sr.ht/~protesilaos/denote
+
+;; This file is NOT part of GNU Emacs.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This is a set of optional convenience functions that used to be
+;; provided in the Denote manual. They facilitate the use of Denote
+;; for daily journaling.
+
+;;; Code:
+
+(require 'denote)
+
+(defgroup denote-journal-extras nil
+ "Denote for daily journaling."
+ :group 'denote
+ :link '(info-link "(denote) Top")
+ :link '(url-link :tag "Homepage" "https://protesilaos.com/emacs/denote"))
+
+(defcustom denote-journal-extras-directory
+ (expand-file-name "journal" denote-directory)
+ "Directory for storing daily journal entries.
+This can either be the same as the variable `denote-directory' or
+a subdirectory of it.
+
+A value of nil means to use the variable `denote-directory'.
+Journal entries will thus be in a flat listing together with all
+other notes. They can still be retrieved easily by searching for
+the `denote-journal-extras-keyword'."
+ :group 'denote-journal-extras
+ :type '(choice (directory :tag "Provide directory path (is created if missing)")
+ (const :tag "Use the `denote-directory'" nil)))
+
+(defcustom denote-journal-extras-keyword "journal"
+ "Single word keyword to tag journal entries.
+It is used by `denote-journal-extras-new-entry' to add a keyword
+to the newly created file."
+ :group 'denote-journal-extras
+ :type 'string)
+
+(defcustom denote-journal-extras-title-format 'day-date-month-year-24h
+ "Date format to construct the title with `denote-journal-extras-new-entry'.
+The value is either a symbol or an arbitrary string that is
+passed to `format-time-string' (consult its documentation for the
+technicalities).
+
+Acceptable symbols and their corresponding styles are:
+
+| Symbol | Style |
+|-------------------------+-----------------------------------|
+| day | Monday |
+| day-date-month-year | Monday 19 September 2023 |
+| day-date-month-year-24h | Monday 19 September 2023 20:49 |
+| day-date-month-year-12h | Monday 19 September 2023 08:49 PM |
+
+With a nil value, make `denote-journal-extras-new-entry' prompt
+for a title."
+ :group 'denote-journal-extras
+ :type '(choice
+ (const :tag "Prompt for title with `denote-journal-extras-new-entry'" nil)
+ (const :tag "Monday"
+ :doc "The `format-time-string' is: %A"
+ day)
+ (const :tag "Monday 19 September 2023"
+ :doc "The `format-time-string' is: %A %e %B %Y"
+ day-date-month-year)
+ (const :tag "Monday 19 September 2023 20:49"
+ :doc "The `format-time-string' is: %A %e %B %Y %H:%M"
+ day-date-month-year-24h)
+ (const :tag "Monday 19 September 2023 08:49 PM"
+ :doc "The `format-time-string' is: %A %e %B %Y %I:%M %^p"
+ day-date-month-year-12h)
+ (string :tag "Custom string with `format-time-string' specifiers")))
+
+(defcustom denote-journal-extras-hook nil
+ "Normal hook called after `denote-journal-extras-new-entry'.
+Use this to, for example, set a timer after starting a new
+journal entry (refer to the `tmr' package on GNU ELPA)."
+ :group 'denote-journal-extras
+ :type 'hook)
+
+(defun denote-journal-extras-directory ()
+ "Make the variable `denote-journal-extras-directory' and its parents."
+ (when-let (((stringp denote-journal-extras-directory))
+ (directory (file-name-as-directory (expand-file-name denote-journal-extras-directory))))
+ (when (not (file-directory-p denote-journal-extras-directory))
+ (make-directory directory :parents))
+ directory))
+
+(defun denote-journal-extras-daily--title-format (&optional date)
+ "Return present date in `denote-journal-extras-title-format' or prompt for title.
+With optional DATE, use it instead of the present date. DATE has
+the same format as that returned by `current-time'."
+ (format-time-string
+ (if (and denote-journal-extras-title-format
+ (stringp denote-journal-extras-title-format))
+ denote-journal-extras-title-format
+ (pcase denote-journal-extras-title-format
+ ('day "%A")
+ ('day-date-month-year "%A %e %B %Y")
+ ('day-date-month-year-24h "%A %e %B %Y %H:%M")
+ ('day-date-month-year-12h "%A %e %B %Y %I:%M %^p")
+ (_ (denote-title-prompt (format-time-string "%F" date)))))
+ date))
+
+(defun denote-journal-extras--get-template ()
+ "Return template that has `journal' key in `denote-templates'.
+If no template with `journal' key exists but `denote-templates'
+is non-nil, prompt the user for a template among
+`denote-templates'. Else return nil.
+
+Also see `denote-journal-extras-new-entry'."
+ (if-let ((template (alist-get 'journal denote-templates)))
+ template
+ (when denote-templates
+ (denote-template-prompt))))
+
+(defun denote-journal-extras--get-date (date)
+ "Return a valid DATE for `format-time-string'.
+If DATE is a list, return it as-is. If it is a string, parse it
+with `denote--valid-date'. Else return the `current-time'."
+ (cond
+ ((listp date) date)
+ ((stringp date) (denote--valid-date date))
+ (t (current-time))))
+
+;;;###autoload
+(defun denote-journal-extras-new-entry (&optional date)
+ "Create a new journal entry in variable `denote-journal-extras-directory'.
+Use `denote-journal-extras-keyword' as a keyword for the newly
+created file. Set the title of the new entry according to the
+value of the user option `denote-journal-extras-title-format'.
+
+With optional DATE as a prefix argument, prompt for a date. If
+`denote-date-prompt-use-org-read-date' is non-nil, use the Org
+date selection module.
+
+When called from Lisp DATE is a string and has the same format as
+that covered in the documentation of the `denote' function. It
+is internally processed by `denote-journal-extras--get-date'."
+ (interactive (list (when current-prefix-arg (denote-date-prompt))))
+ (let ((internal-date (denote-journal-extras--get-date date))
+ (denote-user-enforced-denote-directory (denote-journal-extras-directory)))
+ (denote
+ (denote-journal-extras-daily--title-format internal-date)
+ `(,denote-journal-extras-keyword)
+ nil nil date
+ (denote-journal-extras--get-template))
+ (run-hooks 'denote-journal-extras-hook)))
+
+(defun denote-journal-extras--entry-today (&optional date)
+ "Return list of files matching a journal for today or optional DATE.
+DATE has the same format as that returned by `denote-journal-extras--get-date'."
+ (denote-directory-files-matching-regexp
+ (format "%sT[0-9]\\{6\\}.*_%s"
+ (format-time-string "%Y%m%d" date)
+ denote-journal-extras-keyword)))
+
+;;;###autoload
+(defun denote-journal-extras-new-or-existing-entry (&optional date)
+ "Locate an existing journal entry or create a new one.
+A journal entry is one that has `denote-journal-extras-keyword' as
+part of its file name.
+
+If there are multiple journal entries for the current date,
+prompt for one using minibuffer completion. If there is only
+one, visit it outright. If there is no journal entry, create one
+by calling `denote-journal-extra-new-entry'.
+
+With optional DATE as a prefix argument, prompt for a date. If
+`denote-date-prompt-use-org-read-date' is non-nil, use the Org
+date selection module.
+
+When called from Lisp, DATE is a string and has the same format
+as that covered in the documentation of the `denote' function.
+It is internally processed by `denote-journal-extras--get-date'."
+ (interactive
+ (list
+ (when current-prefix-arg
+ (denote-date-prompt))))
+ (let* ((internal-date (denote-journal-extras--get-date date))
+ (files (denote-journal-extras--entry-today internal-date)))
+ (cond
+ ((length> files 1)
+ (find-file (completing-read "Select journal entry: " files nil :require-match)))
+ (files
+ (find-file (car files)))
+ (t
+ (denote-journal-extras-new-entry date)))))
+
+(provide 'denote-journal-extras)
+;;; denote-journal-extras.el ends here
diff --git a/tools/emacs/lisp/org-extra-emphasis.el b/tools/emacs/lisp/org-extra-emphasis.el
@@ -0,0 +1,805 @@
+;;; org-extra-emphasis.el --- Extra Emphasis markers for Org -*- lexical-binding: t; coding: utf-8-emacs; -*-
+
+;; Copyright (C) 2022 Jambunathan K <kjambunathan at gmail dot com>
+;; Copyright (C) 2004-2022 Free Software Foundation, Inc.
+
+;; Author: Jambunathan K <kjambunathan at gmail dot com>
+;; Keywords: org
+;; Homepage: https://github.com/kjambunathan/org-extra-emphasis
+;; Version: 1.0
+;; Package-Requires: ((ox-odt "9.5.3.467"))
+
+;; This file is NOT part of GNU Emacs.
+
+;; This program is free software: you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Overview
+;; ========
+;;
+;; This library provides two additional markers `!!' and `!@' over
+;; and above those in `org-emphasis-alist'.'
+;;
+;; - Text enclosed in `!!' is highlighted in yellow, and exported likewise
+;; - Text enclosed in `!@' is displayed in red, and exported likewise
+;;
+;; Following backends are supported: HTML and ODT. For export of extra
+;; emphasis markers to the ODT side, you need
+;; [[https://github.com/kjambunathan/org-mode-ox-odt][Enhanced ODT]]
+;; exporter with version >= 9.5.3.467 (dtd. June 14, 2022 IST). This
+;; is the first version of the exporter that defines the user option
+;; `org-odt-extra-styles'.
+;;
+;; Example
+;; =======
+;;
+;; Setup
+;; =====
+;;
+;; Add the following to your `user-init-file' and restart Emacs.
+;;
+;; (requrie 'org-extra-emphasis)
+;;
+;; Test Run
+;; ========
+;;
+;; 1. Create an `org' file, say `org-export-emphasis.org' and fill it
+;; with following content or you can download the file from
+;; https://raw.githubusercontent.com/kjambunathan/org-extra-emphasis/main/org-extra-emphasis.org
+
+ ;; #+TITLE: Test file for ==org-extra-emphasis== library
+
+ ;; * Demo of extra emphasis markers ==!!== and ==!@==
+
+ ;; !!Ea consectetur laboris adipiscing et ipsum labore esse qui minim
+ ;; pariatur et sunt sunt nostrud anim laborum culpa.!!
+
+ ;; !@Minim reprehenderit excepteur elit, dolore elit, veniam, eu.
+ ;; Ullamco dolore elit, cupidatat sed labore ea aute.!@
+
+ ;; Pariatur !!et lorem cupidatat !@minim irure!@ proident, ad.!! Eiusmod
+ ;; sunt et lorem labore ex aliqua aute esse.
+
+ ;; Ut mollit !@duis velit est est magna in quis ipsum. !!Aliqua aliqua
+ ;; non laboris exercitation cupidatat aliqua incididunt.!! Qui voluptate
+ ;; irure aute occaecat laborum cillum est.!@ Quis magna dolor ullamco
+ ;; magna do consectetur est laborum enim ut.
+
+ ;; * !!Demo of extra emphasis markers in a styled paragraph!!
+
+ ;; #+ATTR_ODT: :target "extra_styles"
+ ;; #+begin_src nxml
+ ;; <style:style style:name="Warn"
+ ;; style:parent-style-name="Text_20_body"
+ ;; style:family="paragraph">
+ ;; <style:paragraph-properties>
+ ;; <style:tab-stops />
+ ;; </style:paragraph-properties>
+ ;; <style:text-properties fo:background-color="#ff0000"
+ ;; fo:color="#ffffff"
+ ;; fo:font-size="20pt"
+ ;; fo:font-style="italic"
+ ;; fo:font-weight="bold" />
+ ;; </style:style>
+ ;; #+end_src
+
+ ;; #+ATTR_ODT: :style "Warn"
+ ;; Proident, duis dolore consectetur sed nisi ea pariatur. Esse
+ ;; proident, cillum duis qui ullamco sint cillum magna. !!Eiusmod
+ ;; veniam, !@sint officia!@ non consectetur laboris cillum.!! Cillum
+ ;; mollit consequat eu dolore ullamco qui reprehenderit anim cillum
+ ;; in consectetur consequat sunt dolore aliquip voluptate
+ ;; consectetur anim ea. Voluptate nisi est incididunt aliquip
+ ;; excepteur aliqua id do enim ut non consequat.
+;;
+;; 2. Note that portions of text marked with `!!' and `!@' are fontified as described above.
+;;
+;; 3. Export the file to HTML with `C-c C-e h O'.
+;;
+;; Note that the text enclosed in the above emphasis markers are
+;; colorized in HTML file.
+;;
+;; 4. Export the file to ODT with `C-c C-e o O'.
+;;
+;; Note that the text enclosed in the above emphasis markers are
+;; colorized in ODT file.
+;;
+;; The HTML, ODT, PDF generated in steps (3) and (4) above are
+;; available at https://github.com/kjambunathan/org-extra-emphasis and
+;; the screenshots can be seen in https://github.com/kjambunathan/org-extra-emphasis/tree/main/screenshots
+;;
+
+;; Default Settings
+;; ================
+;;
+;; 16 Emphasis Markers
+;; ===================
+;;
+;; This library defines the following 16 emphasis markers,
+;;
+;; |----+----+----+----|
+;; | !! | !@ | !% | !& |
+;; |----+----+----+----|
+;; | @! | @@ | @% | @& |
+;; |----+----+----+----|
+;; | %! | %@ | %% | %& |
+;; |----+----+----+----|
+;; | &! | &@ | &% | && |
+;; |----+----+----+----|
+;;
+;; The above markers are all pairings of the following four characters:
+;; ! @ % &
+;;
+;; It is hoped that these set of emphasis markers don't pose issues
+;; while exporting.
+;;
+;; 17 Extra Emphasis Faces
+;; =======================
+;;
+;; This library defines 17 faces:
+;;
+;; - one base face `org-extra-emphasis'
+;; - 16 more faces `org-extra-emphasis-01',`org-extra-emphasis-02',
+;; ..., `org-extra-emphasis-16'.
+;;
+;; The later 16 faces derive from `org-extra-emphasis' face. Of
+;; these, only the first two faces `org-extra-emphasis-01' and
+;; `org-extra-emphasis-02' are explicitly configured. If you are
+;; using more than 2 emphasis markers, you may want to configure the
+;; other 14 faces.
+;;
+;; `org-extra-emphasis-alist' already associated 16 emphasis markers
+;; with 16 different faces.
+;;
+;; Customization
+;; =============
+;;
+;; Configuring your own Emphasis Markers
+;; =====================================
+;;
+;; 16 numbers of emphasis markers should suffice in practice.
+;; However, if none of the above emphasis markers resonate with you,
+;; you can customize `org-extra-emphasis-alist', and plug in your own
+;; markers. When choosing your own marker, ensure that you exercise
+;; some care. For example, if you choose `#' as a marker you are
+;; likely to get malformed `html' and `odt' files.
+;;
+;; Configuring Extra Emphasis Faces
+;; ===============================
+;;
+;; You can use `M-x customize-group RET org-extra-emphasis-faces RET'
+;; to configure the extra emphasis faces.
+;;
+;; Disabling the Extra Emphasis
+;; =============================
+;;
+;; You can use `M-x org-extra-emphasis-mode' to toggle this feature.
+;;
+;; Adding additional export backends
+;; =================================
+;;
+;; To add additional backends, modify `org-extra-emphasis-formatter'
+;; and `org-extra-emphasis-build-backend-regexp'.
+
+;;; Code:
+
+(require 'org)
+(require 'ox-odt)
+(require 'rx)
+(require 'htmlfontify)
+
+;;; PART-1: `org-extra-emphasis-mode'
+
+;;;; Internal Variables
+
+(defvar org-extra-emphasis-backends
+ '(html odt ods))
+
+(defvar org-extra-emphasis-info
+ (list :enabled nil))
+
+;; Helper snippets to convert a Emacs Face to Inine CSS and ODT Text Properties
+;;
+;; (defun org-extra-emphasis-emacs-face->inline-css (face)
+;; (let ((s (cdr (hfy-face-to-css-default face))))
+;; (when (string-match (rx-to-string '(and "{" (group (zero-or-more any)) "}")) s)
+;; (format "<span style=\"%s\">%%s</span>" (match-string 1 s)))))
+;;
+;; (org-extra-emphasis-emacs-face->inline-css 'hi-yellow)
+;; (org-extra-emphasis-emacs-face->inline-css 'hi-red-b)
+;;
+;; (defun org-extra-emphasis-emacs-face->odt-text-properties (face)
+;; (org-odt--lisp-to-xml
+;; (assoc 'style:text-properties
+;; (org-odt--xml-to-lisp
+;; (cdr (org-odt-hfy-face-to-css face))))))
+;;
+;; (org-extra-emphasis-emacs-face->odt-text-properties 'hi-yellow)
+;; (org-extra-emphasis-emacs-face->odt-text-properties 'hi-red-b)
+
+(defun org-extra-emphasis-update (&rest _ignored)
+ "Workhorse function that responds to configuration changes.
+
+Current state is maintined in `org-extra-emphasis-info', a plist."
+ ;; When `org-extra-emaphasis' is ON, override use
+ ;; `org-extra-emphasis-org-do-emphasis-faces'.
+ ;; Otherwise, use `org-do-emphasis-faces'.
+ (cond
+ ((plist-get org-extra-emphasis-info :enabled)
+ (advice-add 'org-do-emphasis-faces :override
+ 'org-extra-emphasis-org-do-emphasis-faces))
+ (t
+ (advice-remove 'org-do-emphasis-faces
+ 'org-extra-emphasis-org-do-emphasis-faces)))
+ ;; `org-extra-emphasis-alist' is effective only if
+ ;; `org-extra-emphasis' is enabled.
+ (plist-put org-extra-emphasis-info :work-alist
+ (when (plist-get org-extra-emphasis-info :enabled)
+ (plist-get org-extra-emphasis-info :alist)))
+ ;; Set properties that control fontification.
+ ;; The property names and their values mimics the corresponding
+ ;; variables in `org-set-emph-re'.
+ (plist-put org-extra-emphasis-info :org-emphasis-alist
+ (when (and (boundp 'org-emphasis-regexp-components)
+ org-emphasis-alist org-emphasis-regexp-components)
+ (append (plist-get org-extra-emphasis-info :work-alist)
+ org-emphasis-alist)))
+ (plist-put org-extra-emphasis-info :org-emph-re-template
+ (when (and (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))))
+ (format (concat "\\([%s]\\|^\\)" ;before markers
+ "\\(\\(%%s\\)\\([^%s]\\|[^%s]%s[^%s]\\)\\3\\)"
+ "\\([%s]\\|$\\)") ;after markers
+ pre border border body border post))))
+ (plist-put org-extra-emphasis-info :org-emph-re
+ (format (plist-get org-extra-emphasis-info :org-emph-re-template)
+ (rx-to-string
+ `(or ,@(mapcar #'car
+ (cl-remove-if (lambda (l)
+ (eq 'verbatim (nth 2 l)))
+ (plist-get org-extra-emphasis-info :org-emphasis-alist)))))))
+ (plist-put org-extra-emphasis-info :org-verbatim-re
+ (format (plist-get org-extra-emphasis-info :org-emph-re-template)
+ (rx-to-string
+ `(or ,@(mapcar #'car
+ (cl-remove-if-not (lambda (l)
+ (eq 'verbatim (nth 2 l)))
+ (plist-get org-extra-emphasis-info :org-emphasis-alist)))))
+ (rx-to-string
+ `(or ,@(mapcar #'car
+ (cl-remove-if-not (lambda (l)
+ (eq 'verbatim (nth 2 l)))
+ (plist-get org-extra-emphasis-info :org-emphasis-alist)))))))
+ ;; Set properties that control Export backends
+ ;; - Regexp to search for in the final exported document
+ (plist-put org-extra-emphasis-info :export-alist
+ (org-extra-emphasis-build-backend-regexp))
+
+ ;; - Generate ODT character styles for the extra emphasis faces and
+ ;; dump those in `org-odt-extra-styles' and `org-ods-automatic-styles'.
+ (plist-put org-extra-emphasis-info :odt-extra-styles
+ (let* ((odt-styles
+ (concat (mapconcat #'identity
+ (cl-loop for (_marker face) in (plist-get org-extra-emphasis-info :alist)
+ collect (cdr (org-odt-hfy-face-to-css face)))
+ "\n\n"))))
+ (with-no-warnings
+ (unless (boundp 'org-odt-extra-styles)
+ (message "`org-odt-extra-styles' not found. Upgrade to `ox-odt-9.5.3.467' or later.")
+ ;; (sleep-for 2)
+ (setq org-odt-extra-styles nil))
+ (setq org-odt-extra-styles
+ (concat (or (when (boundp 'org-odt-extra-styles)
+ (get 'org-odt-extra-styles 'saved-value))
+ "")
+ "\n\n"
+ odt-styles))
+ (setq org-ods-automatic-styles
+ (concat (or (when (boundp 'org-ods-automatic-styles)
+ (get 'org-ods-automatic-styles 'saved-value))
+ "")
+ "\n\n"
+ odt-styles))
+ (message "`org-odt-extra-styles' and `org-ods-automatic-styles' is updated for this session")
+ ;; (sleep-for 1)
+ )
+ odt-styles))
+ ;; Re-fontify all Org buffers based on current configuration.
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (when (derived-mode-p 'org-mode)
+ (font-lock-flush)))))
+
+;;;; Fontify Extra Emphasis Markers
+
+(defun org-extra-emphasis-org-do-emphasis-faces (limit)
+ "Workhorse function that does fontification This function is
+based on `org-do-emphasis-faces'. The property names and values
+correspond to the variables used in `org-do-emphasis-faces'. Key
+differences are:
+
+ - `:org-emphasis-alist' includes entries for both standard
+ emphasis markers and extra emphasis markers.
+
+ - The regexes used for search-based fontification allow for
+ the possibility that the emphasis markers _in all
+ likelihood_ are multi-char strings, as opposed to single
+ chars."
+ (let* ((quick-re (format "\\([%s]\\|^\\)\\(%s\\)"
+ (car org-emphasis-regexp-components)
+ (rx-to-string
+ `(or ,@(mapcar #'car (plist-get org-extra-emphasis-info :org-emphasis-alist)))))))
+ (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? (plist-get org-extra-emphasis-info :org-verbatim-re)
+ (plist-get org-extra-emphasis-info :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 (plist-get org-extra-emphasis-info :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))
+ (add-text-properties (match-beginning 3) (match-end 3)
+ '(invisible t)))
+ (throw :exit t))))))))
+
+;; There is no `:set' function for `deffaces'. So, when the extra
+;; faces `org-extra-emphasis-01', `org-extra-emphasis-02' reconfigured,
+;; we don't get a notification. The following export hook ensures
+;; that `org-extra-emphasis-info' is in sync with user configuration.
+(add-hook 'org-export-before-processing-hook 'org-extra-emphasis-update)
+
+;;;; Export Extra Emphasis Markers
+
+(defun org-extra-emphasis-formatter (marker text backend)
+ "Style TEXT in the same font face as the face MARKER is mapped to.
+Note that TEXT is in BACKEND format.
+
+This currently supports HTML and ODT backends.
+
+See `org-extra-emphasis-alist' for MARKER to face mappings."
+ (let* ((face (car (assoc-default marker (plist-get org-extra-emphasis-info :work-alist))))
+ (encode-attribute-value
+ (lambda (text)
+ (dolist (pair '(("&" . "&")
+ ("<" . "<")
+ (">" . ">")
+ ("'" . "'")
+ ("\"" . """)))
+ (setq text (replace-regexp-in-string (car pair) (cdr pair) text t t)))
+ text)))
+ (cl-case backend
+ ((odt ods)
+ (format "<text:span text:style-name=\"%s\">%s</text:span>"
+ (car (org-odt-hfy-face-to-css face)) text))
+ (html
+ (format "<span class=\"%s\" style=\"%s\">%s</span>"
+ face
+ ;; An alternate implementation of
+ ;; `hfy-face-to-css-default' which performs correctly
+ ;; when a face specifies a `:family', and/or inherits
+ ;; some attributes from other faces. Note that the
+ ;; flattening (or non-duplication) of face attributes
+ ;; here is done by Emacs itself.
+ (mapconcat (lambda (x)
+ (when (cdr x)
+ (format "%s: %s;" (car x)
+ (funcall encode-attribute-value (cdr x)))))
+ (hfy-face-to-style-i
+ (cl-loop with props = (mapcar #'car face-attribute-name-alist)
+ for prop in props
+ for value = (face-attribute face prop nil 'default)
+ unless (eq prop :inherit)
+ append (list prop value)))
+ " ")
+ text))
+ (_ text))))
+
+(defun org-extra-emphasis-build-backend-regexp ()
+ "Regexp to search for emphasized text in exported file.
+This function transcode an emphasis MARKER which is in plain text
+format, to the BACKEND format. That is, if you use `<<' as an
+emphasis marker, you need to search for `<<' in the
+exported HTML file.
+
+See `org-extra-emphasis-alist' for more information"
+ (cl-loop for (marker . spec) in (plist-get org-extra-emphasis-info :work-alist) collect
+ (cons marker
+ (cl-loop for backend in org-extra-emphasis-backends collect
+ (cons backend
+ (rx-to-string `(and ,(org-export-data-with-backend marker backend nil)
+ (group (minimal-match
+ (zero-or-more (or any "\n"))))
+ ,(org-export-data-with-backend marker backend nil))))))))
+
+(defun org-extra-emphasis-plain-text-filter (text backend _info)
+ "Transcode TEXT in to BACKEND format.
+Uses `org-extra-emphasis-formatter' to do the transcoding.
+
+Search TEXT for one or more transcoded MARKERs, and mark it up as
+specified in `org-extra-emphasis-alist'."
+ (with-temp-buffer
+ (insert text)
+ (cl-loop for (marker . spec) in (plist-get org-extra-emphasis-info :export-alist)
+ for regex = (assoc-default backend spec)
+ do (goto-char (point-min))
+ (if (not regex) text
+ (while (re-search-forward regex nil t)
+ (let* ((contents (match-string 1))
+ (emphasized-contents (save-match-data
+ (org-extra-emphasis-formatter
+ marker contents backend))))
+ (replace-match emphasized-contents t t)))))
+ (buffer-substring-no-properties (point-min) (point-max))))
+
+;; Install export filter for transcoding extra emphasis markers.
+(defun org-extra-emphasis-update-filter-functions (&optional export-filter-functions)
+ (let* ((all-filter-functions (thread-last org-export-filters-alist
+ (seq-map #'cdr)
+ (seq-sort #'string<))))
+ (dolist (filter-fn '(org-extra-emphasis-plain-text-filter org-extra-emphasis-strip-zws-maybe))
+ (dolist (it all-filter-functions)
+ (set it (delq filter-fn (symbol-value it))))
+ (dolist (it export-filter-functions)
+ (add-to-list it filter-fn)))))
+
+;;;; User Options & Commands
+
+;;;;; Custom Groups
+
+(defgroup org-extra-emphasis nil
+ "Options for highlighting and exporting extra emphasis markers in Org files."
+ :tag "Org Extra Emphasis"
+ :group 'org)
+
+(defgroup org-extra-emphasis-faces nil
+ "Faces for Org Extra Emphasis."
+ :group 'org-extra-emphasis
+ :group 'faces)
+
+;;;; Custom Faces
+
+(defface org-extra-emphasis nil
+ "A face for Org Extra Emphasis."
+ :group 'org-extra-emphasis-faces)
+
+(defface org-extra-emphasis-01
+ '((t (:inherit org-extra-emphasis :background "yellow")))
+ "A face for Org Extra Emphasis."
+ :group 'org-extra-emphasis-faces)
+
+(defface org-extra-emphasis-02
+ '((t (:inherit org-extra-emphasis :foreground "red")))
+ "A face for Org Extra Emphasis."
+ :group 'org-extra-emphasis-faces)
+
+(defface org-extra-emphasis-03
+ '((t (:inherit org-extra-emphasis)))
+ "A face for Org Extra Emphasis."
+ :group 'org-extra-emphasis-faces)
+
+(defface org-extra-emphasis-04
+ '((t (:inherit org-extra-emphasis)))
+ "A face for Org Extra Emphasis."
+ :group 'org-extra-emphasis-faces)
+
+(defface org-extra-emphasis-05
+ '((t (:inherit org-extra-emphasis)))
+ "A face for Org Extra Emphasis."
+ :group 'org-extra-emphasis-faces)
+
+(defface org-extra-emphasis-06
+ '((t (:inherit org-extra-emphasis)))
+ "A face for Org Extra Emphasis."
+ :group 'org-extra-emphasis-faces)
+
+(defface org-extra-emphasis-07
+ '((t (:inherit org-extra-emphasis)))
+ "A face for Org Extra Emphasis."
+ :group 'org-extra-emphasis-faces)
+
+(defface org-extra-emphasis-08
+ '((t (:inherit org-extra-emphasis)))
+ "A face for Org Extra Emphasis."
+ :group 'org-extra-emphasis-faces)
+
+(defface org-extra-emphasis-09
+ '((t (:inherit org-extra-emphasis)))
+ "A face for Org Extra Emphasis."
+ :group 'org-extra-emphasis-faces)
+
+(defface org-extra-emphasis-10
+ '((t (:inherit org-extra-emphasis)))
+ "A face for Org Extra Emphasis."
+ :group 'org-extra-emphasis-faces)
+
+(defface org-extra-emphasis-11
+ '((t (:inherit org-extra-emphasis)))
+ "A face for Org Extra Emphasis."
+ :group 'org-extra-emphasis-faces)
+
+(defface org-extra-emphasis-12
+ '((t (:inherit org-extra-emphasis)))
+ "A face for Org Extra Emphasis."
+ :group 'org-extra-emphasis-faces)
+
+(defface org-extra-emphasis-13
+ '((t (:inherit org-extra-emphasis)))
+ "A face for Org Extra Emphasis."
+ :group 'org-extra-emphasis-faces)
+
+(defface org-extra-emphasis-14
+ '((t (:inherit org-extra-emphasis)))
+ "A face for Org Extra Emphasis."
+ :group 'org-extra-emphasis-faces)
+
+(defface org-extra-emphasis-15
+ '((t (:inherit org-extra-emphasis)))
+ "A face for Org Extra Emphasis."
+ :group 'org-extra-emphasis-faces)
+
+(defface org-extra-emphasis-16
+ '((t (:inherit org-extra-emphasis)))
+ "A face for Org Extra Emphasis."
+ :group 'org-extra-emphasis-faces)
+
+;;;;; Useful Org Setting
+
+(setcar (last org-emphasis-regexp-components) 5)
+
+(defcustom org-extra-emphasis-alist
+ '(("!!" org-extra-emphasis-01)
+ ("!@" org-extra-emphasis-02)
+ ("!%" org-extra-emphasis-03)
+ ("!&" org-extra-emphasis-04)
+ ("@!" org-extra-emphasis-05)
+ ("@@" org-extra-emphasis-06)
+ ("@%" org-extra-emphasis-07)
+ ("@&" org-extra-emphasis-08)
+ ("%!" org-extra-emphasis-09)
+ ("%@" org-extra-emphasis-10)
+ ("%%" org-extra-emphasis-11)
+ ("%&" org-extra-emphasis-12)
+ ("&!" org-extra-emphasis-13)
+ ("&@" org-extra-emphasis-14)
+ ("&%" org-extra-emphasis-15)
+ ("&&" org-extra-emphasis-16))
+ "Alist of emphasis marker and its associated face."
+ :group 'org-extra-emphasis
+ :type '(repeat
+ (list
+ (string :tag "Emphasis Marker")
+ (face :tag "Face")))
+ :set (lambda (var val)
+ (set var val)
+ (plist-put org-extra-emphasis-info :alist val)
+ (org-extra-emphasis-update)))
+
+(defcustom org-extra-emphasis t
+ "When non-nil, enable Org Extra Emphasis."
+ :group 'org-extra-emphasis
+ :type '(boolean "Org Extra Emphasis")
+ :set (lambda (var val)
+ (set var val)
+ (plist-put org-extra-emphasis-info :enabled val)
+ (org-extra-emphasis-update)))
+
+(defcustom org-extra-emphasis-filter-functions
+ '(
+ org-export-filter-headline-functions
+ org-export-filter-paragraph-functions
+ org-export-filter-table-cell-functions
+ )
+ "List of places to which `org-extra-emphasis-plain-text-filter'
+and `org-extra-emphasis-strip-zws-maybe' hooks itself.
+
+The places should be one among the values that occur in
+`org-export-filters-alist'.
+
+By default, the list includes
+ - `org-export-filter-headline-functions'
+ - `org-export-filter-paragraph-functions'
+ - `org-export-filter-table-cell-functions',
+
+This means that text with extra emphasis which appears as plain
+text, or within headlines and table cells will be, fontified."
+ :group 'org-extra-emphasis
+ :type `(set
+ ,@(thread-last org-export-filters-alist
+ (seq-map #'cdr)
+ (seq-sort #'string<)
+ (seq-map (lambda (it)
+ (list 'const it)))))
+ :set (lambda (var value)
+ (set-default var value)
+ (org-extra-emphasis-update-filter-functions value)))
+
+;;;;; `M-x org-extra-emphasis-mode'
+
+(defun org-extra-emphasis-mode (&optional arg)
+ "Enable / Disable Org Extra Emphasis.
+
+If called interactively, toggle Extra Emphasis.
+
+When called non-interactively, enable Extra Emphasis if ARG is
+positive; disable otherwise."
+ (interactive "p")
+ (cond
+ ;; Called interactively; Toggle
+ ((called-interactively-p 'any)
+ (setq org-extra-emphasis (not org-extra-emphasis)))
+ ;; Called programatically; enable if arg >= 1
+ ((and (numberp arg)
+ (>= arg 1))
+ (setq org-extra-emphasis t))
+ ;; Otherwise, disable
+ (t
+ (setq org-extra-emphasis nil)))
+ (plist-put org-extra-emphasis-info :enabled org-extra-emphasis)
+ (org-extra-emphasis-update))
+
+;;; PART-2: `org-extra-emphasis-intraword-emphasis-mode'
+
+;;;; User options
+
+(defface org-extra-emphasis-zws-face
+ '((t (:inherit org-extra-emphasis :foreground "red")))
+ "Use this face to highlight the ZERO WIDTH SPACE character."
+ :group 'org-extra-emphasis-faces)
+
+(defcustom org-extra-emphasis-zws-display-char ?\N{SPACING UNDERSCORE}
+ "Use the glyph of this character to display ZERO WIDTH SPACE.
+
+Set this to nil, if you want the ZERO WIDTH SPACE to remain
+inconspicuous in the buffer. Note that even if ZERO WIDTH SPACE
+is inconspicuos in the buffer, the ZERO WIDTH SPACE will be
+stripped from the export output accoding to the value of
+`org-extra-emphasis-intraword-emphasis-mode'."
+ :type '(choice (const :tag "Disabled" nil)
+ (character :tag "Display ZERO WIDTH SPACE as "))
+ :group 'org-extra-emphasis)
+
+;;;; Internal Variables
+
+(defvar-local org-extra-emphasis-stashed-display-table nil
+ "Stashed value of `buffer-display-table'.
+
+This is the value of `buffer-display-table' before
+`org-extra-emphasis-intraword-emphasis-mode' is turned on in the
+buffer.
+
+Use this value to restore a buffer's `buffer-display-table' when
+`org-extra-emphasis-intraword-emphasis-mode' is turned off in the
+buffer.")
+
+;;;; `M-x org-extra-emphasis-intraword-emphasis-mode'
+
+;;;###autoload
+(define-minor-mode org-extra-emphasis-intraword-emphasis-mode
+ "Toggle intra word emphasis in `org-mode' export.
+
+When `org-extra-emphasis-intraword-emphasis-mode' is enabled:
+
+- ZERO WIDTH SPACE characters are stripped from export backends.
+- ZERO WIDTH SPACE characters are displayed using
+ `org-extra-emphasis-zws-display-char' and highlighted with
+ `org-extra-emphasis-zws-face' space.
+
+TIPS for the user:
+
+1. You can insert ZERO WIDTH SPACE using
+
+ `M-x insert-char RET ZERO WIDTH SPACE RET'
+
+ One another way is to store that the ZERO WIDTH SPACE in a
+ register, say SPC, and
+
+ (set-register ?\N{SPACE} \"\N{ZERO WIDTH SPACE}\")
+
+ and use the \\[insert-register] command on that register to insert
+ the ZERO WIDTH SPACE character.
+
+2. You can examine the presence of ZERO WIDTH SPACE character in the
+ export output by turning on the `glyphless-display-mode'."
+ :lighter " ZWS"
+ :init-value nil
+ :global t
+ :group 'org-extra-emphasis
+ (cond
+ ;; Turn ON `org-extra-emphasis-intraword-emphasis-mode'
+ (org-extra-emphasis-intraword-emphasis-mode
+ (when org-extra-emphasis-zws-display-char
+ ;; Display ZERO WIDTH CHAR in a conspicuous way.
+ (setq org-extra-emphasis-stashed-display-table (copy-sequence buffer-display-table))
+ (unless buffer-display-table
+ (setq buffer-display-table (make-display-table)))
+ (aset buffer-display-table
+ ?\N{ZERO WIDTH SPACE}
+ (vector (make-glyph-code org-extra-emphasis-zws-display-char
+ 'org-extra-emphasis-zws-face)))))
+ (t
+ ;; Turn OFF `org-extra-emphasis-intraword-emphasis-mode'
+ (when org-extra-emphasis-zws-display-char
+ ;; Restore the buffer's original `buffer-display-table'.
+ (setq buffer-display-table org-extra-emphasis-stashed-display-table)))))
+
+;; Adjust `buffer-display-table' so that ZERO WIDTH SPACE characters
+;; are displayed.
+(add-hook 'org-mode-hook 'org-extra-emphasis-intraword-emphasis-mode t)
+
+;;;; Export hook to strip ZERO WIDTH SPACE
+
+(defun org-extra-emphasis-strip-zws-maybe (text _backend _info)
+ "Strip ZERO WIDTH SPACE from TEXT.
+
+If `org-extra-emphasis-intraword-emphasis-mode' is enabled, strip
+ZERO WIDTH SPACE from TEXT. Otherwise, return TEXT unmodified."
+ (cond
+ ;; `org-extra-emphasis-intraword-emphasis-mode' is ON
+ (org-extra-emphasis-intraword-emphasis-mode
+ ;; Strip ZERO WIDTH SPACE.
+ (replace-regexp-in-string
+ (rx-to-string `(one-or-more ,(char-to-string ?\N{ZERO WIDTH SPACE})))
+ "" text t t))
+ ;; `org-extra-emphasis-intraword-emphasis-mode' is OFF.
+ (t
+ ;; Nothing to do.
+ text)))
+
+;; Configure Org Export Engine to strip ZERO WIDTH SPACE, if needed.
+;; (dolist (it '(org-export-filter-table-cell-functions
+;; org-export-filter-paragraph-functions))
+;; (add-to-list it 'org-extra-emphasis-strip-zws-maybe it))
+
+(provide 'org-extra-emphasis)
+
+;;; org-extra-emphasis.el ends here
diff --git a/tools/emacs/lisp/org-protocol-capture-html.el b/tools/emacs/lisp/org-protocol-capture-html.el
@@ -0,0 +1,280 @@
+;;; org-protocol-capture-html.el --- Capture HTML with org-protocol
+
+;; URL: https://github.com/alphapapa/org-protocol-capture-html
+;; Version: 0.1-pre
+;; Package-Requires: ((emacs "24.4"))
+
+;;; Commentary:
+
+;; This package captures Web pages into Org-mode using Pandoc to
+;; process HTML. It can also use eww's eww-readable functionality to
+;; get the main content of a page.
+
+;; These are the helper functions that run in Emacs. To capture pages
+;; into Emacs, you can use either a browser bookmarklet or the
+;; org-protocol-capture-html.sh shell script. See the README.org file
+;; for instructions.
+
+;;; License:
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Code:
+
+;;;; Require
+
+(require 'org-protocol)
+(require 'cl-lib)
+(require 'subr-x)
+(require 's)
+
+;;;; Vars
+
+(defcustom org-protocol-capture-html-demote-times 1
+ "How many times to demote headings in captured pages.
+You may want to increase this if you use a sub-heading in your capture template."
+ :group 'org-protocol-capture-html :type 'integer)
+
+;;;; Test Pandoc
+
+(defconst org-protocol-capture-html-pandoc-no-wrap-option nil
+ ;; Set this so it won't be unbound
+ "Option to pass to Pandoc to disable wrapping.
+Pandoc >= 1.16 deprecates `--no-wrap' in favor of
+`--wrap=none'.")
+
+(defun org-protocol-capture-html--define-pandoc-wrap-const ()
+ "Set `org-protocol-capture-html-pandoc-no-wrap-option'."
+ (setq org-protocol-capture-html-pandoc-no-wrap-option
+ ;; Pandoc >= 1.16 deprecates the --no-wrap option, replacing it with
+ ;; --wrap=none. Sending the wrong option causes output to STDERR,
+ ;; which `call-process-region' doesn't like. So we test Pandoc to see
+ ;; which option to use.
+ (with-temp-buffer
+ (let* ((process (start-process "test-pandoc" (current-buffer) "pandoc" "--dump-args" "--no-wrap"))
+ (limit 3)
+ (checked 0))
+ (while (process-live-p process)
+ (if (= checked limit)
+ (progn
+ ;; Pandoc didn't exit in time. Kill it and raise
+ ;; an error. This function will return `nil' and
+ ;; `org-protocol-capture-html-pandoc-no-wrap-option'
+ ;; will remain `nil', which will cause this
+ ;; function to run again and set the const when a
+ ;; capture is run.
+ (set-process-query-on-exit-flag process nil)
+ (error "Unable to test Pandoc! Please report this bug! (include the output of \"pandoc --dump-args --no-wrap\")"))
+ (sleep-for 0.2)
+ (cl-incf checked)))
+ (if (and (zerop (process-exit-status process))
+ (not (string-match "--no-wrap is deprecated" (buffer-string))))
+ "--no-wrap"
+ "--wrap=none")))))
+
+;;;; Direct-to-Pandoc
+
+(defun org-protocol-capture-html--with-pandoc (data)
+ "Process an org-protocol://capture-html:// URL using DATA.
+
+This function is basically a copy of `org-protocol-do-capture', but
+it passes the captured content (not the URL or title) through
+Pandoc, converting HTML to Org-mode."
+
+ ;; It would be nice to not basically duplicate
+ ;; `org-protocol-do-capture', but passing the data back to that
+ ;; function would require re-encoding the data into a URL string
+ ;; with Emacs after Pandoc converts it. Since we've already split
+ ;; it up, we might as well go ahead and run the capture directly.
+
+ (unless org-protocol-capture-html-pandoc-no-wrap-option
+ (org-protocol-capture-html--define-pandoc-wrap-const))
+
+ (let* ((template (or (plist-get data :template)
+ org-protocol-default-template-key))
+ (url (org-protocol-sanitize-uri (plist-get data :url)))
+ (type (if (string-match "^\\([a-z]+\\):" url)
+ (match-string 1 url)))
+ (title (or (org-protocol-capture-html--nbsp-to-space (string-trim (plist-get data :title))) ""))
+ (content (or (org-protocol-capture-html--nbsp-to-space (string-trim (plist-get data :body))) ""))
+ (orglink (org-make-link-string
+ url (if (string-match "[^[:space:]]" title) title url)))
+ (org-capture-link-is-already-stored t)) ; avoid call to org-store-link
+
+ (setq org-stored-links
+ (cons (list url title) org-stored-links))
+ (kill-new orglink)
+
+ (with-temp-buffer
+ (insert content)
+ (if (not (zerop (call-process-region
+ (point-min) (point-max)
+ "pandoc" t t nil "-f" "html" "-t" "org" org-protocol-capture-html-pandoc-no-wrap-option)))
+ (message "Pandoc failed: %s" (buffer-string))
+ (progn
+ ;; Pandoc succeeded
+ (org-store-link-props :type type
+ :annotation orglink
+ :link url
+ :description title
+ :orglink orglink
+ :initial (buffer-string)))))
+ (org-protocol-capture-html--do-capture)
+ nil))
+
+(add-to-list 'org-protocol-protocol-alist
+ '("capture-html"
+ :protocol "capture-html"
+ :function org-protocol-capture-html--with-pandoc
+ :kill-client t))
+
+;;;; eww-readable
+
+(defvar url-http-end-of-headers)
+
+(eval-when-compile
+ ;; eww-readable only works on Emacs >=25.1, but I think it's better
+ ;; to check for the actual symbols. I think using
+ ;; `eval-when-compile' is the right way to do this, but I'm not
+ ;; sure.
+ (when (and (require 'eww nil t)
+ (require 'dom nil t)
+ (fboundp 'eww-score-readability))
+
+ (defun org-protocol-capture-html--capture-eww-readable (data)
+ "Capture content of URL with eww-readable.."
+
+ (unless org-protocol-capture-html-pandoc-no-wrap-option
+ (org-protocol-capture-html--define-pandoc-wrap-const))
+
+ (let* ((template (or (plist-get data :template)
+ org-protocol-default-template-key))
+ (url (org-protocol-sanitize-uri (plist-get data :url)))
+ (type (if (string-match "^\\([a-z]+\\):" url)
+ (match-string 1 url)))
+ (html (org-protocol-capture-html--url-html url))
+ (result (org-protocol-capture-html--eww-readable html))
+ (title (cdr result))
+ (content (with-temp-buffer
+ (insert (org-protocol-capture-html--nbsp-to-space (car result)))
+ ;; Convert to Org with Pandoc
+ (unless (= 0 (call-process-region (point-min) (point-max)
+ "pandoc" t t nil "-f" "html" "-t" "org"
+ org-protocol-capture-html-pandoc-no-wrap-option))
+ (error "Pandoc failed"))
+ (save-excursion
+ ;; Remove DOS CR/LF line endings
+ (goto-char (point-min))
+ (while (search-forward (string ?\C-m) nil t)
+ (replace-match "")))
+ ;; Demote page headings in capture buffer to below the
+ ;; top-level Org heading and "Article" 2nd-level heading
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward (rx bol (1+ "*") (1+ space)) nil t)
+ (beginning-of-line)
+ (insert "**")
+ (end-of-line)))
+ (buffer-string)))
+ (orglink (org-make-link-string
+ url (if (s-present? title) title url)))
+ ;; Avoid call to org-store-link
+ (org-capture-link-is-already-stored t))
+
+ (setq org-stored-links
+ (cons (list url title) org-stored-links))
+ (kill-new orglink)
+
+ (org-store-link-props :type type
+ :annotation orglink
+ :link url
+ :description title
+ :orglink orglink
+ :initial content)
+ (org-protocol-capture-html--do-capture)
+ nil))
+
+ (add-to-list 'org-protocol-protocol-alist
+ '("capture-eww-readable"
+ :protocol "capture-eww-readable"
+ :function org-protocol-capture-html--capture-eww-readable
+ :kill-client t))
+
+ (defun org-protocol-capture-html--url-html (url)
+ "Return HTML from URL as string."
+ (let* ((response-buffer (url-retrieve-synchronously url nil t))
+ (encoded-html (with-current-buffer response-buffer
+ (pop-to-buffer response-buffer)
+ ;; Skip HTTP headers, using marker provided by url-http
+ (delete-region (point-min) (1+ url-http-end-of-headers))
+ (buffer-string))))
+ (kill-buffer response-buffer) ; Not sure if necessary to avoid leaking buffer
+ (with-temp-buffer
+ ;; For some reason, running `decode-coding-region' in the
+ ;; response buffer has no effect, so we have to do it in a
+ ;; temp buffer.
+ (insert encoded-html)
+ (condition-case nil
+ ;; Fix undecoded text
+ (decode-coding-region (point-min) (point-max) 'utf-8)
+ (coding-system-error nil))
+ (buffer-string))))
+
+ (defun org-protocol-capture-html--eww-readable (html)
+ "Return `eww-readable' part of HTML with title.
+Returns list (HTML . TITLE)."
+ ;; Based on `eww-readable'
+ (let* ((html
+ ;; Convert " " in HTML to plain spaces.
+ ;; `libxml-parse-html-region' turns them into
+ ;; underlines. The closest I can find to an explanation
+ ;; is at <http://www.perlmonks.org/?node_id=825188>.
+ (org-protocol-capture-html--nbsp-to-space html))
+ (dom (with-temp-buffer
+ (insert html)
+ (libxml-parse-html-region (point-min) (point-max))))
+ (title (cl-caddr (car (dom-by-tag dom 'title)))))
+ (eww-score-readability dom)
+ (cons (with-temp-buffer
+ (shr-dom-print (eww-highest-readability dom))
+ (buffer-string))
+ title)))))
+
+;;;; Helper functions
+
+(defun org-protocol-capture-html--nbsp-to-space (s)
+ "Convert HTML non-breaking spaces to plain spaces in S."
+ ;; Not sure why sometimes these are in the HTML and Pandoc converts
+ ;; them to underlines instead of spaces, but this fixes it.
+ (replace-regexp-in-string (rx " ") " " s t t))
+
+(with-no-warnings
+ ;; Ignore warning about the dynamically scoped `template' variable.
+ (defun org-protocol-capture-html--do-capture ()
+ "Call `org-capture' and demote page headings in capture buffer."
+ (raise-frame)
+ (funcall 'org-capture nil template)
+
+ ;; Demote page headings in capture buffer to below the
+ ;; top-level Org heading
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward (rx bol "*" (1+ space)) nil t) ; Skip 1st heading
+ (while (re-search-forward (rx bol "*" (1+ space)) nil t)
+ (dotimes (n org-protocol-capture-html-demote-times)
+ (org-demote-subtree))))))
+
+(provide 'org-protocol-capture-html)
+
+;;; org-protocol-capture-html.el ends here
