Home / Emacs / Org Publish
Multi-HTML export (unlimited!)
(defun my-org-keyword-value (data key)
"Return the value of KEY keyword in DATA parse tree."
(let ((key (upcase key)))
(string-join
(org-element-map data 'keyword
(lambda (keyword)
(when (string= (org-element-property :key keyword) key)
(org-element-property :value keyword))))
" ")))
(defun my-org-split-parse-options (options)
"Return OPTIONS from #+OPTIONS parsed into key-value alist."
(mapcar (lambda (option)
(let ((components (string-split option ":")))
(cons (nth 0 components)
(nth 1 components))))
(string-split options)))
(defun my-org-collect-keywords (data keywords)
"Return values for KEYWORDS in current buffer, as a plist.
Like `org-collect-keywords' but
- not resolving SETUPFILE
- returning plist instead of alist
- returning concatenated strings instead of lists of strings"
(message "Collecting keywords...")
(let ((values '()))
(org-element-map data 'keyword
(lambda (element)
(let ((raw-key (org-element-property :key element)))
(if (member-ignore-case raw-key keywords)
(let* ((key (upcase raw-key))
(value
(if-let* ((new (org-element-property :value element))
(old (plist-get values key #'equal)))
(concat old " " new)
new)))
(setq values
(plist-put values key value #'equal)))))))
values))
(defun my-org-slug (title)
(let* ((title (downcase title))
(title (replace-regexp-in-string org-link-bracket-re "\\2" title))
(title (replace-regexp-in-string "[^a-zA-Z0-9]+" "-" title))
(title (replace-regexp-in-string "-+" "-" title))
(title (replace-regexp-in-string "^-+" "" title))
(title (replace-regexp-in-string "-+$" "" title)))
title))
(defun my-files-equal-p (file file*)
(and (file-exists-p file)
(file-exists-p file*)
(= (file-attribute-size (file-attributes file))
(file-attribute-size (file-attributes file*)))
(string= (with-temp-buffer
(insert-file-contents-literally file)
(buffer-substring-no-properties (point-min) (point-max)))
(with-temp-buffer
(insert-file-contents-literally file*)
(buffer-substring-no-properties (point-min) (point-max))))))
(defun my-file-content-equal-p (file content)
(and (file-exists-p file)
(string= content
(with-temp-buffer
(insert-file-contents file)
(buffer-substring-no-properties (point-min) (point-max))))))
(defun my-intersection-p (list1 list2)
"Return non-nil if LIST1 and LIST2 have at least one equal element.
Like set intersection but exits early."
(when (and list1 list2)
(or (member (car list1) list2)
(my-intersection-p (cdr list1) list2))))
(defun my-org-split-file-name (headline)
(cl-assert (eq (org-element-type headline) 'headline))
(file-name-with-extension
(my-org-slug
(string-join
(reverse
(org-element-lineage-map headline
(lambda (ancestor)
(org-element-property :raw-value ancestor))
'(headline)
t))
"/"))
"org"))
(defun my-org-keywords-string ()
(string-join
(org-element-map (org-element-parse-buffer) 'keyword
(lambda (element)
(if-let* ((key (org-element-property :key element))
(value (org-element-property :value element)))
(if (not (string-empty-p value))
(format "#+%s: %s" key value)))))
"\n"))
;; TODO Also look at `:select-tags'
(defun my-org-prune (exclude-tags)
(dolist (level (sort (org-element-map (org-element-parse-buffer) 'headline
(lambda (headline)
(org-element-property :true-level headline)))))
(let ((edits (org-element-map (org-element-parse-buffer) 'headline
(lambda (headline)
(if (and (= (org-element-property :true-level headline)
level)
(my-intersection-p
(org-element-property :tags headline)
exclude-tags))
(list (org-element-property :begin headline)
(org-element-property :end headline)))))))
(dolist (edit (reverse edits))
(apply #'delete-region edit)))))
;; (with-temp-buffer
;; (insert "A [[http://example.com][B]] C")
;; (org-element-map (org-element-parse-buffer) 'link
;; (lambda (link)
;; (let ((begin (org-element-property :begin link))
;; (end (org-element-property :end link))
;; (post-blank (org-element-post-blank link))
;; )
;; (buffer-substring-no-properties begin (- end
;; post-blank))))))
(defun my-org-split-first-headline-p (headline)
(eq (car (org-element-contents (org-element-parent headline)))
headline))
(defun my-org-split-first-headline-p (headline)
"Return non-nil if HEADLINE is the first in its parent.
HEADLINE must have full context."
(let* ((parent (org-element-contents (org-element-parent headline)))
(first-child (org-element-map parent 'headline #'identity nil t)))
(eq first-child headline)))
(defun my-org-multi-html--setup-file (data)
"Return #+OPTIONS as alist, given parse DATA."
(or (my-org-keyword-value data "SETUPFILE")
(user-error "SETUPFILE required for multi-page HTML export" file)))
(defun my-org-multi-html--options (file-or-data)
"Return #+OPTIONS as alist, given parse DATA."
(my-org-split-parse-options
(my-org-keyword-value
(if (stringp file-or-data)
(with-temp-buffer
(insert-file-contents-literally file-or-data)
(org-element-parse-buffer))
file-or-data)
"OPTIONS")))
(defun my-org-multi-html--option-number (options key default)
(if-let* ((string (alist-get key options nil nil #'string=)))
(string-to-number string)
default))
;; Looking great so far!
(defun my-org-html-publish-to-multiple-html (plist file pub-dir)
"Publish an Org file to multiple HTML files.
TODO This does not need to be tied to HTML: it all comes down to one call. Or, we just split.
Return root output file name."
(message "plist: %s" plist)
;; (:base-directory ~/org :exclude .* :include (obtf.org) :publishing-directory ~/org/tmp/www :publishing-function my-org-html-publish-to-multiple-html)
;;
;; Check preconditions.
(cl-check-type file string)
(cl-check-type pub-dir string)
(cl-assert (file-exists-p file) t "File '%s' does not exist")
(cl-assert (file-directory-p pub-dir) t "Directory '%s' does not exist")
;;
;; Copy the given FILE to PUB-DIR.
(message "Copying file...")
(copy-file file pub-dir t)
;;
;; Split the copy of the FILE in-place.
(let* ((file (file-name-concat pub-dir (file-name-nondirectory file)))
(index-file-name (file-name-with-extension "index" "org"))
(index-file (file-name-concat pub-dir index-file-name)))
(with-temp-file index-file
(insert-file-contents file)
(message "Parsing buffer...")
(let* ((data (org-element-parse-buffer))
(file-options (my-org-multi-html--options data))
(dir (file-name-directory file))
(setup-file (my-org-multi-html--setup-file data))
(setup-options (my-org-multi-html--options setup-file))
(options (append file-options setup-options))
;; (headline-levels (my-org-multi-html--option-number options "H" (or org-export-headline-levels 1)))
;; (toc-levels (my-org-multi-html--option-number options "toc" (or org-export-with-toc 1)))
(index-link (format "[[file:%s][%s]]" index-file-name "Home"))
(headlines (org-element-map data 'headline #'identity))
(headline-removals (make-vector (+ org-export-max-depth 1) 0))
(file-names (let ((hash (make-hash-table :test 'equal)))
(message "Mapping identifiers to file names...")
(org-element-map data 'headline
(lambda (headline)
;; Is the headline one with ID?
(when-let* ((id (org-element-property :ID headline)))
;; Is the headline to be exported?
(unless (org-element-lineage-map headline
(lambda (parent-headline)
(when (my-intersection-p
(org-element-property :tags parent-headline)
'("private")) ;; TODO Parse & also consider `selected'
t))
'(headline)
t
t)
;; Compute the file name.
(puthash id (my-org-split-file-name headline) hash)))))
hash)))
(message "Extracting headlines...")
(dolist (headline (reverse headlines))
(message "Processing headline: %s" (org-element-property :raw-value headline))
(let* ((level (org-element-property :true-level headline))
(excluded (org-element-lineage-map headline
(lambda (headline)
(when (my-intersection-p
(org-element-property :tags headline)
'("private")) ;; TODO Parse & also consider `selected'
t))
'(headline)
t
t))
(offset (elt headline-removals (1- level))) ;; aref? (used later)
(begin (org-element-begin headline)) ;; section-begin
(end (- (org-element-end headline) offset)) ;; section-end
(removal
;;
;; Case 1. The heading is excluded.
(if excluded
;;
;; Remove the headline, along with its content, and
;; return the number of removed characters.
(progn
(delete-region begin end)
(- end begin))
;;
;; Headline is included, do edits and return the number
;; of removed characters, to offset future edits.
(let* (
;;
;; Replace `id:' links with `file:' links, walking
;; backward to avoid shifting, accumulating the total
;; number of removed characters.
(links-delta
;; Gather all ID links.
(let* (
;; TODO Is this just one `org-element-map' over the `headline' itself?
(title-links (org-element-map (org-element-property :title headline) 'link
(lambda (link)
(if (equal (org-element-property :type link) "id")
link))
nil
nil
'headline))
(content-links (org-element-map (org-element-contents headline) 'link
(lambda (link)
(if (equal (org-element-property :type link) "id")
link))
nil
nil
'headline))
(links (append title-links content-links)))
;; Process the gathered links in reverse.
(seq-reduce
(lambda (removed link)
(let* ((begin (org-element-begin link))
(post-blank (org-element-post-blank link))
(end-blank (org-element-end link))
(end (- end-blank post-blank))
(description-begin (org-element-contents-begin link))
(description-end (org-element-contents-end link))
(description (buffer-substring-no-properties description-begin description-end))
(id (org-element-property :path link))
(replacement (if-let* ((file-name (gethash id file-names)))
(format "[[file:%s][%s]]" file-name description)
description)))
;; (cl-assert file-name nil "ID '%s' not found in '%s'" id file)
(replace-region-contents begin end replacement 0)
(+ removed
(- (- end begin)
(length replacement)))))
(reverse links)
0)))
(headline-delta
;;
;; Do we extract the heading?
(if (or
;; We extract if the heading has some content.
(org-element-contents-begin headline)
;; (if-let* ((unnumbered (org-element-property :UNNUMBERED headline)))
;; (not (string-equal-ignore-case unnumbered "NOTOC"))
;; t)
)
;;
;; Headline has ID, so is extracted.
(let* ((id (org-element-property :ID headline))
(file-name (or ;; (gethash id file-names)
(my-org-split-file-name headline)))
(breadcrumbs (string-join
(cons index-link
(reverse
(org-element-lineage-map headline
(lambda (headline)
(let ((id (org-element-property :ID headline))
(title (org-element-property :raw-value headline)))
(format "[[file:%s][%s]]"
(or ;; (gethash id file-names)
(my-org-split-file-name headline))
title)))
'(headline))))
" / "))
(begin (org-element-begin headline))
(end (- end links-delta))
(title (org-element-property :raw-value headline))
(no-link-title (replace-regexp-in-string org-link-bracket-re "\\2" title))
;; Alternative that shows one or the other:
;; (replace-regexp-in-string
;; org-link-bracket-re
;; (lambda (_) (or (match-string 2 _) (match-string 1 _)))
;; title)
(link (format "[[file:%s][%s]]" file-name no-link-title))
(stars (make-string level ?\*))
(content (concat
;; Disable Org Babel to avoid failed checks
;; of header arguments, where variables are
;; in other files.
"# -*- org-export-use-babel: nil -*-\n"
"#+SETUPFILE: " setup-file "\n"
(format "#+OPTIONS: H:1 toc:nil")
"\n"
breadcrumbs "\n" (make-string 5 ?\-) "\n"
(buffer-substring-no-properties begin end)))
(replacement (concat
;;
;; Add a separator before the first headline at LEVEL.
(if (my-org-split-first-headline-p headline)
(concat "\n" (make-string 5 ?\-) "\n")
"")
;;
;; Link the extracted file.
stars " " link "\n")))
;; (cl-assert file-name nil "ID '%s' not found in '%s'" id file)
;;
;; Replace the section with a link.
(replace-region-contents begin end replacement 0)
;;
;; Publish the heading, if changed.
(let ((file (file-name-concat pub-dir file-name)))
(if (my-file-content-equal-p file content)
(progn (message "Skipping '%s'..." file) nil)
;;
;; Extract the file.
(message "Extracting file '%s'" file)
(with-temp-file file (insert content))
;;
;; Publish the file.
(org-html-publish-to-html plist file pub-dir)))
;;
;; Return the removal.
(- (- end begin)
(length replacement)))
;;
;; Headline is not excluded nor extracted, so we do
;; nothing and return the removal of 0.
0)))
(+ links-delta
headline-delta)))))
;;
;; Adjust `headline-removals'.
(dolist (index (number-sequence 0 (1- (length headline-removals))))
(aset headline-removals
index
(if (< index (1- level))
(+ (aref headline-removals
index)
removal)
0)))))))
;;
;; Publish the index file.
(org-html-publish-to-html plist index-file pub-dir)))