Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
397 lines (384 sloc) 16.2 KB
;;; custom-org-html.el --- Custom org-mode html exporter
(require 'ox-html)
(org-export-define-derived-backend
'custom-html 'html
:translate-alist '((headline . custom-org-html-headline))
:options-alist '((:html-after-contents "HTML_AFTER_CONTENTS" nil custom-org-html-after-contents)
(:html-validation-link nil "html-validation-link" org-html-validation-link)
(:html-postamble "HTML_POSTAMBLE" "html-postamble" org-html-postamble)))
(defcustom custom-org-html-after-contents nil
"Arbitrary HTML to insert after the main content, before postamble.
Can be set with the in-buffer HTML_AFTER_CONTENT property or for
publishing, with :html-after-content."
:group 'org-export-html
;; :version "24.4"
;; :package-version '(Org . "8.0")
:type 'string)
(defun custom-org-html-headline (headline contents info)
"Transcode a HEADLINE element from Org to HTML.
CONTENTS holds the contents of the headline. INFO is a plist
holding contextual information."
(unless (org-element-property :footnote-section-p headline)
(let* ((numberedp (org-export-numbered-headline-p headline info))
(numbers (org-export-get-headline-number headline info))
(level (+ (org-export-get-relative-level headline info)
(1- (plist-get info :html-toplevel-hlevel))))
(todo (and (plist-get info :with-todo-keywords)
(let ((todo (org-element-property :todo-keyword headline)))
(and todo (org-export-data todo info)))))
(todo-type (and todo (org-element-property :todo-type headline)))
(priority (and (plist-get info :with-priority)
(org-element-property :priority headline)))
(text (org-export-data (org-element-property :title headline) info))
(tags (and (plist-get info :with-tags)
(org-export-get-tags headline info)))
(full-text (funcall (plist-get info :html-format-headline-function)
todo todo-type priority text tags info))
(contents (or contents ""))
(ids (delq nil
(progn
(list (org-element-property :CUSTOM_ID headline)
(org-export-get-reference headline info)
(org-element-property :ID headline)))))
(preferred-id (car ids))
(extra-ids
(mapconcat
(lambda (id)
(org-html--anchor
(if (org-uuidgen-p id) (concat "ID-" id) id)
nil nil info))
(cdr ids) "")))
(if (org-export-low-level-p headline info)
;; This is a deep sub-tree: export it as a list item.
(let* ((html-type (if numberedp "ol" "ul")))
(concat
(and (org-export-first-sibling-p headline info)
(apply #'format "<%s class=\"org-%s\">\n"
(make-list 2 html-type)))
(org-html-format-list-item
contents (if numberedp 'ordered 'unordered)
nil info nil
(concat (org-html--anchor preferred-id nil nil info)
extra-ids
full-text)) "\n"
(and (org-export-last-sibling-p headline info)
(format "</%s>\n" html-type))))
;; Standard headline. Export it as a section.
(let ((extra-class (org-element-property :HTML_CONTAINER_CLASS headline))
(first-content (car (org-element-contents headline))))
(format "<%s id=\"%s\" class=\"%s\">%s%s</%s>\n"
(org-html--container headline info)
(concat "outline-container-"
(org-export-get-reference headline info))
(concat (format "outline-%d" level)
(and extra-class " ")
extra-class)
(let* ((section-number-s (mapconcat #'number-to-string numbers "."))
;;(heading-id (format "%s-%s" section-number-s full-text))
)
(format "\n<h%d id=\"%s\">%s%s</h%d>\n"
level
preferred-id
extra-ids
(concat
(and numberedp
(format
"<a class=\"section-number-%d\" href=\"#%s\">%s</a> "
level
preferred-id
section-number-s))
full-text)
level))
;; When there is no section, pretend there is an
;; empty one to get the correct <div
;; class="outline-...> which is needed by
;; `org-info.js'.
(if (eq (org-element-type first-content) 'section) contents
(concat (org-html-section first-content "" info) contents))
(org-html--container headline info)))))))
(defun custom-org-format-latex
(prefix &optional beg end dir overlays msg forbuffer processing-type)
"Like org-format-latex, but customized. Wraps a ~math-block~ div around mathjax math blocks."
(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)))
;; 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-property :begin context))
(end (save-excursion
(goto-char (org-element-property :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 "<div class=\"math-block\"><div class=\"mathjax-wrapper\">\\[" (substring value 2 -2) "\\]</div></div>")
(insert "\\(" (substring value 1 -1) "\\)"))))
((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 (and forbuffer (eq color 'auto))
(face-attribute face :foreground nil 'default)
color)))
(bg
(let ((color (plist-get org-format-latex-options
:background)))
(if (and forbuffer (eq color 'auto))
(face-attribute face :background nil 'default)
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))
(if overlays
(progn
(dolist (o (overlays-in beg end))
(when (eq (overlay-get o 'org-overlay-type)
'org-latex-overlay)
(delete-overlay o)))
(org--format-latex-make-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)))))))
((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 headline? (datum)
(eq (car datum) 'headline))
(defun get-raw-value (datum)
(plist-get (cadr datum) :raw-value))
(defun custom-org-html--build-after-contents (info)
"Insert arbitrary html after the content, before the postamble."
(let ((after-contents (plist-get info :html-after-contents)))
(org-element-normalize-string after-contents)))
(defun custom-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
(fboundp 'coding-system-get)
(coding-system-get org-html-coding-system 'mime-charset))
"iso-8859-1"))))))
(org-html-doctype info)
"\n"
(concat "<html"
(cond ((org-html-xhtml-p info)
(format
" xmlns=\"http://www.w3.org/1999/xhtml\" lang=\"%s\" xml:lang=\"%s\""
(plist-get info :language) (plist-get info :language)))
((org-html-html5-p info)
(format " lang=\"%s\"" (plist-get info :language))))
">\n")
"<head>\n"
(org-html--build-meta-info info)
(org-html--build-head info)
(org-html--build-mathjax-config info)
"</head>\n"
"<body>\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\">\n" (nth 1 div) (nth 2 div)))
;; 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
"<header>\n<h1 class=\"title\">%s</h1>\n%s</header>"
"<h1 class=\"title\">%s%s</h1>\n")
(org-export-data title info)
(if subtitle
(format
(if html5-fancy
"<p class=\"subtitle\">%s</p>\n"
(concat "\n" (org-html-close-tag "br" nil info) "\n"
"<span class=\"subtitle\">%s</span>\n"))
(org-export-data subtitle info))
"")))))
contents
;; After contents
(custom-org-html--build-after-contents info)
(format "</%s>\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.
(if (plist-get info :html-klipsify-src)
(concat "<script>" (plist-get info :html-klipse-selection-script)
"</script><script src=\""
org-html-klipse-js
"\"></script><link rel=\"stylesheet\" type=\"text/css\" href=\""
org-html-klipse-css "\"/>"))
;; Closing document.
"</body>\n</html>"))
(defun custom-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 (and (or (require 'htmlize nil t)
(error "Please install htmlize from \
https://github.com/hniksic/emacs-htmlize"))
(fboundp 'htmlize-region-for-paste)))
;; Emit a warning.
(message "Cannot fontify src block (htmlize.el >= 1.34 required)")
(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))
(with-temp-buffer
;; Switch to language-specific mode.
(funcall lang-mode)
(fci-mode 0)
(insert code)
;; Fontify buffer.
(org-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 <pre></pre> tags.
(let* ((beg (and (string-match "\\`<pre[^>]*>\n?" code) (match-end 0)))
(end (and beg (string-match "</pre>\\'" code))))
(if (and beg end) (substring code beg end) code)))))))))
;;;###autoload
(defun org-html-export-to-custom-html
(&optional async subtreep visible-only body-only ext-plist)
"Like org-html-export-to-html, but with some customizations."
(interactive)
(cl-letf (((symbol-function 'org-format-latex) #'custom-org-format-latex)
((symbol-function 'org-html-headline) #'custom-org-html-headline)
((symbol-function 'org-html-template) #'custom-org-html-template)
((symbol-function 'org-html-fontify-code) #'custom-org-html-fontify-code))
(let* ((extension (concat "." (or (plist-get ext-plist :html-extension)
org-html-extension
"html")))
(file (org-export-output-file-name extension subtreep))
(org-export-coding-system org-html-coding-system)
(org-html-divs '((preamble "div" "preamble")
(content "div" "content")
(postamble "footer" "postamble"))))
(org-export-to-file 'custom-html file
async subtreep visible-only body-only ext-plist))))
;;;###autoload
(defun org-html-export-project-to-custom-html ()
(interactive)
(let* ((index-path (locate-current-dominating-file-regex "^index.org$"))
(project-dir (file-name-directory index-path))
(full-path? t)
(page-paths (directory-files (concat project-dir "pages") full-path? "\\.org$")))
(save-window-excursion
(dolist (page-path (cons index-path page-paths))
(with-current-buffer (find-file page-path)
(org-html-export-to-custom-html))))))
(provide 'custom-org-html)
You can’t perform that action at this time.