Ignore the patches in that last email, (but please do address some of the concerns I had about the number of `:any` outputs).
Anyway, I finally did it - I got it to work. Every single patch now pasts tests. Please review these patches and *not the patches in the last email*. (Apologies for the frequency of my emails today) Best, Mehmet
From 020992b46b5a7c2ae18c677afb5c29c00de58059 Mon Sep 17 00:00:00 2001 From: Mehmet Tekman <mtekma...@gmail.com> Date: Tue, 1 Aug 2023 05:14:46 +0200 Subject: [PATCH 1/3] * testing/lisp/test-ob.el: New tests for merge-params (test-ob/get-src-block-property): (test-ob/merge-params): add new tests for the merge-params source block header handling function. (test-ob/merge-params-tangle): add new tests for tangle specific headers. --- testing/lisp/test-ob.el | 146 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 146 insertions(+) diff --git a/testing/lisp/test-ob.el b/testing/lisp/test-ob.el index c8dbd44f4..460afbf9b 100644 --- a/testing/lisp/test-ob.el +++ b/testing/lisp/test-ob.el @@ -314,6 +314,152 @@ this is simple" (org-babel-next-src-block) (should (= 14 (org-babel-execute-src-block))))) +(defun test-ob/get-src-block-property (properties) + "Get plist of PROPERTIES and values for the first src block in buffer. +PROPERTIES is a list of property keywords or a single keyword." + (org-with-wide-buffer + (goto-char (point-min)) + (org-babel-next-src-block) + (org-set-regexps-and-options) + (let ((all-props (nth 2 (org-babel-get-src-block-info)))) + (if (listp properties) + (apply #'nconc (mapcar (lambda (p) (list p (cdr (assoc p all-props)))) properties)) + (list properties (cdr (assoc properties all-props))))))) + +(ert-deftest test-ob/merge-params() + "Test the output of merging multiple header parameters." + (should + (equal '(:file-mode "#o755") + (org-test-with-temp-text + "\ +#+PROPERTY: header-args :file-mode #o755 +* One +#+begin_src conf +#+end_src" + (test-ob/get-src-block-property :file-mode)))) + (should + (equal '(:file-mode "anything" :exports "both") + (org-test-with-temp-text + "\ +#+PROPERTY: header-args :file-mode #o755 :exports both +* One +#+begin_src conf :file-mode anything +#+end_src" + (test-ob/get-src-block-property '(:file-mode :exports))))) + (should + (equal '(:mkdirp "no" :dir nil :padline "yes") + (org-test-with-temp-text + "\ +#+PROPERTY: header-args :dir /tmp/ :padline no +* One +:PROPERTIES: +:header-args: :mkdirp no +:END: +#+begin_src conf :padline yes +#+end_src" + (test-ob/get-src-block-property '(:mkdirp :dir :padline))))) + (should + (equal '(:results "value code replace file" :file "file") + (org-test-with-temp-text + "\ +#+PROPERTY: header-args :results file :file file +* One +#+begin_src conf :results code value +#+end_src" + (test-ob/get-src-block-property '(:results :file))))) + (should + (equal '(:results "value html silent") + (org-test-with-temp-text + "\ +#+PROPERTY: header-args :results file +* One +:PROPERTIES: +:header-args: :results html silent +:END: +#+begin_src conf :results value +#+end_src" + (test-ob/get-src-block-property :results))))) + +(ert-deftest test-ob/merge-params-tangle() + "Test the output of merging multiple header parameters." + (should + (equal '(:tangle "/tmp/default_tangle.txt") + (org-test-with-temp-text + "\ +#+PROPERTY: header-args :tangle /tmp/default_tangle.txt +* One +#+begin_src conf +#+end_src" + (test-ob/get-src-block-property :tangle)))) + (should ;; 2. inherit-document-header-with-local-sync-action + (equal '(:tangle "skip") + (org-test-with-temp-text + "\ +#+PROPERTY: header-args :tangle /tmp/default_tangle.txt +* Two +#+begin_src conf :tangle skip +#+end_src" + (test-ob/get-src-block-property :tangle)))) + (should + (equal '(:tangle "randomfile") + (org-test-with-temp-text + "\ +#+PROPERTY: header-args :tangle /tmp/default_tangle.txt +* Three +#+begin_src conf :tangle randomfile +#+end_src" + (test-ob/get-src-block-property :tangle)))) + (should + (equal '(:tangle "newfile.txt") + (org-test-with-temp-text + "\ +#+PROPERTY: header-args :tangle /tmp/default_tangle.txt +* Four +:PROPERTIES: +:header-args: :tangle \"newfile.txt\" +:END: +** A +#+begin_src conf +#+end_src" + (test-ob/get-src-block-property :tangle)))) + (should + (equal '(:tangle "./headfile.txt") + (org-test-with-temp-text + "\ +#+PROPERTY: header-args :tangle ./headfile.txt +* Five +:PROPERTIES: +:header-args: :tangle ./headfile.txt +:END: +** A +#+begin_src conf +#+end_src" + (test-ob/get-src-block-property :tangle)))) + (should + (equal '(:tangle "yes") + (org-test-with-temp-text + "\ +#+PROPERTY: header-args :tangle /tmp/default_tangle.txt +* Eleven +:PROPERTIES: +:header-args: :tangle \"foo.txt\" +:END: +#+begin_src conf :tangle yes +#+end_src" + (test-ob/get-src-block-property :tangle)))) + (should + (equal '(:tangle "file with spaces.txt") + (org-test-with-temp-text + "\ +* Twelve +:PROPERTIES: +:header-args: :tangle \"foo.txt\" +:END: +** A +#+begin_src conf :tangle \"file with spaces.txt\" +#+end_src" + (test-ob/get-src-block-property :tangle))))) + (ert-deftest test-ob/inline-src-blocks () (should (= 1 -- 2.41.0
From 033c5ef74f54c1a83a9f3de2590700d852b9a344 Mon Sep 17 00:00:00 2001 From: Mehmet Tekman <mtekma...@gmail.com> Date: Fri, 4 Aug 2023 18:17:34 +0200 Subject: [PATCH 3/3] * lisp/ob-core.el: (org-babel-common-header-args-w-values): Added mutually exclusive tangle groups relating to desired tangle sync actions * testing/lisp/test-ob.el: (test-ob/merge-params-tangle): Updated test function to take into account the new headers --- lisp/ob-core.el | 3 +- testing/lisp/test-ob.el | 133 +++++++++++++++++++++++++++++++++++++--- 2 files changed, 127 insertions(+), 9 deletions(-) diff --git a/lisp/ob-core.el b/lisp/ob-core.el index cd6c6708c..f09540f18 100644 --- a/lisp/ob-core.el +++ b/lisp/ob-core.el @@ -441,7 +441,8 @@ then run `org-babel-switch-to-session'." (sep . :any) (session . :any) (shebang . :any) - (tangle . ((tangle yes no :any))) + (tangle . ((tangle yes no :any) + (import export skip sync))) (tangle-mode . ((#o755 #o555 #o444 :any))) (var . :any) (wrap . :any)) diff --git a/testing/lisp/test-ob.el b/testing/lisp/test-ob.el index 48cb60e10..60f385663 100644 --- a/testing/lisp/test-ob.el +++ b/testing/lisp/test-ob.el @@ -382,7 +382,7 @@ PROPERTIES is a list of property keywords or a single keyword." (ert-deftest test-ob/merge-params-tangle() "Test the output of merging multiple header parameters." - (should + (should ;; 1. inherit-document-header-args (equal '(:tangle "/tmp/default_tangle.txt") (org-test-with-temp-text "\ @@ -391,8 +391,8 @@ PROPERTIES is a list of property keywords or a single keyword." #+begin_src conf #+end_src" (test-ob/get-src-block-property :tangle)))) - (should ;; 2. inherit-document-header-with-local-sync-action - (equal '(:tangle "skip") + (should ;; 2. inherit-document-header + (equal '(:tangle "/tmp/default_tangle.txt skip") (org-test-with-temp-text "\ #+PROPERTY: header-args :tangle /tmp/default_tangle.txt @@ -400,7 +400,7 @@ PROPERTIES is a list of property keywords or a single keyword." #+begin_src conf :tangle skip #+end_src" (test-ob/get-src-block-property :tangle)))) - (should + (should ;; 3. override-document-header-with-local-tfile (equal '(:tangle "randomfile") (org-test-with-temp-text "\ @@ -409,7 +409,16 @@ PROPERTIES is a list of property keywords or a single keyword." #+begin_src conf :tangle randomfile #+end_src" (test-ob/get-src-block-property :tangle)))) - (should + (should ;; 3b. override-document-header-with-local-tfile-sync + (equal '(:tangle "randomfile sync") + (org-test-with-temp-text + "\ +#+PROPERTY: header-args :tangle /tmp/default_tangle.txt +* ThreeA +#+begin_src conf :tangle randomfile sync +#+end_src" + (test-ob/get-src-block-property :tangle)))) + (should ;; 4. override-document-and-parent-header-with-local-tfile (equal '(:tangle "newfile.txt") (org-test-with-temp-text "\ @@ -422,7 +431,20 @@ PROPERTIES is a list of property keywords or a single keyword." #+begin_src conf #+end_src" (test-ob/get-src-block-property :tangle)))) - (should + (should ;; 4a. override-document-and-parent-header-with-local-tfile-action + (equal '(:tangle "randomfile sync") + (org-test-with-temp-text + "\ +#+PROPERTY: header-args :tangle /tmp/default_tangle.txt +* Four +:PROPERTIES: +:header-args: :tangle \"newfile.txt\" import +:END: +** A +#+begin_src conf :tangle randomfile sync +#+end_src" + (test-ob/get-src-block-property :tangle)))) + (should ;; 5. tangle-file-name-duplicate (equal '(:tangle "./headfile.txt") (org-test-with-temp-text "\ @@ -435,7 +457,63 @@ PROPERTIES is a list of property keywords or a single keyword." #+begin_src conf #+end_src" (test-ob/get-src-block-property :tangle)))) - (should + (should ;; 5a. test-tangle-and-default-results-param-together + (equal '(:tangle "randomfile" :results "replace") + (org-test-with-temp-text + "\ +* FiveA +#+begin_src conf :tangle randomfile +#+end_src" + (test-ob/get-src-block-property '(:tangle :results))))) + (should ;; 6. inherit-document-tfile-take-only-last-local-sync-action + (equal '(:tangle "/tmp/default_tangle.txt export") + (org-test-with-temp-text + "\ +#+PROPERTY: header-args :tangle /tmp/default_tangle.txt +* Six +#+begin_src conf :tangle import export +#+end_src" + (test-ob/get-src-block-property :tangle)))) + (should ;; 7. ignore-document-header-take-last-tfile-and-sync-action + ;; This should pass with newer merge function with multiple tangle parameters + (equal '(:tangle "fname2 export") + (org-test-with-temp-text + "\ +#+PROPERTY: header-args :tangle /tmp/default_tangle.txt +* Seven +#+begin_src conf :tangle fname1 fname2 sync export +#+end_src" + (test-ob/get-src-block-property :tangle)))) + (should ;; 8. test-results-and-exports + (equal '(:results "wrap file replace" :exports "code") + (org-test-with-temp-text + "\ +* Eight +#+begin_src sh :results file wrap +#+end_src" + (test-ob/get-src-block-property '(:results :exports))))) + (should ;; 9. do-not-tangle-this-block -- + (equal '(:tangle "no") + (org-test-with-temp-text + "\ +#+PROPERTY: header-args :tangle /tmp/default_tangle.txt +* Nine +#+begin_src conf :tangle no +#+end_src" + (test-ob/get-src-block-property :tangle)))) + (should ;; 10. test-tangle-exports-and-comments + (equal '(:tangle "foo.txt" :exports "verbatim code" :comments "link") + (org-test-with-temp-text + "\ +#+PROPERTY: header-args :tangle /tmp/default_tangle.txt +* Ten +:PROPERTIES: +:header-args: :tangle no :exports verbatim +:END: +#+begin_src conf :tangle \"foo.txt\" :comments link +#+end_src" + (test-ob/get-src-block-property '(:tangle :exports :comments))))) + (should ;; 11. override-document-and-heading-tfile-with-yes (equal '(:tangle "yes") (org-test-with-temp-text "\ @@ -447,7 +525,7 @@ PROPERTIES is a list of property keywords or a single keyword." #+begin_src conf :tangle yes #+end_src" (test-ob/get-src-block-property :tangle)))) - (should + (should ;; 12. simple-file-with-space (equal '(:tangle "file with spaces.txt") (org-test-with-temp-text "\ @@ -457,9 +535,48 @@ PROPERTIES is a list of property keywords or a single keyword." :END: ** A #+begin_src conf :tangle \"file with spaces.txt\" +#+end_src" + (test-ob/get-src-block-property :tangle)))) + (should ;; 12a. simple-file-with-spaces-action + (equal '(:tangle "file with spaces.txt import") + (org-test-with-temp-text "\ +#+PROPERTY: header-args :tangle \"file with spaces.txt\" sync +* TwelveA +#+begin_src conf :tangle import +#+end_src" + (test-ob/get-src-block-property :tangle)))) + (should ;; 13. hierarchical-tangle-file-with-spaces + (equal '(:tangle "file with spaces.txt") + (org-test-with-temp-text + "\ +* Thirteen +:PROPERTIES: +:header-args: :tangle \"foo.txt\" +:END: +** A +#+begin_src conf :tangle \"file with spaces.txt\" +#+end_src" + (test-ob/get-src-block-property :tangle)))) + (should ;; 14. do-not-tangle + (equal '(:tangle "no") + (org-test-with-temp-text + "\ +#+PROPERTY: header-args :tangle /tmp/default_tangle.txt +* Fourteen +#+begin_src emacs-lisp :tangle no +#+end_src" + (test-ob/get-src-block-property :tangle)))) + (should ;; 15. headers-dont-cancel-out + (equal '(:tangle "relative.el") + (org-test-with-temp-text + "\ +#+PROPERTY: header-args :tangle relative.el +* Fifteen +#+begin_src emacs-lisp :tangle relative.el #+end_src" (test-ob/get-src-block-property :tangle))))) + (ert-deftest test-ob/inline-src-blocks () (should (= 1 -- 2.41.0
From 1866c082547f75f38e221117e4eff2f0124d69f7 Mon Sep 17 00:00:00 2001 From: Mehmet Tekman <mtekma...@gmail.com> Date: Wed, 10 May 2023 17:38:22 +0200 Subject: [PATCH 2/3] * lisp/ob-core.el: Rewrite of merge babel headers (org-babel-merge-params): merge headers strategy split out into new dedicated function `--merge-headers' (org-babel--merge-headers): new function that resolves headers based on their mutually exclusive groups, with better support for groups with `:any' keywords. * lisp/test-ob.el (test-ob/merge-params): Very minor test value update due to rewrite --- lisp/ob-core.el | 154 +++++++++++++++++++++++++++++++--------- testing/lisp/test-ob.el | 4 +- 2 files changed, 123 insertions(+), 35 deletions(-) diff --git a/lisp/ob-core.el b/lisp/ob-core.el index fb9df80c3..cd6c6708c 100644 --- a/lisp/ob-core.el +++ b/lisp/ob-core.el @@ -2843,6 +2843,88 @@ specified as an an \"attachment:\" style link." (goto-char body-start) (insert body)))) +(defun org-babel--merge-headers (exclusive-groups &rest related-params) + "Merge related cascading header parameters whilst upholding group exclusivity. + +A given header parameter (prop) can have multiple values +depending on where it is referenced in the outline path (olp) of +an Org document. The RELATED-PARAMS argument is a list that +contains the value of the prop at the current level of the olp, +as well the resolution of the last time this function was called +for the prop. The EXCLUSIVE-GROUPS argument contains the related +prop entry from `org-babel-common-header-args-w-values' and +dictates the valid values a prop can take. If the prop can have +more than one value, it defines consistent mutually exclusive +keywords that the prop can take." + ;; + ;; Having an :any keyword in an exclusion group means that a + ;; parameter of "yes" could match to an exclusion group that + ;; contains both "yes" AND ":any". + ;; + ;; For each parameter, build a list of exclusion groups it could + ;; belong to. If a parameter belongs to two groups, eliminate it + ;; from the group that contains the ":any" keyword. + ;; + ;; Exclusion groups are referenced to by their car, acting as a key + ;; for the entire group. + ;; + (let ((any-group-key ;; exclusion group key for group with :any keyword + ;; Ihor: cl-find is suggested here, but not sure how to apply. + (caar (cl-remove-if-not (lambda (x) (member ":any" x)) exclusive-groups))) + params-alist ;; param -> list( exclusion group keys ) + unexplained-params) ;; any params that were not caught + ;; Iterate parameters, across each exclusion group. + ;; - Populate params-alist + (dolist (new-params related-params) + (dolist (new-param new-params) + (dolist (exclusive-group exclusive-groups) + (if (or (member new-param exclusive-group) + (and (string= (car exclusive-group) any-group-key) + ;; param *doesn't* match a keyword in this + ;; :any group? Could be :any. + (not (member new-param exclusive-group)))) + (let ((group-key (car exclusive-group))) + (push group-key (alist-get new-param params-alist nil nil #'equal))) + ;; Some parameters fit into no groups, store them and process later. + (push new-param unexplained-params))))) + + (setq unexplained-params (delete-dups unexplained-params)) + ;; Find parameters listed in 2 or more exclusive groups, and kick + ;; them out of any non-":any" group. + ;; - Update params-alist + ;; - Remove uniquely known params from unexplained-params + (dolist (parm-vals params-alist) + (let ((parm (car parm-vals)) + (group-keys (delete-dups (cdr parm-vals)))) + (if (member parm unexplained-params) + (setq unexplained-params (delete parm unexplained-params))) + (if (> (length group-keys) 1) + (dolist (gkey group-keys) + (if (string= gkey any-group-key) + (setcdr (assoc parm params-alist) (delete gkey group-keys))))))) + ;; Collapse parameters into exclusion groups + ;; - convert params → list(exclusion group keys) to exclusion-group-key → list(params) + (let (group-alist) + (mapcar (lambda (x) + (let* ((key (cadr x)) + (val (car x)) + (existing (cdr (assoc key group-alist)))) + ;;(push val (alist-get key group-alist nil nil #'equal)) + (if existing + (setcdr (assoc key group-alist) (append existing (list val))) + (setq group-alist (cons (cons key (list val)) group-alist))))) + params-alist) + ;; Set values in the same order that the exclusion groups are defined + (let ((group-key-order (mapcar #'car exclusive-groups))) + (setq group-alist (delq nil (mapcar (lambda (x) (car (alist-get x group-alist))) + group-key-order)))) + + ;; Final Sanity Check: were all parameters explained? + ;; - if not, append to result + (if unexplained-params + (setq group-alist (append unexplained-params group-alist))) + group-alist))) + (defun org-babel-merge-params (&rest plists) "Combine all parameter association lists in PLISTS. Later elements of PLISTS override the values of previous elements. @@ -2854,26 +2936,15 @@ parameters when merging lists." (exports-exclusive-groups (mapcar (lambda (group) (mapcar #'symbol-name group)) (cdr (assq 'exports org-babel-common-header-args-w-values)))) - (merge - (lambda (exclusive-groups &rest result-params) - ;; Maintain exclusivity of mutually exclusive parameters, - ;; as defined in EXCLUSIVE-GROUPS while merging lists in - ;; RESULT-PARAMS. - (let (output) - (dolist (new-params result-params (delete-dups output)) - (dolist (new-param new-params) - (dolist (exclusive-group exclusive-groups) - (when (member new-param exclusive-group) - (setq output (cl-remove-if - (lambda (o) (member o exclusive-group)) - output)))) - (push new-param output)))))) + (tangle-exclusive-groups + (mapcar (lambda (group) (mapcar #'symbol-name group)) + (cdr (assq 'tangle org-babel-common-header-args-w-values)))) (variable-index 0) ;Handle positional arguments. clearnames params ;Final parameters list. ;; Some keywords accept multiple values. We need to treat ;; them specially. - vars results exports) + vars results exports tangle) (dolist (plist plists) (dolist (pair plist) (pcase pair @@ -2908,22 +2979,33 @@ parameters when merging lists." (t (error "Variable \"%s\" must be assigned a default value" (cdr pair)))))) (`(:results . ,value) - (setq results (funcall merge - results-exclusive-groups - results - (split-string - (cond ((stringp value) value) - ((functionp value) (funcall value)) + (setq results (org-babel--merge-headers + results-exclusive-groups + results + (split-string + (cond ((stringp value) value) + ((functionp value) (funcall value)) ;; FIXME: Arbitrary code evaluation. - (t (eval value t))))))) + (t (eval value t))))))) (`(:exports . ,value) - (setq exports (funcall merge - exports-exclusive-groups - exports - (split-string - (cond ((and value (functionp value)) (funcall value)) - (value value) - (t "")))))) + (setq exports (org-babel--merge-headers + exports-exclusive-groups + exports + (split-string + (cond ((and value (functionp value)) (funcall value)) + (value value) + (t "")))))) + (`(:tangle . ,value) + (setq tangle (org-babel--merge-headers + tangle-exclusive-groups + tangle + (mapcar #'org-babel-read + (org-babel-balanced-split + (or value "") + (if (eq (car (text-properties-at 0 value)) + 'org-babel-quote) + ?\" + ?\s)))))) ((or '(:dir . attach) '(:dir . "'attach")) (unless (org-attach-dir nil t) (error "No attachment directory for element (add :ID: or :DIR: property)")) @@ -2949,7 +3031,8 @@ parameters when merging lists." params))))) ;; Handle other special keywords, which accept multiple values. (setq params (nconc (list (cons :results (mapconcat #'identity results " ")) - (cons :exports (mapconcat #'identity exports " "))) + (cons :exports (mapconcat #'identity exports " ")) + (cons :tangle (mapconcat #'substring-no-properties tangle " "))) params)) ;; Return merged params. (org-babel-eval-headers params))) @@ -3246,9 +3329,14 @@ situations in which is it not appropriate." ;; FIXME: Arbitrary code evaluation. (eval (read cell) t)) ((save-match-data - (and (string-match "^[[:space:]]*\"\\(.*\\)\"[[:space:]]*$" cell) - (not (string-match "[^\\]\"" (match-string 1 cell))))) - (read cell)) + (and (string-match (rx bol (* space) "\"" (group (* any)) "\"" (* space) eol) + cell) + (not (string-match (rx (not "\\") "\"") (match-string 1 cell))))) + (let ((res (read cell))) + ;; If the matched string contains quotes, add quote property + (if (string-match (rx bol "\"" (* any) "\"" eol) cell) + (put-text-property 0 (length res) 'org-babel-quote 't res)) + res)) (t (org-no-properties cell)))) (defun org-babel--string-to-number (string) diff --git a/testing/lisp/test-ob.el b/testing/lisp/test-ob.el index 460afbf9b..48cb60e10 100644 --- a/testing/lisp/test-ob.el +++ b/testing/lisp/test-ob.el @@ -359,7 +359,7 @@ PROPERTIES is a list of property keywords or a single keyword." #+end_src" (test-ob/get-src-block-property '(:mkdirp :dir :padline))))) (should - (equal '(:results "value code replace file" :file "file") + (equal '(:results "file code replace value" :file "file") (org-test-with-temp-text "\ #+PROPERTY: header-args :results file :file file @@ -368,7 +368,7 @@ PROPERTIES is a list of property keywords or a single keyword." #+end_src" (test-ob/get-src-block-property '(:results :file))))) (should - (equal '(:results "value html silent") + (equal '(:results "html silent value") (org-test-with-temp-text "\ #+PROPERTY: header-args :results file -- 2.41.0