From 0a142efddebd24e947c3d8666a73360f0f27249d Mon Sep 17 00:00:00 2001 From: Nicolas Goaziou Date: Fri, 23 Nov 2012 18:41:58 +0100 Subject: [PATCH] org-export: Add tools for timestamps objects * contrib/lisp/org-export.el (org-export-split-timestamp-range, org-export-translate-timestamp): New functions. * testing/lisp/test-org-export.el: Add tests. --- contrib/lisp/org-export.el | 55 ++++++++++++++++++ testing/lisp/test-org-export.el | 120 +++++++++++++++++++++++++++++++++++++++- 2 files changed, 174 insertions(+), 1 deletion(-) diff --git a/contrib/lisp/org-export.el b/contrib/lisp/org-export.el index 5195bab71..841eee0cc 100644 --- a/contrib/lisp/org-export.el +++ b/contrib/lisp/org-export.el @@ -4314,6 +4314,61 @@ Universal Time." :year-start))))) utc)) +(defun org-export-split-timestamp-range (timestamp &optional end) + "Extract a timestamp object from a date or time range. + +TIMESTAMP is a timestamp object. END, when non-nil, means extract +the end of the range. Otherwise, extract its start. + +Return a new timestamp object sharing the same parent as +TIMESTAMP." + (let ((type (org-element-property :type timestamp))) + (if (memq type '(active inactive diary)) timestamp + (let ((split-ts (list 'timestamp (copy-sequence (nth 1 timestamp))))) + ;; Set new type. + (org-element-put-property + split-ts :type (if (eq type 'active-range) 'active 'inactive)) + ;; Copy start properties over end properties if END is + ;; non-nil. Otherwise, copy end properties over `start' ones. + (let ((p-alist '((:minute-start . :minute-end) + (:hour-start . :hour-end) + (:day-start . :day-end) + (:month-start . :month-end) + (:year-start . :year-end)))) + (dolist (p-cell p-alist) + (org-element-put-property + split-ts + (funcall (if end 'car 'cdr) p-cell) + (org-element-property + (funcall (if end 'cdr 'car) p-cell) split-ts))) + ;; Eventually refresh `:raw-value'. + (org-element-put-property split-ts :raw-value nil) + (org-element-put-property + split-ts :raw-value (org-element-interpret-data split-ts))))))) + +(defun org-export-translate-timestamp (timestamp &optional boundary) + "Apply `org-translate-time' on a TIMESTAMP object. +When optional argument BOUNDARY is non-nil, it is either the +symbol `start' or `end'. In this case, only translate the +starting or ending part of TIMESTAMP if it is a date or time +range. Otherwise, translate both parts." + (if (and (not boundary) + (memq (org-element-property :type timestamp) + '(active-range inactive-range))) + (concat + (org-translate-time + (org-element-property :raw-value + (org-export-split-timestamp-range timestamp))) + "--" + (org-translate-time + (org-element-property :raw-value + (org-export-split-timestamp-range timestamp t)))) + (org-translate-time + (org-element-property + :raw-value + (if (not boundary) timestamp + (org-export-split-timestamp-range timestamp (eq boundary 'end))))))) + ;;;; Smart Quotes ;; diff --git a/testing/lisp/test-org-export.el b/testing/lisp/test-org-export.el index 18b01039b..dc67059c9 100644 --- a/testing/lisp/test-org-export.el +++ b/testing/lisp/test-org-export.el @@ -598,7 +598,7 @@ body\n"))) -;;; Back-end Definition +;;; Back-End Tools (ert-deftest test-org-export/define-backend () "Test back-end definition and accessors." @@ -694,6 +694,28 @@ body\n"))) (org-export-define-derived-backend test3 test2) (org-export-derived-backend-p 'test3 'test)))) +(ert-deftest test-org-export/with-backend () + "Test `org-export-with-backend' definition." + ;; Error when calling an undefined back-end + (should-error + (let (org-export-registered-backends) + (org-export-with-backend 'test "Test"))) + ;; Error when called back-end doesn't have an appropriate + ;; transcoder. + (should-error + (let (org-export-registered-backends) + (org-export-define-backend test ((headline . ignore))) + (org-export-with-backend 'test "Test"))) + ;; Otherwise, export using correct transcoder + (should + (equal "Success" + (let (org-export-registered-backends) + (org-export-define-backend test + ((plain-text . (lambda (text contents info) "Failure")))) + (org-export-define-backend test2 + ((plain-text . (lambda (text contents info) "Success")))) + (org-export-with-backend 'test2 "Test"))))) + ;;; Export Snippets @@ -2049,6 +2071,102 @@ Another text. (ref:text) (org-test-with-temp-text "[2011-07-14 Thu]--[2012-03-29 Thu]" (org-export-format-timestamp (org-element-context) "%Y-%m-%d" t))))) +(ert-deftest test-org-export/split-timestamp-range () + "Test `org-export-split-timestamp-range' specifications." + ;; Extract range start (active). + (should + (equal '(2012 3 29) + (org-test-with-temp-text "<2012-03-29 Thu>--<2012-03-30 Fri>" + (let ((ts (org-export-split-timestamp-range (org-element-context)))) + (mapcar (lambda (p) (org-element-property p ts)) + '(:year-end :month-end :day-end)))))) + ;; Extract range start (inactive) + (should + (equal '(2012 3 29) + (org-test-with-temp-text "[2012-03-29 Thu]--[2012-03-30 Fri]" + (let ((ts (org-export-split-timestamp-range (org-element-context)))) + (mapcar (lambda (p) (org-element-property p ts)) + '(:year-end :month-end :day-end)))))) + ;; Extract range end (active). + (should + (equal '(2012 3 30) + (org-test-with-temp-text "<2012-03-29 Thu>--<2012-03-30 Fri>" + (let ((ts (org-export-split-timestamp-range + (org-element-context) t))) + (mapcar (lambda (p) (org-element-property p ts)) + '(:year-end :month-end :day-end)))))) + ;; Extract range end (inactive) + (should + (equal '(2012 3 30) + (org-test-with-temp-text "[2012-03-29 Thu]--[2012-03-30 Fri]" + (let ((ts (org-export-split-timestamp-range + (org-element-context) t))) + (mapcar (lambda (p) (org-element-property p ts)) + '(:year-end :month-end :day-end)))))) + ;; Return the timestamp if not a range. + (should + (org-test-with-temp-text "[2012-03-29 Thu]" + (let* ((ts-orig (org-element-context)) + (ts-copy (org-export-split-timestamp-range ts-orig))) + (eq ts-orig ts-copy)))) + (should + (org-test-with-temp-text "<%%(org-float t 4 2)>" + (let* ((ts-orig (org-element-context)) + (ts-copy (org-export-split-timestamp-range ts-orig))) + (eq ts-orig ts-copy)))) + ;; Check that parent is the same when a range was split. + (should + (org-test-with-temp-text "[2012-03-29 Thu]--[2012-03-30 Fri]" + (let* ((ts-orig (org-element-context)) + (ts-copy (org-export-split-timestamp-range ts-orig))) + (eq (org-element-property :parent ts-orig) + (org-element-property :parent ts-copy)))))) + +(ert-deftest test-org-export/translate-timestamp () + "Test `org-export-translate-timestamp' specifications." + ;; Translate whole date range. + (should + (equal "<29>--<30>" + (org-test-with-temp-text "<2012-03-29 Thu>--<2012-03-30 Fri>" + (let ((org-display-custom-times t) + (org-time-stamp-custom-formats '("<%d>" . "<%d>"))) + (org-export-translate-timestamp (org-element-context)))))) + ;; Translate date range start. + (should + (equal "<29>" + (org-test-with-temp-text "<2012-03-29 Thu>--<2012-03-30 Fri>" + (let ((org-display-custom-times t) + (org-time-stamp-custom-formats '("<%d>" . "<%d>"))) + (org-export-translate-timestamp (org-element-context) 'start))))) + ;; Translate date range end. + (should + (equal "<30>" + (org-test-with-temp-text "<2012-03-29 Thu>--<2012-03-30 Fri>" + (let ((org-display-custom-times t) + (org-time-stamp-custom-formats '("<%d>" . "<%d>"))) + (org-export-translate-timestamp (org-element-context) 'end))))) + ;; Translate time range. + (should + (equal "<08>--<16>" + (org-test-with-temp-text "<2012-03-29 Thu 8:30-16:40>" + (let ((org-display-custom-times t) + (org-time-stamp-custom-formats '("<%d>" . "<%H>"))) + (org-export-translate-timestamp (org-element-context)))))) + ;; Translate non-range timestamp. + (should + (equal "<29>" + (org-test-with-temp-text "<2012-03-29 Thu>" + (let ((org-display-custom-times t) + (org-time-stamp-custom-formats '("<%d>" . "<%d>"))) + (org-export-translate-timestamp (org-element-context)))))) + ;; Do not change `diary' timestamps. + (should + (equal "<%%(org-float t 4 2)>" + (org-test-with-temp-text "<%%(org-float t 4 2)>" + (let ((org-display-custom-times t) + (org-time-stamp-custom-formats '("<%d>" . "<%d>"))) + (org-export-translate-timestamp (org-element-context))))))) + ;;; Topology -- 2.11.4.GIT