[O] [RFC] Rewrite `org-entry-properties' using parser

[Thorsten Jolitz]

Hi List,

here is my first take of rewriting `org-entry-properties'.

The existing function predates the new parser and some Org variables,
and thus does the parsing and the property classification itself. The
new version leaves parsing to the parser and property classification
(mostly) to existing Org variables, resulting in much simpler code. 

OTOH, the new version offers more fine-grained control over property
selection. I was a bit unhappy when the use of property-drawers as
simple key-val databases and meta-data stores for USERS was kind of
deprecated with the introduction of the new parser (in favor of usage by
the SYSTEM). This improved with introduction of the 'prop:t' export
option, and the new version of `org-entry-properties' should be powerful
and convenient enough to separate user and system data stored in the
same property-drawers.

Implementation goals were:

 1. (almost) full backward-compability. The parser upcases user
   properties, thus case-sensitivity is lost after parsing and old
   applications that rely on the difference between "foo", "Foo" and
   "FOO" as property keys will break

 2. allow retrieving all property-classes defined in Org-mode separately

 3. allow filtering out parser-specific properties

 4. allow retrieving all "non-org" properties (user and application defined)

 5. allow retrieving properties by regexp-matching, e.g. props prefixed
   with "foo_" by application 'foo'. 

I did not bother to prepare a patch yet since this should be reviewed
and tested:

 - Are some options useless?

 - Do the return values of the options make sense?

 - Is property-classification consistent (e.g. "TODO" in
   `org-special-properties', but :todo-keyword and :todo-type in the
   parse-tree)?

 - I actually reimplemented the docstring of the old function instead of
   the rather complicated code - did I get the semantics right?

 - are there bugs?

 - etc ...

Here is an Org file with the new version of `org-entry-properties',
helper functions and some 20 ERT-tests. Please have a look.


* org-entry-properties
** new function (org.el)

#+begin_src emacs-lisp
(defun org-entry-properties (&optional pom which specific)
  "Get all properties of the entry at point-or-marker POM.

This includes the TODO keyword, the tags, time strings for
deadline, scheduled, and clocking, and any additional properties
defined in the entry.  

The return value is an alist, except if WHICH has value `parser',
then a plist filtered for the properties set by
`org-element-parse-headline' is returned. Keys may occur multiple
times if the property key was used several times.  POM may also
be nil, in which case the current entry is used.

WHICH can have several meaningful values:

 - nil or `all' :: get all regular (non parser) properties

 - `special' :: get properties that are member of
   `org-special-properties'

 - `standard' :: get properties of that subclass

 - `parser' :: get properties set by parser (as plist)

 - `custom' :: get properties that are member of
   `org-custom-properties'

 - `default' :: get properties that are member of
   `org-default-properties'

 - `document' :: get properties that are member of
   `org-element-document-properties'

 - `file' :: get properties that are member of
   `org-file-properties'

 - `global' :: get properties that are member of
   `org-global-properties'

 - `global-fixed' :: get properties that are member of
   `org-global-properties-fixed'

 - `non-org' :: get properties that are not member of any of the
   preceeding classes (except `all')

 - any string :: get only exactly this property

 - form :: get properties string-matched by (rx-to-string form),
           with FORM being a regular expression in sexp form

