Merge pull request #20 from mdorman/update_for_org_changes

mdorman · mdorman · commit b795ff2e2aa6 · 2013-08-24T15:48:29.000-07:00
Update for org changes
diff --git a/TODO.org b/TODO.org
@@ -1,61 +1,41 @@
+* DONE Make it so the tests only prompt for the test blog password once
+  That's the only thing that annoys me about running the tests right now.
+* DONE Convert to be compatible with the Org 8.0 exporter
+  I have no idea what will be involved---our own sub-exporter of html?
+* DONE Fix date issues once and for all
+  Added some tests to make the failure repeatable, then fixed the
+  issue.  The fix is admittedly a hack, but it would appear to be a
+  reliable one, at least until WP changes its output.
+* DONE Fix line break behavior
 * TODO Automate mirroring the post into a directory heirarchy
-
   Starting from the permalink (at least in WordPress), you could
   easily construct a filename to save under, rooted under a directory
   you specify.  We could give the option for posting to automatically
   prompt to save the file in that spot as well.
-
 * TODO Packaging for MELPA or whatever
-
   I don't use the Emacs packaging tools, so I don't really know what's
   involved.  I presume it's simple.
-
-* DONE Make it so the tests only prompt for the test blog password once
-  
-  That's the only thing that annoys me about running the tests right now.
-
 * TODO Autocompletion of categories or tags
-
   One thing I appreciated about org2blog (though it's implementation
   had some warts).
-
-* DONE Convert to be compatible with the Org 8.0 exporter
-
-  I have no idea what will be involved---our own sub-exporter of html?
-
 * TODO More testing
-
   I really want this to be rock-solid, so testing some of the more
   perverse permutations of things would be nice, to make sure they
   work as intended.
-
 * TODO More back-ends
-
   It's not that I love WordPress, really.  I would love to see other
   options supported---perhaps even static blogging options.  I think
   I've kept things sufficiently open to allow that.
-
 * TODO More idiomatic, better code
-
   It's my first Emacs project, what do you expect?
-
 * TODO A customize interface
-
   I don't use it myself, really, but it would be a very nice thing.
   I'm fairly certain that everything necessary could be done that way,
   so it would be mighty cool.
-
 * TODO More automation for setup
-
   It should be possible, in theory, to be given the URL of a blog
   (true for WP, and I imagine for others) and have it autodiscover the
   posting interface, prompt for username and password, and retrieve
   whatever else it needs and then save it somewhere for the user to
   use.  Gets around the =:blog-id= sort of stuff, or even having to
   know about =xmlrpc.php=.
-
-* DONE Fix date issues once and for all
-  Added some tests to make the failure repeatable, then fixed the
-  issue.  The fix is admittedly a hack, but it would appear to be a
-  reliable one, at least until WP changes its output.
-* DONE Fix line break behavior
diff --git a/acceptance b/acceptance
@@ -1,3 +1,3 @@
 #!/bin/sh -e
