emacs-orgmode@gnu.org archives
 help / color / mirror / code / Atom feed
* [RFC] Rewrite `org-entry-properties' using parser
@ 2014-07-31 23:21 Thorsten Jolitz
  2014-08-01 11:44 ` Bastien
                   ` (2 more replies)
  0 siblings, 3 replies; 13+ messages in thread
From: Thorsten Jolitz @ 2014-07-31 23:21 UTC (permalink / raw)
  To: emacs-orgmode


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

^ permalink raw reply	[flat|nested] 13+ messages in thread
end of thread, other threads:[~2014-08-21  0:17 UTC | newest]

Thread overview: 13+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2014-07-31 23:21 [RFC] Rewrite `org-entry-properties' using parser Thorsten Jolitz
2014-08-01 11:44 ` Bastien
2014-08-01 12:44   ` Thorsten Jolitz
2014-08-01 13:28 ` Nicolas Goaziou
2014-08-05 12:52   ` Thorsten Jolitz
2014-08-06  9:59     ` Rasmus
2014-08-06 12:04     ` Nicolas Goaziou
2014-08-21  0:16       ` Thorsten Jolitz
2014-08-01 18:41 ` Erik Hetzner
2014-08-03 18:59   ` John Kitchin
2014-08-04  3:45     ` Erik Hetzner
2014-08-04  4:07       ` Aaron Ecay
2014-08-04 14:11         ` Erik Hetzner

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).