SPECIFIC can be a string, symbol or keyword, all types will be
converted to an upcased string. It is the specific property we
are interested in. This argument only exists for historical
reasons and backward portability, since giving a string value to
WHICH has the same effect as giving a value to SPECIFIC. However,
if SPECIFIC is non-nil, it takes precedence over WHICH."
  (setq which (or which 'all))
  (org-with-wide-buffer
   (org-with-point-at pom
     (when (and (derived-mode-p 'org-mode)
                (ignore-errors (org-back-to-heading t)))
       (let ((elem (org-element-at-point)))
         (when (eq (car elem) 'headline)
           (let* ((specific-prop
                   (cond
                    ((or (org-string-nw-p specific)
                         (org-string-nw-p which))
                     (upcase
                      (or (org-string-nw-p specific)
                          (org-string-nw-p which))))
                    ((keywordp specific)
                     (car (org-split-string
                           (format "%s" specific) ":")))
                    ((and (not (booleanp specific))
                          (symbolp specific))
                     (upcase (format "%s" specific)))
                    (t nil)))
                  (props-plist (cadr elem))
                  (props-alist-strg-keys
                   (org-plist-to-alist props-plist nil t))
                  (parser-keywords
                   (list :raw-value :title :alt-title :begin :end
                         :pre-blank :post-blank :contents-begin
                         :contents-end :level :priority :tags
                         :todo-keyword :todo-type :scheduled
                         :deadline :closed :archivedp :commentedp
                         :footnote-section-p))
                  (parser-keywords-but-special-props
                   (list :raw-value :title :alt-title :begin :end
                         :pre-blank :post-blank :contents-begin
                         :contents-end :level :archivedp
                         :commentedp :footnote-section-p))
                  ;; FIXME necessary?
                  ;; for backward compability only
                  (excluded
                   '("TODO" "TAGS" "ALLTAGS" "PRIORITY" "BLOCKED"))
                  sym)
             (if specific-prop
                 (assoc specific-prop props-alist-strg-keys)
               (let ((all-but-parser
                      (progn
                        (setplist 'sym props-plist)
                        (mapc (lambda (--kw)
                                (remprop 'sym --kw))
                              parser-keywords-but-special-props)
                        (org-plist-to-alist
                         (symbol-plist 'sym) nil t)))
                     (downcased-special-props
                      (mapcar 'downcase org-special-properties)))
                 (case which
                   ('all all-but-parser)
                   ('non-org (remove-if
                              (lambda (--item)
                                (member
                                 (car --item)
                                 (append
                                  org-special-properties
                                  org-default-properties
                                  org-custom-properties
                                  org-element-document-properties
                                  org-global-properties
                                  org-global-properties-fixed
                                  org-file-properties)))
                              all-but-parser))
                   ;; FIXME necessary?
                   ;; for backward compability only
                   ('standard (remove-if
                               (lambda (--item)
                                 (member (car --item) excluded))
                                 all-but-parser))
                   ;; return plist
                   ('parser (setplist 'sym props-plist)
                            (mapc (lambda (--kw)
                                    (remprop 'sym --kw))
                                  (set-difference
                                   (org-plist-keys props-plist t)
                                   parser-keywords))
                            (symbol-plist 'sym))
                   ('special (remove-if-not
                              (lambda (--item)
                                (member
                                 (car --item)
                                 downcased-special-props))
                              props-alist-strg-keys))
                   ('default (remove-if-not
                              (lambda (--item)
                                (member (car --item)
                                        org-default-properties))
                              props-alist-strg-keys))
                   ('custom (remove-if-not
                             (lambda (--item)
                               (member (car --item)
                                       org-custom-properties))
                             props-alist-strg-keys))
                   ('document (remove-if-not
                               (lambda (--item)
                                 (member
                                  (car --item)
                                  org-element-document-properties))
                               props-alist-strg-keys))
                   ('global (remove-if-not
                             (lambda (--item)
                               (member (car --item)
                                       org-global-properties))
                             props-alist-strg-keys))
                   ('global-fixed (remove-if-not
                                   (lambda (--item)
                                     (assoc
                                      (car --item)
                                      org-global-properties-fixed))
                                   props-alist-strg-keys))
                   ('file (remove-if-not
                           (lambda (--item)
                             (member (car --item)
                                     org-file-properties))
                           props-alist-strg-keys))
                   (t (when (consp which)
                        (ignore-errors
                          (let ((rgxp (rx-to-string which)))
                            (remove-if-not
                             (lambda (--item)
                               (string-match rgxp (car --item)))
                             all-but-parser)))))))))))))))
#+end_src


** helper function (org-macs.el)

#+begin_src emacs-lisp
;; copied from kv.el
(defun org-plist-to-alist (plist &optional keys-are-keywords keys-to-string)
  "Convert PLIST to an alist.
The keys are expected to be :prefixed and the colons are removed
unless KEYS-ARE-KEYWORDS is `t'.  The keys in the resulting alist
are symbols unless KEYS-TO-STRING is non-nil."
  (when plist
    (loop for (key value . rest) on plist by 'cddr
          collect
          (cons (cond
                 (keys-are-keywords key)
                 (keys-to-string
                  (format "%s" (org-keyword-to-symbol key)))
                 (t (org-keyword-to-symbol key)))
                value))))

;; copied from kv.el
(defun org-alist-keys (alist)
  "Get just the keys from the alist."
  (mapcar (lambda (pair) (car pair)) alist))

;; copied from kv.el
(defun org-alist-values (alist)
  "Get just the values from the alist."
  (mapcar (lambda (pair) (cdr pair)) alist))

(defun org-plist-keys  (plist &optional as-keywords-p)
  "Get just the keys from the plist.
The keys are expected to be :prefixed and the colons are removed
unless AS-KEYWORDS-P is non-nil."
  (org-alist-keys
   (org-plist-to-alist plist as-keywords-p)))

(defun org-plist-values (plist)
  "Get just the values from the plist."
  (org-alist-values
   (org-plist-to-alist plist)))

;; copied from kv.el
(defun org-keyword-to-symbol (keyword)
  "A keyword is a symbol leading with a :.
Converting to a symbol means dropping the :."
  (if (keywordp keyword)
      (intern (substring (symbol-name keyword) 1))
    keyword))
#+end_src


** tests (test-org.el)


#+begin_src emacs-lisp
;;; Properties

(defconst test-org/org-entry-properties-temp-text
"* DONE [#A] headline <2014-07-31 Do> :tag:
  DEADLINE: <2014-08-01 Fr 08:00>
  - State \"DONE\"       from \"WAITING\"    [2014-07-31 Do 22:45]
  - State \"WAITING\"    from \"TODO\"       [2014-07-31 Do 14:46] \\
    testing
  :PROPERTIES:
  :CATEGORY: mycat
  :VISIBILITY_ALL: folded children all
  :foo-key1: val1
  :foo-key2: val2
  :ID:       3996b55d-d678-43a4-af1f-48ed22b5f414
  :CUSTOM_ID: abc123
  :bar:      loo
  :END:
  [2014-07-31 Do 14:45]
"
 "Headline used to test `org-entry-properties'.")

(ert-deftest test-org/org-entry-properties-1 ()
  "Test of `org-entry-properties' specifications."
  (should
  (equal '(("priority" . 65) ("tags" "tag") ("todo-keyword" . "DONE") 
("todo-type" . done) ("deadline" timestamp (:type active :raw-value 
"<2014-08-01 Fr 08:00>" :year-start 2014 :month-start 8 :day-start 1 
:hour-start 8 :minute-start 0 :year-end 2014 :month-end 8 :day-end 1 :hour-end 
8 :minute-end 0 :begin 56 :end 77 :post-blank 0)) ("CATEGORY" . "mycat") 
("VISIBILITY_ALL" . "folded children all") ("FOO-KEY1" . "val1") ("FOO-KEY2" . 
"val2") ("ID" . "3996b55d-d678-43a4-af1f-48ed22b5f414") ("CUSTOM_ID" . 
"abc123") ("BAR" . "loo"))
          (org-test-with-temp-text
              test-org/org-entry-properties-temp-text
            (org-entry-properties nil nil nil)))))


(ert-deftest test-org/org-entry-properties-2 ()
  "Test of `org-entry-properties' specifications."
  (should
   (equal '(("priority" . 65) ("tags" "tag") ("todo-keyword" . "DONE") 
("todo-type" . done) ("deadline" timestamp (:type active :raw-value 
"<2014-08-01 Fr 08:00>" :year-start 2014 :month-start 8 :day-start 1 
:hour-start 8 :minute-start 0 :year-end 2014 :month-end 8 :day-end 1 :hour-end 
8 :minute-end 0 :begin 56 :end 77 :post-blank 0)) ("CATEGORY" . "mycat") 
("VISIBILITY_ALL" . "folded children all") ("FOO-KEY1" . "val1") ("FOO-KEY2" . 
"val2") ("ID" . "3996b55d-d678-43a4-af1f-48ed22b5f414") ("CUSTOM_ID" . 
"abc123") ("BAR" . "loo"))
          (org-test-with-temp-text
              test-org/org-entry-properties-temp-text
            (org-entry-properties nil nil t)))))


(ert-deftest test-org/org-entry-properties-3 ()
  "Test 3 of `org-entry-properties' specifications."
  (should
   (equal nil
          (org-test-with-temp-text
              test-org/org-entry-properties-temp-text
            (org-entry-properties nil nil 'foo)))))


(ert-deftest test-org/org-entry-properties-4 ()
  "Test 4 of `org-entry-properties' specifications."
  (should
   (equal '("BAR" . "loo")
          (org-test-with-temp-text
              test-org/org-entry-properties-temp-text
            (org-entry-properties nil nil "bar")))))

(ert-deftest test-org/org-entry-properties-5 ()
  "Test 5 of `org-entry-properties' specifications."
  (should
   (equal '(("priority" . 65) ("tags" "tag") ("todo-keyword" . "DONE") 
("todo-type" . done) ("deadline" timestamp (:type active :raw-value 
"<2014-08-01 Fr 08:00>" :year-start 2014 :month-start 8 :day-start 1 
:hour-start 8 :minute-start 0 :year-end 2014 :month-end 8 :day-end 1 :hour-end 
8 :minute-end 0 :begin 56 :end 77 :post-blank 0)) ("CATEGORY" . "mycat") 
("VISIBILITY_ALL" . "folded children all") ("FOO-KEY1" . "val1") ("FOO-KEY2" . 
"val2") ("ID" . "3996b55d-d678-43a4-af1f-48ed22b5f414") ("CUSTOM_ID" . 
"abc123") ("BAR" . "loo"))
          (org-test-with-temp-text
              test-org/org-entry-properties-temp-text
            (org-entry-properties nil nil '(loo))))))
  
(ert-deftest test-org/org-entry-properties-6 ()
  "Test of `org-entry-properties' specifications."
  (should
   (equal nil
          (org-test-with-temp-text
              test-org/org-entry-properties-temp-text
            (org-entry-properties nil t)))))

(ert-deftest test-org/org-entry-properties-7 ()
  "Test of `org-entry-properties' specifications."
  (should
   (equal nil
          (org-test-with-temp-text
              test-org/org-entry-properties-temp-text
            (org-entry-properties nil 'foo)))))

(ert-deftest test-org/org-entry-properties-8 ()
  "Test of `org-entry-properties' specifications."
  (should
   (equal '("BAR" . "loo")
          (org-test-with-temp-text
              test-org/org-entry-properties-temp-text
            (org-entry-properties nil "bar")))))

(ert-deftest test-org/org-entry-properties-9 ()
  "Test of `org-entry-properties' specifications."
  (should
   (equal '(("priority" . 65) ("tags" "tag") ("todo-keyword" . "DONE") 
("todo-type" . done) ("deadline" timestamp (:type active :raw-value 
"<2014-08-01 Fr 08:00>" :year-start 2014 :month-start 8 :day-start 1 
:hour-start 8 :minute-start 0 :year-end 2014 :month-end 8 :day-end 1 :hour-end 
8 :minute-end 0 :begin 56 :end 77 :post-blank 0)) ("CATEGORY" . "mycat") 
("VISIBILITY_ALL" . "folded children all") ("FOO-KEY1" . "val1") ("FOO-KEY2" . 
"val2") ("ID" . "3996b55d-d678-43a4-af1f-48ed22b5f414") ("CUSTOM_ID" . 
"abc123") ("BAR" . "loo"))
          (org-test-with-temp-text
              test-org/org-entry-properties-temp-text
            (org-entry-properties nil 'all)))))

(ert-deftest test-org/org-entry-properties-10 ()
  "Test of `org-entry-properties' specifications."
  (should
   (equal '(("priority" . 65) ("tags" "tag") ("todo-keyword" . "DONE") 
("todo-type" . done) ("deadline" timestamp (:type active :raw-value 
"<2014-08-01 Fr 08:00>" :year-start 2014 :month-start 8 :day-start 1 
:hour-start 8 :minute-start 0 :year-end 2014 :month-end 8 :day-end 1 :hour-end 
8 :minute-end 0 :begin 56 :end 77 :post-blank 0)) ("VISIBILITY_ALL" . "folded 
children all") ("FOO-KEY1" . "val1") ("FOO-KEY2" . "val2") ("ID" . 
"3996b55d-d678-43a4-af1f-48ed22b5f414") ("BAR" . "loo"))
          (org-test-with-temp-text
              test-org/org-entry-properties-temp-text
            (org-entry-properties nil 'non-org)))))

(ert-deftest test-org/org-entry-properties-11 ()
  "Test of `org-entry-properties' specifications."
  (should
   (equal '(("priority" . 65) ("tags" "tag") ("todo-keyword" . "DONE") 
("todo-type" . done) ("deadline" timestamp (:type active :raw-value 
"<2014-08-01 Fr 08:00>" :year-start 2014 :month-start 8 :day-start 1 
:hour-start 8 :minute-start 0 :year-end 2014 :month-end 8 :day-end 1 :hour-end 
8 :minute-end 0 :begin 56 :end 77 :post-blank 0)) ("CATEGORY" . "mycat") 
("VISIBILITY_ALL" . "folded children all") ("FOO-KEY1" . "val1") ("FOO-KEY2" . 
"val2") ("ID" . "3996b55d-d678-43a4-af1f-48ed22b5f414") ("CUSTOM_ID" . 
"abc123") ("BAR" . "loo"))
          (org-test-with-temp-text
              test-org/org-entry-properties-temp-text
            (org-entry-properties nil 'standard)))))

(ert-deftest test-org/org-entry-properties-12 ()
  "Test of `org-entry-properties' specifications."
  (should (equal '(:raw-value "headline <2014-07-31 Do>" :begin 1 :end 448 
:pre-blank 0 :contents-begin 44 :contents-end 448 :level 1 :priority 65 :tags 
("tag") :todo-keyword "DONE" :todo-type done :deadline (timestamp (:type active 
:raw-value "<2014-08-01 Fr 08:00>" :year-start 2014 :month-start 8 :day-start 1 
:hour-start 8 :minute-start 0 :year-end 2014 :month-end 8 :day-end 1 :hour-end 
8 :minute-end 0 :begin 56 :end 77 :post-blank 0)))
                 (org-test-with-temp-text
                     test-org/org-entry-properties-temp-text
                   (org-entry-properties nil 'parser)))))

(ert-deftest test-org/org-entry-properties-13 ()
  "Test of `org-entry-properties' specifications."
  (should (equal '(("priority" . 65) ("tags" "tag") ("deadline" timestamp 
(:type active :raw-value "<2014-08-01 Fr 08:00>" :year-start 2014 :month-start 
8 :day-start 1 :hour-start 8 :minute-start 0 :year-end 2014 :month-end 8 
:day-end 1 :hour-end 8 :minute-end 0 :begin 56 :end 77 :post-blank 0)))
                 (org-test-with-temp-text
                     test-org/org-entry-properties-temp-text
                   (org-entry-properties nil 'special)))))

(ert-deftest test-org/org-entry-properties-14 ()
  "Test of `org-entry-properties' specifications."
  (should
   (equal '(("CATEGORY" . "mycat") ("CUSTOM_ID" . "abc123"))
          (org-test-with-temp-text
              test-org/org-entry-properties-temp-text
            (org-entry-properties nil 'default)))))

(ert-deftest test-org/org-entry-properties-15 ()
  "Test of `org-entry-properties' specifications."
  (should
   (equal nil
          (org-test-with-temp-text
              test-org/org-entry-properties-temp-text
            (org-entry-properties nil 'custom)))))

(ert-deftest test-org/org-entry-properties-16 ()
  "Test of `org-entry-properties' specifications."
  (should
   (equal nil
          (org-test-with-temp-text
              test-org/org-entry-properties-temp-text
            (org-entry-properties nil 'document)))))


(ert-deftest test-org/org-entry-properties-17 ()
  "Test of `org-entry-properties' specifications."
  (should
   (equal nil
          (org-test-with-temp-text
              test-org/org-entry-properties-temp-text
            (org-entry-properties nil 'global)))))

(ert-deftest test-org/org-entry-properties-18 ()
  "Test of `org-entry-properties' specifications."
  (should
   (equal '(("VISIBILITY_ALL" . "folded children all"))
          (org-test-with-temp-text
              test-org/org-entry-properties-temp-text
            (org-entry-properties nil 'global-fixed)))))


(ert-deftest test-org/org-entry-properties-19 ()
  "Test of `org-entry-properties' specifications."
  (should
   (equal nil
          (org-test-with-temp-text
              test-org/org-entry-properties-temp-text
            (org-entry-properties nil 'file)))))


(ert-deftest test-org/org-entry-properties-20 ()
  "Test of `org-entry-properties' specifications."
  (should
   (equal nil
          (org-test-with-temp-text
              test-org/org-entry-properties-temp-text
            (org-entry-properties nil '(loo))))))

(ert-deftest test-org/org-entry-properties-21 ()
  "Test of `org-entry-properties' specifications."
  (should
   (equal '(("FOO-KEY1" . "val1") ("FOO-KEY2" . "val2"))
          (org-test-with-temp-text
              test-org/org-entry-properties-temp-text
            (org-entry-properties nil '(and "foo-"))))))

#+end_src


-- 
cheers,
Thorsten