-IFS= read -r -p 'Please enter blog password: ' PASSWORD
-exec emacs -nw -Q -L /usr/share/emacs/site-lisp/org-mode -L . -l ert -l org-blog --eval '(setq xml-rpc-debug 10)' --eval "(setq org-blog-test-password \"${PASSWORD}\")" --eval '(ert t)'
+exec emacs -nw -Q -L /usr/share/emacs/site-lisp/org-mode -L . -l org-blog -l ert --eval "(setq org-blog-test-password \"${PASSWORD}\")" --eval '(setq xml-rpc-debug 10)' --eval '(setq stack-trace-on-error t)' --eval '(ert t)'
+
diff --git a/org-blog-buffer.el b/org-blog-buffer.el
@@ -23,28 +23,24 @@
 (provide 'org-blog-buffer)
 
 (require 'org)
+(require 'org-blog)
 (require 'ox)
 (require 'ox-html)
-(require 'org-blog)
 
 (eval-when-compile
   (require 'cl))
 
 (defconst org-blog-buffer-options-alist
   (reduce
    (lambda (l i)
-     (let ((field (plist-get (cdr i) :attr)))
+     (let ((field (plist-get (cdr i) :to-buffer)))
+       ;; Only add our fields, distinguised by the POST_ prefix
        (if (string-prefix-p "POST_" field t)
            (cons (list (car i) field nil nil t) l)
          l)))
    org-blog-post-mapping
    :initial-value nil))
 
-(org-export-define-derived-backend 'blog 'html
-  :filters-alist '((:filter-final-output . org-blog-filter-tag-newline)
-                   (:filter-plain-text . org-blog-filter-text-newlines))
-  :options-alist org-blog-buffer-options-alist)
-
 ;;; Filters
 (defun org-blog-filter-tag-newline (content backend info)
   "Remove superfluous leading space and trailing newlines from tags
@@ -53,26 +49,38 @@ TREE is the parse tree being exported.  BACKEND is the export
 back-end used.  INFO is a plist used as a communication channel.
 
 Assume BACKEND is `blog'."
-  ;; (print (format "content is: %s" content))
   ;; <tag>, </tag>, <tag/>, (replace-regexp-in-string "\\(<\\([[:alpha:]]+\\|/[[:alpha:]]+\\|[[:alpha:]]+/\\)>\\)\n+" "\\1" content)
   (replace-regexp-in-string "\s*\\(<[^>]+>\\)\n+" "\\1" content))
 
-;;; Filters
 (defun org-blog-filter-text-newlines (content backend info)
   "Remove superfluous newlines in elements (except verse blocks)
 
 TREE is the parse tree being exported.  BACKEND is the export
 back-end used.  INFO is a plist used as a communication channel.
 
 Assume BACKEND is `blog'."
-  ;; (print (format "content is: %s" content))
-  (print (format "parent is %s" (org-export-get-parent content)))
   (cond ((eq 'verse-block (car (org-export-get-parent content)))
-         (print "in verse")
          content)
         (t
          (replace-regexp-in-string "\n" " " content))))
 
+(defun org-blog-translate-link (link content info)
+  "Fixup links"
+  (let ((type (org-element-property :type link)))
+    (cond ((member type '("custom-id" "id"))
+           (let ((destination (org-export-resolve-id-link link info)))
+             (format "<a href=\"%s\">%s</a>" destination contents)))
+          ((equal type "fuzzy")
+           ;; This is not ideal
+           (let ((destination (org-element-property :path link)))
+             (format "<a href=\"%s\">%s</a>" destination contents))))))
+
+(org-export-define-derived-backend 'blog 'html
+  :filters-alist '((:filter-final-output . org-blog-filter-tag-newline)
+                   (:filter-plain-text . org-blog-filter-text-newlines))
+  :options-alist org-blog-buffer-options-alist
+  :translate-alist '((link . org-blog-translate-link)))
+
 (defun org-blog-buffer-extract-post ()
   "Transform a buffer into a post.
 
@@ -89,12 +97,16 @@ retain the maximum flexibility for further transformation."
     (sort
      (reduce
       (lambda (l i)
-        (let ((v (plist-get attrs (car i)))
-              (filter (plist-get (cdr i) :from-buffer)))
-          (if v
-              (cons (cons (car i) (if filter
-                                      (funcall filter v attrs)
-                                    v)) l)
+        (let* ((v (plist-get attrs (car i)))
+               (filter (plist-get (cdr i) :from-buffer))
+               (value (if (and v
+                               (not (= 0 (length v))))
+                          (if filter
+                              (funcall filter v attrs)
+                            v))))
+          ;; We should only cons if there's a v and the output of the filter is non-nil
+          (if value
+              (cons (cons (car i) value) l)
             l)))
       org-blog-post-mapping
       :initial-value (when content
@@ -111,6 +123,7 @@ update the buffer to reflect the values it contains."
     (save-restriction
       ;; Get the current values
       (let ((current (org-blog-buffer-extract-post)))
+        ;; Iterate over the stuff to merge in
         (mapc
          (lambda (item)
            (let ((k (car item))
@@ -129,16 +142,24 @@ update the buffer to reflect the values it contains."
                                 "default")))
                (goto-char (point-min))
                (cond
-                ;; Inserting a new keyword
+                ;; No existing value associated with keyword
                 ((eq (cdr (assq k current)) nil)
                  (when val
-                   (insert (concat "#+" (plist-get (cdr (assq k org-blog-post-mapping)) :attr) ": " val "\n"))))
-                ;; Updating an existing keyword
+                   (insert (concat "#+" (plist-get (cdr (assq k org-blog-post-mapping)) :to-buffer) ": " val "\n"))))
+                ;; Existing value associated with keyword does not match new value
                 ((not (equal (cdr (assq k current)) val))
-                 (let ((re (org-make-options-regexp (list (plist-get (cdr (assq k org-blog-post-mapping)) :attr)) nil))
+                 ;; Prepare to search for the keyword
+                 (let ((re (org-make-options-regexp (list (plist-get (cdr (assq k org-blog-post-mapping)) :to-buffer)) nil))
                        (case-fold-search t))
-                   (re-search-forward re nil t)
-                   (replace-match (concat "#+" (plist-get (cdr (assq k org-blog-post-mapping)) :attr) ": " val) t t)))))))
+                   (cond
+                    ;; If it was found
+                    ((re-search-forward re nil t)
+                     (message "Updating existing value with %s" val)
+                     (replace-match (concat "#+" (plist-get (cdr (assq k org-blog-post-mapping)) :to-buffer) ": " val) t t)
+                     (message "Done replacing value"))
+                    ;; It was not found
+                    (val
+                     (insert (concat "#+" (plist-get (cdr (assq k org-blog-post-mapping)) :to-buffer) ": " val "\n"))))))))))
          ;; Reverse sort fields to insert alphabetically
          (sort
           (copy-alist merge)
@@ -176,10 +197,12 @@ retain
 its line
 breaks
 #+END_VERSE
+
+[[org-blog-buffer.el][There's a link in here, too]]
 ")
             (post-struct '((:blog . "t1b")
                            (:category "t1c1" "t1c2")
-                           (:content . "<p>Just a little bit of content. There is still part of the paragraph.  Line breaks are refolded.</p><p class=\"verse\">Though the material in verse should<br/>retain<br/>its line<br/>breaks<br/></p>")
+                           (:content . "<p>Just a little bit of content. There is still part of the paragraph.  Line breaks are refolded.</p><p class=\"verse\">Though the material in verse should<br/>retain<br/>its line<br/>breaks<br/></p><p><a href=\"org-blog-buffer.el\">There's a link in here, too</a></p>")
                            (:date 20738 4432)
                            (:description . "t1e")
                            (:id . "1")
diff --git a/org-blog-wp.el b/org-blog-wp.el
@@ -184,14 +184,13 @@ function to make other calls."
                                                      ((equal (length userblogs) 1)
                                                       (setcdr (assq :xmlrpc complete) (cdr (assoc "xmlrpc" (car userblogs))))
                                                       (cdr (assoc "blogid" (car userblogs))))
-                                                     ;; FIXME: Prompt the user from the list of blogs (if there's more than 1
-                                                     ;; Then shove the blog info into complete
+                                                     ;; If there's mroe than one blog, ask the user to choose from them
                                                      (t
                                                       (reduce
-                                                       (lambda (entry)
-                                                         (when (string= (cdr (assoc "blogName" entry)))
-                                                           (setcdr (assq :xmlrpc complete) (cdr (assoc "xmlrpc" userblog)))
-                                                           (cdr (assoc "blogid" userblog))))
+                                                       (lambda (chosen entry)
+                                                         (when (string= (cdr (assoc "blogName" result)) (cdr (assoc "blogName" entry)))
+                                                           (setcdr (assq :xmlrpc complete) (cdr (assoc "xmlrpc" entry)))
+                                                           (cdr (assoc "blogid" entry))))
                                                        userblogs
                                                        :initial-value (completing-read
                                                                        "Blog Name: "
diff --git a/org-blog.el b/org-blog.el
@@ -55,26 +55,48 @@ Each loaded back-end should add its name to the list.")
 (defun org-blog-property-strip (v i)
   "Strip properties from a property string."
   (when v
-    (set-text-properties 0 (length v) nil v)
-    v))
+    ;; If we got a list, only do the head
+    (when (listp v)
+      (message "Saw list value for %s" v)
+      (setq v (car v)))
+    ;; (message "Setting text properties on %s" v)
+    (let ((clean (substring-no-properties v)))
+      ;; (message "Doing string match on %s" v)
+      (unless (string-match "^\s*$" clean)
+        ;; (message "Found non-whitespace characters")
+        clean))))
 
 (defun org-blog-date-format (v i)
   "Properly format a date."
-  (date-to-time
-   (org-export-get-date i "%Y%m%dT%T%z")))
-
-(defconst org-blog-post-mapping '((:blog :attr "POST_BLOG" :from-buffer org-blog-property-strip)
-                                  (:category :attr "POST_CATEGORY" :from-buffer org-blog-property-split)
-                                  (:date :attr "DATE" :from-buffer org-blog-date-format)
-                                  (:description :attr "DESCRIPTION" :from-buffer org-blog-property-strip)
-                                  (:id :attr "POST_ID" :from-buffer org-blog-property-strip)
-                                  (:keywords :attr "KEYWORDS" :from-buffer org-blog-property-split)
-                                  (:link :attr "POST_LINK" :from-buffer org-blog-property-strip)
-                                  (:name :attr "POST_NAME" :from-buffer org-blog-property-strip)
-                                  (:parent :attr "POST_PARENT" :from-buffer org-blog-property-strip)
-                                  (:status :attr "POST_STATUS" :from-buffer org-blog-property-strip)
-                                  (:title :attr "TITLE" :from-buffer (lambda (v i) (org-blog-property-strip (car v) i)))
-                                  (:type :attr "POST_TYPE" :from-buffer org-blog-property-strip)))
+  (when v
+    (date-to-time
+     (org-export-get-date i "%Y%m%dT%T%z"))))
+
+(defun org-blog-title-format (value info)
+  "Properly format a title."
+  (let ((default (or (let ((visited-file (buffer-file-name (buffer-base-buffer))))
+		   (and visited-file
+			(file-name-sans-extension
+			 (file-name-nondirectory visited-file))))
+		 (buffer-name (buffer-base-buffer))))
+        (val (org-element-interpret-data (plist-get info :title) info)))
+    (cond ((equal default val)
+           nil)
+          (t
+           val))))
+
+(defconst org-blog-post-mapping '((:blog :to-buffer "POST_BLOG" :from-buffer org-blog-property-strip)
+                                  (:category :to-buffer "POST_CATEGORY" :from-buffer org-blog-property-split)
+                                  (:date :to-buffer "DATE" :from-buffer org-blog-date-format)
+                                  (:description :to-buffer "DESCRIPTION" :from-buffer org-blog-property-strip)
+                                  (:id :to-buffer "POST_ID" :from-buffer org-blog-property-strip)
+                                  (:keywords :to-buffer "KEYWORDS" :from-buffer org-blog-property-split)
+                                  (:link :to-buffer "POST_LINK" :from-buffer org-blog-property-strip)
+                                  (:name :to-buffer "POST_NAME" :from-buffer org-blog-property-strip)
+                                  (:parent :to-buffer "POST_PARENT" :from-buffer org-blog-property-strip)
+                                  (:status :to-buffer "POST_STATUS" :from-buffer org-blog-property-strip)
+                                  (:title :to-buffer "TITLE" :from-buffer org-blog-title-format)
+                                  (:type :to-buffer "POST_TYPE" :from-buffer org-blog-property-strip)))
 
 (require 'org-blog-buffer)
 (require 'org-blog-wp)
