Moved to new branch

lisp/org-html.el

@@ -533,6 +533,130 @@ 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)
+
+;;; org-html-cvt-link-fn
+(defconst org-html-cvt-link-fn 
+   nil
+   "Function to convert link URLs to exportable URLs.
+Takes two arguments, TYPE and PATH.
+Returns exportable url as (TYPE PATH), or `nil' to signal that it
+didn't handle this case.
+Intended to be locally bound around a call to `org-export-as-html'." )
+
+(defun org-html-cvt-org-as-html (opt-plist type path)
+   "Convert and org filename to an equivalent html filename.
+If TYPE is not file, just return `nil'.
+See variable `org-export-html-link-org-files-as-html'"
+
+   (save-match-data
+      (and 
+	 org-export-html-link-org-files-as-html
+	 (string= type "file")
+	 (string-match "\\.org$" path)
+	 (progn
+	    (list
+	       "http"
+	       (concat 
+		  (substring path 0 (match-beginning 0))
+		  "." 
+		  (plist-get opt-plist :html-extension)))))))
+
+
+;;; org-html-should-inline-p
+(defun org-html-should-inline-p (filename descp)
+   "Return non-nil if link FILENAME should be inlined, according to
+current settings.
+DESCP is the boolean of whether there was a link description.
+See variables `org-export-html-inline-images' and
+`org-export-html-inline-image-extensions'."
+   (declare (special 
+	       org-export-html-inline-images 
+	       org-export-html-inline-image-extensions))
+   (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))
+
+;;; org-html-make-link
+(defun org-html-make-link (opt-plist type path fragment desc attr
+			     may-inline-p) 
+   "Make an HTML link.
+OPT-PLIST is an options list.
+TYPE is the device-type of the link (THIS://foo.html)
+PATH is the path of the link (http://THIS#locationx)
+FRAGMENT is the fragment part of the link, if any (foo.html#THIS)
+DESC is the link description, if any.
+ATTR is a string of other attributes of the a element.
+MAY-INLINE-P allows inlining it as an image."
+
+   (declare (special org-par-open))
+   (save-match-data
+      (let* ((filename path)
+	       ;;First pass.  Just sanity stuff.
+	       (components-1
+		  (cond
+		     ((string= type "file")
+			(list
+			   type
+			   ;;Substitute just if original path was absolute.
+			   ;;(Otherwise path must remain relative)
+			   (if (file-name-absolute-p path) 
+			      (expand-file-name path) 
+			      path)))
+		     ((string= type "")
+			(list nil path))
+		     (t (list type path))))
+
+	       ;;Second pass.  Components converted so they can refer
+	       ;;to a remote site.
+	       (components-2
+		  (or
+		     (and org-html-cvt-link-fn
+			(apply org-html-cvt-link-fn 
+			   opt-plist components-1))
+		     (apply #'org-html-cvt-org-as-html 
+			opt-plist components-1)
+		     components-1))
+	       (type    (first  components-2))
+	       (thefile (second components-2)))
+
+
+	 ;;Third pass.  Build final link except for leading type
+	 ;;spec.
+	 (cond
+	    ((or
+		(not type)
+		(string= type "http")
+		(string= type "https"))
+	       (if fragment
+		  (setq thefile (concat thefile "#" fragment))))
+	       
+	    (t))
+	    
+	 ;;Final URL-build, for all types.
+	 (setq thefile 
+	    (let
+	       ((str (org-export-html-format-href thefile)))
+	       (if type
+		  (concat type ":" str)
+		  str)))
+
+	 (if (and 
+		may-inline-p
+		;;Can't inline a URL with a fragment.
+		(not fragment))
+	    (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)
@@ -1046,71 +1170,71 @@ lang=\"%s\" xml:lang=\"%s\">
 		  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 "<img src=\"" desc "\"/>")
-			     '(org-protected t))))
-	    ;; FIXME: do we need to unescape here somewhere?
 	    (cond
 	     ((equal type "internal")
-	      (setq rpl
-		    (concat
-		     "<a href=\""
-		     (if (= (string-to-char path) ?#) "" "#")
-		     (org-solidify-link-text
-		      (save-match-data (org-link-unescape path)) nil)
-		     "\"" attr ">"
-		     (org-export-html-format-desc desc)
-		     "</a>")))
+		(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 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>"))))
+				 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, 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, 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
-	      (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, can't inline as image
+		(setq rpl
+		   (org-html-make-link opt-plist
+		      type path nil
+		      desc
+		      attr
+		      nil)))
 
 	     ((string= type "coderef")
-	      (setq rpl (format "<a href=\"#coderef-%s\" class=\"coderef\" onmouseover=\"CodeHighlightOn(this, 'coderef-%s');\" onmouseout=\"CodeHighlightOff(this, 'coderef-%s');\">%s</a>"
-				path path path
-				(format (org-export-get-coderef-format path (and descp desc))
-					(cdr (assoc path org-export-code-refs))))))
-
+		(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
@@ -1118,53 +1242,56 @@ lang=\"%s\" xml:lang=\"%s\">
 		      (funcall fnc (org-link-unescape path) desc1 'html))))
 
 	     ((string= type "file")
-	      ;; FILE link
-	      (let* ((filename path)
-		     (abs-p (file-name-absolute-p filename))
-		     thefile file-is-image-p search)
+		;; FILE link
 		(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*
+		      ((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 "<i>&lt;" type ":"