Commits

Joe Bogner  committed e678a98

add parsing of special properties

  • Participants
  • Parent commits a673836

Comments (0)

Files changed (1)

 (de collectUntil (Lst Func)
   (let (Ret NIL) (find '((X) (if (Func X) T (push 'Ret X) NIL)) Lst) (reverse Ret)))
 
+(de union (Lst1 Lst2)
+   (filter prog (fish atom (list Lst1 Lst2))))
+
+(de *Org-special-props
+   ~(mapcar chop (list "ID", "TODO", "TAGS", "ALLTAGS", "CATEGORY", "PRIORITY", 
+                  "DEADLINE", "SCHEDULED", "CLOSED", "TIMESTAMP", "TIMESTAMP_IA", 
+                  "CLOCKSUM", "CLOCKSUM_T", "BLOCKED", "ITEM", "FILE")))
+
+
 (de org-parse-level (Line)
  (- (length (split (chop Line) "*")) 1))
 
 (de org-next-sibling (Level Lines)
   (seek '((Line) (= Level (org-parse-level (car Line)))) Lines))
 
+(de org-remove-header-prefix (Line)
+   (pack (cdr (diff (chop Line) "*"))))
+
+(de org-parse-special-props (Body)
+   (let (NewBody NIL 
+         Props NIL
+         Special *Org-special-props)
+      (for Line Body
+         (let (LineC (chop Line) Matched NIL)
+            (for Prop Special
+               (when (match (fish atom (list Prop ":" " " '@A)) LineC) 
+                  (setq Matched T)
+                  (push 'Props (cons (pack Prop) @A))))
+            (ifn Matched (push 'NewBody Line)))
+      (cons Props (reverse NewBody)))))
+
+(de org-parse-properties (Body)
+   (let  (PropertyStart (cdr (seek '((Line) (pre? ":PROPERTIES:" Line)) Body))
+         Properties (collectUntil PropertyStart '((Line) (pre? ":END:" Line)))
+         Props (mapcar '((X) (match '(":" @A ":" " " @B) (chop X)) (list (pack @A) (pack @B)))  Properties)
+         NewBody (if Properties (cdr (seek '((Line) (pre? ":END:" Line)) Body)) Body)
+         SpecialPropsRet (org-parse-special-props NewBody)
+         AllProps (union Props (car SpecialPropsRet))
+         NewBody (cdr SpecialPropsRet))
+   (cons AllProps NewBody)))
+
 (de org-parse-heading (Line Level Lines)
   (when (> Level 0)
-    (let (Body (org-parse-body Lines)
+    (let (AllBody (org-parse-body Lines)
+         PropertiesFunc (org-parse-properties AllBody)
+         Properties (car PropertiesFunc)
+         Body (cdr PropertiesFunc)
          Children (org-parse-children Lines Level)
-         Heading (list 'level Level 'name Line 'body Body 'children Children)
+         Header (org-remove-header-prefix Line)
+         Heading (list 'level Level 'name Header 'body Body 'props Properties 'children Children)
          NextPosition (org-next-sibling Level Lines))
      (cons Heading NextPosition))))