From ea1c1e8528af0490c03133a09575e72fa4d0f352 Mon Sep 17 00:00:00 2001 From: David Maus Date: Sun, 30 Jan 2011 18:12:06 +0100 Subject: [PATCH] Factor out link Handling during export * org-html.el (org-html-handle-links): New function. Factor out link Handling during export. (org-export-as-html): Use new function. Putting the entire logic of link handling in a separate function makes it easier to test the link creation during html export and maybe refactor the function in the future. The body of the function is a 1:1 copy of the original code in `org-export-as-html', symbols which were used by the link handling exclusively are removed from `org-export-as-html'. --- lisp/org-html.el | 332 ++++++++++++++++++++++++++++-------------------------- 1 files changed, 171 insertions(+), 161 deletions(-) diff --git a/lisp/org-html.el b/lisp/org-html.el index 9a5d225..2216852 100644 --- a/lisp/org-html.el +++ b/lisp/org-html.el @@ -795,6 +795,173 @@ MAY-INLINE-P allows inlining it as an image." (org-export-html-format-desc desc) ""))))) +(defun org-html-handle-links (line opt-plist) + "Return LINE with markup of Org mode links. +OPT-PLIST is the export options list." + (let ((start 0) + (current-dir (if buffer-file-name + (file-name-directory buffer-file-name) + default-directory)) + (link-validate (plist-get opt-plist :link-validation-function)) + type id-file fnc + rpl path attr desc descp desc1 desc2 link) + (while (string-match org-bracket-link-analytic-regexp++ line start) + (setq start (match-beginning 0)) + (setq path (save-match-data (org-link-unescape + (match-string 3 line)))) + (setq type (cond + ((match-end 2) (match-string 2 line)) + ((save-match-data + (or (file-name-absolute-p path) + (string-match "^\\.\\.?/" path))) + "file") + (t "internal"))) + (setq path (org-extract-attributes (org-link-unescape path))) + (setq attr (get-text-property 0 'org-attributes path)) + (setq desc1 (if (match-end 5) (match-string 5 line)) + desc2 (if (match-end 2) (concat type ":" path) path) + descp (and desc1 (not (equal desc1 desc2))) + desc (or desc1 desc2)) + ;; Make an image out of the description if that is so wanted + (when (and descp (org-file-image-p + desc org-export-html-inline-image-extensions)) + (save-match-data + (if (string-match "^file:" desc) + (setq desc (substring desc (match-end 0))))) + (setq desc (org-add-props + (concat "") + '(org-protected t)))) + (cond + ((equal type "internal") + (let + ((frag-0 + (if (= (string-to-char path) ?#) + (substring path 1) + path))) + (setq rpl + (org-html-make-link + opt-plist + "" + "" + (org-solidify-link-text + (save-match-data (org-link-unescape frag-0)) + nil) + desc attr nil)))) + ((and (equal type "id") + (setq id-file (org-id-find-id-file path))) + ;; This is an id: link to another file (if it was the same file, + ;; it would have become an internal link...) + (save-match-data + (setq id-file (file-relative-name + id-file + (file-name-directory org-current-export-file))) + (setq rpl + (org-html-make-link opt-plist + "file" id-file + (concat (if (org-uuidgen-p path) "ID-") path) + desc + attr + nil)))) + ((member type '("http" "https")) + ;; standard URL, can inline as image + (setq rpl + (org-html-make-link opt-plist + type path nil + desc + attr + (org-html-should-inline-p path descp)))) + ((member type '("ftp" "mailto" "news")) + ;; standard URL, can't inline as image + (setq rpl + (org-html-make-link opt-plist + type path nil + desc + attr + nil))) + + ((string= type "coderef") + (let* + ((coderef-str (format "coderef-%s" path)) + (attr-1 + (format "class=\"coderef\" onmouseover=\"CodeHighlightOn(this, '%s');\" onmouseout=\"CodeHighlightOff(this, '%s');\"" + coderef-str coderef-str))) + (setq rpl + (org-html-make-link opt-plist + type "" coderef-str + (format + (org-export-get-coderef-format + path + (and descp desc)) + (cdr (assoc path org-export-code-refs))) + attr-1 + nil)))) + + ((functionp (setq fnc (nth 2 (assoc type org-link-protocols)))) + ;; The link protocol has a function for format the link + (setq rpl + (save-match-data + (funcall fnc (org-link-unescape path) desc1 'html)))) + + ((string= type "file") + ;; FILE link + (save-match-data + (let* + ((components + (if + (string-match "::\\(.*\\)" path) + (list + (replace-match "" t nil path) + (match-string 1 path)) + (list path nil))) + + ;;The proper path, without a fragment + (path-1 + (first components)) + + ;;The raw fragment + (fragment-0 + (second components)) + + ;;Check the fragment. If it can't be used as + ;;target fragment we'll pass nil instead. + (fragment-1 + (if + (and fragment-0 + (not (string-match "^[0-9]*$" fragment-0)) + (not (string-match "^\\*" fragment-0)) + (not (string-match "^/.*/$" fragment-0))) + (org-solidify-link-text + (org-link-unescape fragment-0)) + nil)) + (desc-2 + ;;Description minus "file:" and ".org" + (if (string-match "^file:" desc) + (let + ((desc-1 (replace-match "" t t desc))) + (if (string-match "\\.org$" desc-1) + (replace-match "" t t desc-1) + desc-1)) + desc))) + + (setq rpl + (if + (and + (functionp link-validate) + (not (funcall link-validate path-1 current-dir))) + desc + (org-html-make-link opt-plist + "file" path-1 fragment-1 desc-2 attr + (org-html-should-inline-p path-1 descp))))))) + + (t + ;; just publish the path, as default + (setq rpl (concat "<" type ":" + (save-match-data (org-link-unescape path)) + ">")))) + (setq line (replace-match rpl t t line) + start (+ start (length rpl)))) + line)) + ;;; org-export-as-html ;;;###autoload (defun org-export-as-html (arg &optional hidden ext-plist @@ -844,7 +1011,6 @@ PUB-DIR is set, use this as the publishing directory." (if (plist-get opt-plist :style-include-scripts) org-export-html-scripts))) (html-extension (plist-get opt-plist :html-extension)) - (link-validate (plist-get opt-plist :link-validation-function)) valid thetoc have-headings first-heading-pos (odd org-odd-levels-only) (region-p (org-region-active-p)) @@ -980,13 +1146,12 @@ PUB-DIR is set, use this as the publishing directory." org-export-html-mathjax-options (or (plist-get opt-plist :mathjax) "")) "")) - table-open type + table-open table-buffer table-orig-buffer ind item-type starter - rpl path attr desc descp desc1 desc2 link - snumber fnc item-tag item-number + snumber item-tag item-number footnotes footref-seen - id-file href + href ) (let ((inhibit-read-only t)) @@ -1315,162 +1480,7 @@ lang=\"%s\" xml:lang=\"%s\"> (setq line (org-html-expand line))) ;; Format the links - (setq start 0) - (while (string-match org-bracket-link-analytic-regexp++ line start) - (setq start (match-beginning 0)) - (setq path (save-match-data (org-link-unescape - (match-string 3 line)))) - (setq type (cond - ((match-end 2) (match-string 2 line)) - ((save-match-data - (or (file-name-absolute-p path) - (string-match "^\\.\\.?/" path))) - "file") - (t "internal"))) - (setq path (org-extract-attributes (org-link-unescape path))) - (setq attr (get-text-property 0 'org-attributes path)) - (setq desc1 (if (match-end 5) (match-string 5 line)) - desc2 (if (match-end 2) (concat type ":" path) path) - descp (and desc1 (not (equal desc1 desc2))) - desc (or desc1 desc2)) - ;; Make an image out of the description if that is so wanted - (when (and descp (org-file-image-p - desc org-export-html-inline-image-extensions)) - (save-match-data - (if (string-match "^file:" desc) - (setq desc (substring desc (match-end 0))))) - (setq desc (org-add-props - (concat "") - '(org-protected t)))) - (cond - ((equal type "internal") - (let - ((frag-0 - (if (= (string-to-char path) ?#) - (substring path 1) - path))) - (setq rpl - (org-html-make-link - opt-plist - "" - "" - (org-solidify-link-text - (save-match-data (org-link-unescape frag-0)) - nil) - desc attr nil)))) - ((and (equal type "id") - (setq id-file (org-id-find-id-file path))) - ;; This is an id: link to another file (if it was the same file, - ;; it would have become an internal link...) - (save-match-data - (setq id-file (file-relative-name - id-file - (file-name-directory org-current-export-file))) - (setq rpl - (org-html-make-link opt-plist - "file" id-file - (concat (if (org-uuidgen-p path) "ID-") path) - desc - attr - nil)))) - ((member type '("http" "https")) - ;; standard URL, can inline as image - (setq rpl - (org-html-make-link opt-plist - type path nil - desc - attr - (org-html-should-inline-p path descp)))) - ((member type '("ftp" "mailto" "news")) - ;; standard URL, can't inline as image - (setq rpl - (org-html-make-link opt-plist - type path nil - desc - attr - nil))) - - ((string= type "coderef") - (let* - ((coderef-str (format "coderef-%s" path)) - (attr-1 - (format "class=\"coderef\" onmouseover=\"CodeHighlightOn(this, '%s');\" onmouseout=\"CodeHighlightOff(this, '%s');\"" - coderef-str coderef-str))) - (setq rpl - (org-html-make-link opt-plist - type "" coderef-str - (format - (org-export-get-coderef-format - path - (and descp desc)) - (cdr (assoc path org-export-code-refs))) - attr-1 - nil)))) - - ((functionp (setq fnc (nth 2 (assoc type org-link-protocols)))) - ;; The link protocol has a function for format the link - (setq rpl - (save-match-data - (funcall fnc (org-link-unescape path) desc1 'html)))) - - ((string= type "file") - ;; FILE link - (save-match-data - (let* - ((components - (if - (string-match "::\\(.*\\)" path) - (list - (replace-match "" t nil path) - (match-string 1 path)) - (list path nil))) - - ;;The proper path, without a fragment - (path-1 - (first components)) - - ;;The raw fragment - (fragment-0 - (second components)) - - ;;Check the fragment. If it can't be used as - ;;target fragment we'll pass nil instead. - (fragment-1 - (if - (and fragment-0 - (not (string-match "^[0-9]*$" fragment-0)) - (not (string-match "^\\*" fragment-0)) - (not (string-match "^/.*/$" fragment-0))) - (org-solidify-link-text - (org-link-unescape fragment-0)) - nil)) - (desc-2 - ;;Description minus "file:" and ".org" - (if (string-match "^file:" desc) - (let - ((desc-1 (replace-match "" t t desc))) - (if (string-match "\\.org$" desc-1) - (replace-match "" t t desc-1) - desc-1)) - desc))) - - (setq rpl - (if - (and - (functionp link-validate) - (not (funcall link-validate path-1 current-dir))) - desc - (org-html-make-link opt-plist - "file" path-1 fragment-1 desc-2 attr - (org-html-should-inline-p path-1 descp))))))) - - (t - ;; just publish the path, as default - (setq rpl (concat "<" type ":" - (save-match-data (org-link-unescape path)) - ">")))) - (setq line (replace-match rpl t t line) - start (+ start (length rpl)))) + (setq line (org-html-handle-links line opt-plist)) (setq line (org-html-handle-time-stamps line)) -- 1.7.2.3