I've refactored `org-export-as-html', factored code to build links
into `org-html-make-link'.
This does two things that I needed:
* It allows custom link types to build anchors.
* How: Call org-html-make-link. Many parameters, see the function
docstring. It returns a string containing an HTML link.
* It adds the capability to convert links when exporting.
* How: Around the export call, bind org-html-cvt-link-fn to a
function that takes 1 parameter (filename) and returns a url as a
string.
I think it also makes the code cleaner.
There are more things that could be done - it's only used by some of
the cond branches, the others are unchanged. But "publish early and
often", so here it is.
I will append the changes as a diff, since I can't push to the org
repository ("fatal: The remote end hung up unexpectedly")
Tom Breton (Tehom)
diff --git a/lisp/org-html.el b/lisp/org-html.el
index 74f3a55..9aaadec 100644
--- a/lisp/org-html.el
+++ b/lisp/org-html.el
@@ -533,6 +533,106 @@ in a window. A non-interactive call will only return the buffer."
(defvar html-table-tag nil) ; dynamically scoped into this.
(defvar org-par-open nil)
+(defconst org-html-cvt-link-fn
+ ;;In the future this might change to take more args: type + path +
+ ;;fragment
+ #'identity
+ "Function to convert link URLs to exportable URLs.
+Takes one argument, PATH.
+Returns exportable URL.
+Intended to be locally bound around a call to `org-export-as-html'." )
+
+;;; org-html-cvt-link-fn
+(defconst org-html-cvt-link-fn
+ ;;In the future this might change to take more args: type + path +
+ ;;fragment
+ #'identity
+ "Function to convert link URLs to exportable URLs.
+Takes one argument, PATH.
+Returns exportable URL.
+Intended for remote exporting." )
+
+
+;;; org-html-make-link
+;;Special variables seen:
+;;`html-extension' -- From plist
+;;`org-par-open' is a special variable so it's not in the arglist.
+(defun org-html-make-link (type path fragment desc descp attr
+ may-inline-p)
+ "Make an HTML link
+TYPE is the device-type of the link (And isn't used yet) (THIS://foo.html)
+PATH is the path of the link (http://THIS)
+FRAGMENT is the fragment part of the link, if any (The foo.html#THIS part)
+DESC is the link description, if any.
+DESCP is whether there originally was a description.
+ATTR is a string of other attributes of the a element.
+MAY-INLINE-P allows inlining it as an image."
+
+ (declare (special html-extension org-par-open))
+ (let ((filename path)
+ thefile)
+ (save-match-data
+ ;;First pass. Mostly deals with treating local files. TYPE
+ ;;may still change.
+ (cond
+ ((string= type "file")
+ ;;Substitute just if original path was absolute.
+ ;;(Otherwise path must remain relative)
+ (setq thefile
+ (if (file-name-absolute-p filename)
+ (expand-file-name filename)
+ filename))
+
+ (when (and org-export-html-link-org-files-as-html
+ (string-match "\\.org$" thefile))
+ (setq type "http")
+ (setq thefile (concat (substring thefile 0
+ (match-beginning 0))
+ "." html-extension))))
+ (t (setq thefile filename)))
+
+ ;;If applicable, convert local path to remote URL
+ (setq thefile
+ (or
+ (funcall org-html-cvt-link-fn thefile)
+ thefile))
+
+ ;;Second pass. Build final link except for leading type
+ ;;spec. Now TYPE is final.
+ (cond
+ ((or
+ (string= type "http")
+ (string= type "https"))
+ (if fragment
+ (setq thefile (concat thefile "#" fragment))))
+
+ (t))
+
+ ;;Final URL-build, for all types.
+ (setq thefile
+ (concat type ":" (org-export-html-format-href thefile)))
+
+ (if (and
+ may-inline-p
+ ;;Can't inline a URL with a fragment.
+ (not fragment)
+ (or
+ (eq t org-export-html-inline-images)
+ (and
+ org-export-html-inline-images
+ (not descp)))
+ (org-file-image-p
+ filename org-export-html-inline-image-extensions))
+
+ (progn
+ (message "image %s %s" thefile org-par-open)
+ (org-export-html-format-image thefile org-par-open))
+ (concat
+ "<a href=\"" thefile "\"" attr ">"
+ (org-export-html-format-desc desc)
+ "</a>")))))
+
+;;; org-export-as-html
;;;###autoload
(defun org-export-as-html (arg &optional hidden ext-plist
to-buffer body-only pub-dir)
@@ -1014,7 +1114,7 @@ lang=\"%s\" xml:lang=\"%s\">
"\" class=\"target\">" (match-string 1 line)
"@</a> ")
t t line)))))
-
+
(setq line (org-html-handle-time-stamps line))
;; replace "&" by "&", "<" and ">" by "<" and ">"
@@ -1070,28 +1170,25 @@ lang=\"%s\" xml:lang=\"%s\">
(save-match-data
(setq id-file (file-relative-name
id-file (file-name-directory org-current-export-file)))
- (setq id-file (concat (file-name-sans-extension id-file)
- "." html-extension))
- (setq rpl (concat "<a href=\"" id-file "#"
- (if (org-uuidgen-p path) "ID-")
- path "\""
- attr ">"
- (org-export-html-format-desc desc)
- "</a>"))))
+ (setq rpl
+ (org-html-make-link
+ "file" id-file
+ (concat (if (org-uuidgen-p path) "ID-") path)
+ (org-export-html-format-desc desc)
+ descp
+ attr
+ nil))))
((member type '("http" "https"))
- ;; standard URL, just check if we need to inline an image
- (if (and (or (eq t org-export-html-inline-images)
- (and org-export-html-inline-images (not descp)))
- (org-file-image-p
- path org-export-html-inline-image-extensions))
- (setq rpl (org-export-html-format-image
- (concat type ":" path) org-par-open))
- (setq link (concat type ":" path))
- (setq rpl (concat "<a href=\""
- (org-export-html-format-href link)
- "\"" attr ">"
- (org-export-html-format-desc desc)
- "</a>"))))
+ ;; standard URL, just check if we need to inline an
+ ;; image
+ (setq rpl
+ (org-html-make-link
+ type path nil
+ (org-export-html-format-desc desc)
+ descp
+ attr
+ ;;But desc already becomes image.
+ t)))
((member type '("ftp" "mailto" "news"))
;; standard URL
(setq link (concat type ":" path))
@@ -1115,52 +1212,49 @@ lang=\"%s\" xml:lang=\"%s\">
((string= type "file")
;; FILE link
- (let* ((filename path)
- (abs-p (file-name-absolute-p filename))
- thefile file-is-image-p search)
(save-match-data
- (if (string-match "::\\(.*\\)" filename)
- (setq search (match-string 1 filename)
- filename (replace-match "" t nil filename)))
- (setq valid
- (if (functionp link-validate)
- (funcall link-validate filename current-dir)
- t))
- (setq file-is-image-p
- (org-file-image-p
- filename org-export-html-inline-image-extensions))
- (setq thefile (if abs-p (expand-file-name filename) filename))
- (when (and org-export-html-link-org-files-as-html
- (string-match "\\.org$" thefile))
- (setq thefile (concat (substring thefile 0
- (match-beginning 0))
- "." html-extension))
- (if (and search
- ;; make sure this is can be used as target search
- (not (string-match "^[0-9]*$" search))
- (not (string-match "^\\*" search))
- (not (string-match "^/.*/$" search)))
- (setq thefile
- (concat thefile
- (if (= (string-to-char search) ?#) "" "#")
- (org-solidify-link-text
- (org-link-unescape search)))))
- (when (string-match "^file:" desc)
- (setq desc (replace-match "" t t desc))
- (if (string-match "\\.org$" desc)
- (setq desc (replace-match "" t t desc))))))
- (setq rpl (if (and file-is-image-p
- (or (eq t org-export-html-inline-images)
- (and org-export-html-inline-images
- (not descp))))
- (progn
- (message "image %s %s" thefile org-par-open)
- (org-export-html-format-image thefile org-par-open))
- (concat "<a href=\"" thefile "\"" attr ">"
- (org-export-html-format-desc desc)
- "</a>")))
- (if (not valid) (setq rpl desc))))
-
+ (let*
+ ((frag-p
+ (string-match "::\\(.*\\)" path))
+ ;;Get the proper path
+ (path-1
+ (if frag-p
+ (replace-match "" t nil path)
+ path))
+ ;;Get the raw fragment
+ (fragment-0
+ (match-string 1 filename))
+ ;;Check the fragment. If it can't be used as
+ ;;target fragment we'll use nil instead.
+ (fragment-1
+ (if
+ (and frag-p
+ (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
+ (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
+ "file" path-1 fragment-1 desc-2 descp
+ attr t))))))
+
(t
;; just publish the path, as default
(setq rpl (concat "<i><" type ":"
@@ -1502,6 +1596,7 @@ lang=\"%s\" xml:lang=\"%s\">
(kill-buffer (current-buffer)))
(current-buffer)))))
+
(defun org-export-html-insert-plist-item (plist key &rest args)
(let ((item (plist-get plist key)))
(cond ((functionp item)_______________________________________________
Emacs-orgmode mailing list
Please use `Reply All' to send replies to the list.
Emacs-orgmode@gnu.org
http://lists.gnu.org/mailman/listinfo/emacs-orgmode
