[cl-org-mode-devel] [PATCH] * src/cl-org-mode.lisp: Added support for link format.

[Ryo TAKAISHI]

It can parse "[[link]]" and "[[link][description]]".
---
 src/cl-org-mode.lisp |   60 ++++++++++++++++++++++++++++++++++++++++++++++++-
 1 files changed, 58 insertions(+), 2 deletions(-)

diff --git a/src/cl-org-mode.lisp b/src/cl-org-mode.lisp
index b24fdfc..653105f 100644
--- a/src/cl-org-mode.lisp
+++ b/src/cl-org-mode.lisp
@@ -11,7 +11,10 @@
 
 (defmethod node-dispatchers ((node org-node))
   (or *dispatchers* 
-      (mapcar #'make-instance '(src-node properties-node outline-node))))
+      (mapcar #'make-instance '(link-node
+                                src-node
+                                properties-node
+                                outline-node))))
 
 (defmethod node-prototypes (node)
   (error "never call"))
@@ -246,4 +249,57 @@ then stick it in the default node"
 		 (and (typep n 'property-node)
 		      (equal (property-node.property n) key)))
 	       (node.children node))))
-    (when node (property-node.value node))))
\ No newline at end of file
+    (when node (property-node.value node))))
+
+
+(defclass link-node (org-parent-node) 
+     ((link :accessor node.link :initform nil :initarg :link)
+      (description :accessor node.description :initform nil :initarg :description)))
+
+(defun at-link-node-p (stack)
+  (let ((char (first stack))
+        (stack (rest stack)))
+    (and (eql char #\[)
+         (eql (first stack) #\[)
+         (if (or (null (rest stack))
+                 (second stack))
+             (values t (rest stack))
+             (at-link-node-p (cons char (rest stack)))))))
+
+(defmethod node-start ((node link-node) stack)
+  (multiple-value-bind (pred old-stack) 
+      (at-link-node-p stack)
+    (if pred 
+        (values  
+         (make-instance (class-of node))
+         old-stack))))
+
+(defmethod node-end ((node link-node) (next-node link-node) stack)
+  T)
+
+(defmethod node-end ((node link-node) (next-node text-node) stack)
+  T)
+
+(defmethod finalize-node ((node link-node) next-node stack)
+  (setf (node.next-node node)
+        (if stack
+            (make-default-node node next-node stack)
+            next-node)))
+
+(defmethod read-next-node ((node link-node) (next-node null) stream)
+  (let (text c)
+    (loop for char = (read-char stream nil)
+          :if (and (eql #\] char)
+                   (eql #\] (car text)))
+          :do (if (eql (node.link node) nil)
+                  (setf (node.link node) (stack->string (cdr text)))
+                  (setf (node.description node) (stack->string (cdr text))))
+              (return)
+          :if (and (eql #\[ char)
+                   (eql #\] (car text)))
+          :do (setf (node.link node) (stack->string (cdr text)))
+          (setf text nil)          
+          :else
+          :do ;;(unread-char c stream)
+              (push char text))
+    (call-next-method)))
-- 
1.7.8.rc1