emacs-orgmode@gnu.org archives
 help / color / mirror / code / Atom feed
* org-html link building diff
@ 2010-04-18  2:13 Tom Breton (Tehom)
  2010-04-26  5:24 ` Carsten Dominik
  0 siblings, 1 reply; 16+ messages in thread
From: Tom Breton (Tehom) @ 2010-04-18  2:13 UTC (permalink / raw)
  To: Emacs-orgmode

[-- Attachment #1: Type: text/plain, Size: 894 bytes --]

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)

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: org-html.el.diff --]
[-- Type: text/x-patch; name="org-html.el.diff", Size: 9145 bytes --]

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 "&amp;", "<" and ">" by "&lt;" and "&gt;"
@@ -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>&lt;" 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)

[-- Attachment #3: Type: text/plain, Size: 201 bytes --]

_______________________________________________
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

^ permalink raw reply related	[flat|nested] 16+ messages in thread
* Re: org-html link building diff
@ 2010-04-29 22:24 Tom Breton (Tehom)
  2010-05-01 12:01 ` Carsten Dominik
  2010-05-15 12:29 ` Carsten Dominik
  0 siblings, 2 replies; 16+ messages in thread
From: Tom Breton (Tehom) @ 2010-04-29 22:24 UTC (permalink / raw)
  To: emacs-orgmode

> Hi Tom,
>
> On Apr 28, 2010, at 5:01 AM, Tom Breton (Tehom) wrote:
>
>>
>> The changes are essentially made and pass my tests now, there's mostly
housekeeping now: pull, merge, push.
>>
>>> Yes.  Send me your name on repo.or.cz and I'll add push for you.
Please create your own branch and stay on it.
>>
>> It is "Tehom".
>
> I have added you.

Oops, when I went to push, I realized that I had capitalized that but it's
apparently not capitalized on repo.or.cz.  It's "tehom".

My branch is called "tehom-master" and the branch that treats link export
based on it is called html-export-refactor-build-link

Tom Breton (Tehom)

^ permalink raw reply	[flat|nested] 16+ messages in thread

end of thread, other threads:[~2010-05-18 12:26 UTC | newest]

Thread overview: 16+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2010-04-18  2:13 org-html link building diff Tom Breton (Tehom)
2010-04-26  5:24 ` Carsten Dominik
2010-04-26 10:03   ` Sebastian Rose
2010-04-26 19:45   ` Tom Breton (Tehom)
2010-04-27  6:07     ` Carsten Dominik
2010-04-28  3:01       ` Tom Breton (Tehom)
2010-04-28 15:07         ` Carsten Dominik
  -- strict thread matches above, loose matches on Subject: below --
2010-04-29 22:24 Tom Breton (Tehom)
2010-05-01 12:01 ` Carsten Dominik
2010-05-15 12:29 ` Carsten Dominik
2010-05-15 21:37   ` Tom Breton (Tehom)
2010-05-16  5:03     ` Carsten Dominik
2010-05-18  0:59       ` Tom Breton (Tehom)
2010-05-18  4:47         ` Carsten Dominik
2010-05-18 12:26           ` Sebastian Rose
2010-05-16  5:20     ` Carsten Dominik

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs/org-mode.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).