From 74faf5bd26d4aea1124dd087fbd99323559459ff Mon Sep 17 00:00:00 2001 From: Nicolas Goaziou Date: Sat, 17 Nov 2012 13:33:38 +0100 Subject: [PATCH] org-export: New `org-export-derived-backend-p' predicate * contrib/lisp/org-export.el (org-export-define-derived-backend): Add `:parent' property to derived backend. (org-export-derived-backend-p): New function. * testing/lisp/test-org-export.el: Add tests. This function can be useful in filters implemation. I.e. (defun my-filter (contents backend info) (when (memq backend '(e-latex e-beamer some-derived-backend-from-latex)) ...)) can be replaced with: (defun my filter (contents backend info) (when (org-export-derived-backend-p backend 'e-latex) ...)) --- contrib/lisp/org-export.el | 12 +++++ testing/lisp/test-org-export.el | 98 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 110 insertions(+) diff --git a/contrib/lisp/org-export.el b/contrib/lisp/org-export.el index 9f0827a43..c9f0edca9 100644 --- a/contrib/lisp/org-export.el +++ b/contrib/lisp/org-export.el @@ -925,6 +925,7 @@ The back-end could then be called with, for example: \(org-export-to-buffer 'my-latex \"*Test my-latex*\")" (declare (debug (&define name sexp [&rest [keywordp sexp]] def-body)) (indent 2)) + (org-export-barf-if-invalid-backend parent) (let (export-block filters menu-entry options translators contents) (while (keywordp (car body)) (case (pop body) @@ -938,6 +939,7 @@ The back-end could then be called with, for example: (:translate-alist (setq translators (pop body))) (t (pop body)))) (setq contents (append + (list :parent parent) (let ((p-table (org-export-backend-translate-table parent))) (list :translate-alist (append translators p-table))) (let ((p-filters (org-export-backend-filters parent))) @@ -985,6 +987,16 @@ The back-end could then be called with, for example: (unless (org-export-backend-translate-table backend) (error "Unknown \"%s\" back-end: Aborting export" backend))) +(defun org-export-derived-backend-p (backend &rest backends) + "Non-nil if BACKEND is derived from one of BACKENDS." + (let ((parent backend)) + (while (and (not (memq parent backends)) + (setq parent + (plist-get (cdr (assq parent + org-export-registered-backends)) + :parent)))) + parent)) + ;;; The Communication Channel diff --git a/testing/lisp/test-org-export.el b/testing/lisp/test-org-export.el index ba70e208c..7eb9f990b 100644 --- a/testing/lisp/test-org-export.el +++ b/testing/lisp/test-org-export.el @@ -572,6 +572,104 @@ body\n"))) +;;; Back-end Definition + +(ert-deftest test-org-export/define-backend () + "Test back-end definition and accessors." + ;; Translate table. + (should + (equal '((headline . my-headline-test)) + (let (org-export-registered-backends) + (org-export-define-backend test ((headline . my-headline-test))) + (org-export-backend-translate-table 'test)))) + ;; Filters. + (should + (equal '((:filter-headline . my-filter)) + (let (org-export-registered-backends) + (org-export-define-backend test + ((headline . my-headline-test)) + :filters-alist ((:filter-headline . my-filter))) + (org-export-backend-filters 'test)))) + ;; Options. + (should + (equal '((:prop value)) + (let (org-export-registered-backends) + (org-export-define-backend test + ((headline . my-headline-test)) + :options-alist ((:prop value))) + (org-export-backend-options 'test)))) + ;; Menu. + (should + (equal '(?k "Test Export" test) + (let (org-export-registered-backends) + (org-export-define-backend test + ((headline . my-headline-test)) + :menu-entry (?k "Test Export" test)) + (org-export-backend-menu 'test)))) + ;; Export Blocks. + (should + (equal '(("TEST" . org-element-export-block-parser)) + (let (org-export-registered-backends org-element-block-name-alist) + (org-export-define-backend test + ((headline . my-headline-test)) + :export-block ("test")) + org-element-block-name-alist)))) + +(ert-deftest test-org-export/define-derived-backend () + "Test `org-export-define-derived-backend' specifications." + ;; Error when parent back-end is not defined. + (should-error + (let (org-export-registered-backends) + (org-export-define-derived-backend test parent))) + ;; Append translation table to parent's. + (should + (equal '((:headline . test) (:headline . parent)) + (let (org-export-registered-backends) + (org-export-define-backend parent ((:headline . parent))) + (org-export-define-derived-backend test parent + :translate-alist ((:headline . test))) + (org-export-backend-translate-table 'test))))) + +(ert-deftest test-org-export/derived-backend-p () + "Test `org-export-derived-backend-p' specifications." + ;; Non-nil with direct match. + (should + (let (org-export-registered-backends) + (org-export-define-backend test ((headline . test))) + (org-export-derived-backend-p 'test 'test))) + (should + (let (org-export-registered-backends) + (org-export-define-backend test ((headline . test))) + (org-export-define-derived-backend test2 test) + (org-export-derived-backend-p 'test2 'test2))) + ;; Non-nil with a direct parent. + (should + (let (org-export-registered-backends) + (org-export-define-backend test ((headline . test))) + (org-export-define-derived-backend test2 test) + (org-export-derived-backend-p 'test2 'test))) + ;; Non-nil with an indirect parent. + (should + (let (org-export-registered-backends) + (org-export-define-backend test ((headline . test))) + (org-export-define-derived-backend test2 test) + (org-export-define-derived-backend test3 test2) + (org-export-derived-backend-p 'test3 'test))) + ;; Nil otherwise. + (should-not + (let (org-export-registered-backends) + (org-export-define-backend test ((headline . test))) + (org-export-define-backend test2 ((headline . test2))) + (org-export-derived-backend-p 'test2 'test))) + (should-not + (let (org-export-registered-backends) + (org-export-define-backend test ((headline . test))) + (org-export-define-backend test2 ((headline . test2))) + (org-export-define-derived-backend test3 test2) + (org-export-derived-backend-p 'test3 'test)))) + + + ;;; Export Snippets (ert-deftest test-org-export/export-snippet () -- 2.11.4.GIT