org-mode-mirror/testing/org-html/tests.el

;;;_ org-html/tests.el --- Tests for org-html

;;;_. Headers
;;;_ , License
;; Copyright (C) 2010  Tom Breton (Tehom)

;; Author: Tom Breton (Tehom) <tehom@panix.com>
;; Keywords: lisp, maint, internal

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;;_ , Commentary:

;; 


;;;_ , Requires

(require 'org-html)

;;;_. Body
;;;_ , org-id testhelp
;;This would go into org-id/testhelp.el if there were such a file
(defconst org-id:thd:usual-id-locations 
   (org-id-alist-to-hash
      '(
	  ("file1" "id-1-in-file1")
	  ("file1" "id-2-in-file1")
	  ("file2" "id-1-in-file2")))
   
   "A stable id-locations table for testing purposes" )
;;;_  . Validation
(emt:deftest-3 org-id:thd:usual-id-locations
   (nil
      (progn
	 (emt:doc "Operation: Look up one of the keys we inserted.")
	 (emt:doc "Response: It has the value we gave it.")
	 (assert
	    (equal
	       (gethash "id-1-in-file1" org-id:thd:usual-id-locations)
	       "file1")))))

;;;_ , Config
;;;_  . org-html:thd:isolation
(defconst org-html:thd:isolation
   ;;Can't hope to capture all the org configuration any time soon,
   ;;but let's set it up to some degree.

   ;;It is generally better for this to remain constant than to try to
   ;;sync this with new versions.  To change it is effectively to
   ;;write new tests.
   '(let
       (
	  (org-export-html-inline-image-extensions
	     '("png" "jpeg" "jpg" "gif"))
	  (org-html-cvt-link-fn                    nil)
	  (org-export-first-hook                   nil)
	  (org-par-open                            t)
	  (org-url-encoding-use-url-hexify         nil)

	  ;;To control the org-id lookups
	  (org-id-locations
	     org-id:thd:usual-id-locations)

          ;;To control `org-default-export-plist'
	  (org-export-inbuffer-options-extra       nil)
						   
	  ;;To control `org-infile-export-plist'.  Set up for minimal
	  ;;export so we can more easily handle examples.  When
	  ;;specific behavior is to be tested, locally bind the
	  ;;controlling variable(s), don't change them here.
	  (org-export-html-link-up                 "")
	  (org-export-html-link-home               "")
	  (org-export-default-language             "en")
	  (org-export-page-keywords                "")
	  (org-export-page-description             "")
	  (org-display-custom-times                nil)
	  (org-export-headline-levels              100)
	  (org-export-with-section-numbers         nil)
	  (org-export-section-number-format '((("1" ".")) . ""))
	  (org-export-with-toc                     nil)
	  (org-export-preserve-breaks              nil)
	  (org-export-with-archived-trees          nil)
	  (org-export-with-emphasize               nil)
	  (org-export-with-sub-superscripts        nil)
	  (org-export-with-special-strings         nil)
	  (org-export-with-footnotes               nil)
	  (org-export-with-drawers                 nil)
	  (org-export-with-tags                    nil)
	  (org-export-with-todo-keywords           nil)
	  (org-export-with-priority                nil)
	  (org-export-with-TeX-macros              nil)
	  (org-export-with-LaTeX-fragments         nil)
	  (org-export-latex-listings               nil)
	  (org-export-skip-text-before-1st-heading nil)
	  (org-export-with-fixed-width             nil)
	  (org-export-with-timestamps              nil)
	  (org-export-author-info                  nil)
	  (org-export-email-info                   nil)
	  (org-export-creator-info                 nil)
	  (org-export-time-stamp-file              nil)
	  (org-export-with-tables                  nil)
	  (org-export-highlight-first-table-line   nil)
	  (org-export-html-style-include-default   nil)
	  (org-export-html-style-include-scripts   nil)
	  (org-export-html-style                   "")
	  (org-export-html-style-extra             "")
	  (org-agenda-export-html-style            "")
	  (org-export-html-link-org-files-as-html  nil)
	  (org-export-html-inline-images           nil)
	  (org-export-html-extension               "html")
	  (org-export-html-xml-declaration 
	     '(("html" . "<?xml version=\"1.0\" encoding=\"%s\"?>") 
		 ("php" . "<?php echo \"<?xml version=\\\"1.0\\\" encoding=\\\"%s\\\" ?>\"; ?>")))
	  (org-export-html-table-tag 
	     "<table border=\"2\" cellspacing=\"0\" cellpadding=\"6\" rules=\"groups\" frame=\"hsides\">")
	  (org-export-html-expand                nil)
	  (org-export-html-with-timestamp        nil)
	  (org-export-publishing-directory       nil)
	  (org-export-html-preamble              nil)
	  (org-export-html-postamble             nil)
	  (org-export-html-auto-preamble         nil)
	  (org-export-html-auto-postamble        nil)
	  (user-full-name                        "Emtest user")
	  (user-mail-address                     "emtest-user@localhost.localdomain")
	  (org-export-select-tags                '("export"))
	  (org-export-exclude-tags               '("noexport"))
	  (org-export-latex-image-default-option nil)

	  (org-export-plist-vars
	     '(  
		 (:link-up                 nil         org-export-html-link-up)
		 (:link-home               nil         org-export-html-link-home)
		 (:language                nil         org-export-default-language)
		 (:keywords                nil         org-export-page-keywords)
		 (:description             nil         org-export-page-description)
		 (:customtime              nil         org-display-custom-times)
		 (:headline-levels         "H"         org-export-headline-levels)
		 (:section-numbers         "num"       org-export-with-section-numbers)
		 (:section-number-format   nil         org-export-section-number-format)
		 (:table-of-contents       "toc"       org-export-with-toc)
		 (:preserve-breaks         "\\n"       org-export-preserve-breaks)
		 (:archived-trees          nil         org-export-with-archived-trees)
		 (:emphasize               "*"         org-export-with-emphasize)
		 (:sub-superscript         "^"         org-export-with-sub-superscripts)
		 (:special-strings         "-"         org-export-with-special-strings)
		 (:footnotes               "f"         org-export-with-footnotes)
		 (:drawers                 "d"         org-export-with-drawers)
		 (:tags                    "tags"      org-export-with-tags)
		 (:todo-keywords           "todo"      org-export-with-todo-keywords)
		 (:priority                "pri"       org-export-with-priority)
		 (:TeX-macros              "TeX"       org-export-with-TeX-macros)
		 (:LaTeX-fragments         "LaTeX"     org-export-with-LaTeX-fragments)
		 (:latex-listings          nil         org-export-latex-listings)
		 (:skip-before-1st-heading "skip"      org-export-skip-text-before-1st-heading)
		 (:fixed-width             ":"         org-export-with-fixed-width)
		 (:timestamps              "<"         org-export-with-timestamps)
		 (:author-info             "author"    org-export-author-info)
		 (:email-info              "email"     org-export-email-info)
		 (:creator-info            "creator"   org-export-creator-info)
		 (:time-stamp-file         "timestamp" org-export-time-stamp-file)
		 (:tables                  "|"         org-export-with-tables)
		 (:table-auto-headline     nil         org-export-highlight-first-table-line)
		 (:style-include-default   nil         org-export-html-style-include-default)
		 (:style-include-scripts   nil         org-export-html-style-include-scripts)
		 (:style                   nil         org-export-html-style)
		 (:style-extra             nil         org-export-html-style-extra)
		 (:agenda-style            nil         org-agenda-export-html-style)
		 (:convert-org-links       nil         org-export-html-link-org-files-as-html)
		 (:inline-images           nil         org-export-html-inline-images)
		 (:html-extension          nil         org-export-html-extension)
		 (:xml-declaration         nil         org-export-html-xml-declaration)
		 (:html-table-tag          nil         org-export-html-table-tag)
		 (:expand-quoted-html      "@"         org-export-html-expand)
		 (:timestamp               nil         org-export-html-with-timestamp)
		 (:publishing-directory    nil         org-export-publishing-directory)
		 (:preamble                nil         org-export-html-preamble)
		 (:postamble               nil         org-export-html-postamble)
		 (:auto-preamble           nil         org-export-html-auto-preamble)
		 (:auto-postamble          nil         org-export-html-auto-postamble)
		 (:author                  nil         user-full-name)
		 (:email                   nil         user-mail-address)
		 (:select-tags             nil         org-export-select-tags)
		 (:exclude-tags            nil         org-export-exclude-tags)
		 (:latex-image-options     nil         org-export-latex-image-default-option)))
	  ))
   "Isolation let-form for org-html tests.

Isolation let-forms are intended to be included by
`:surrounders'.  They provide a known configuration and keep
tests from altering the outside state." )

;;;_ , Examples
(defconst org-html:thd:examples
   (emt:eg:define+ ;;xmp:tqu804919ze0
      ((project org)
	 (library html)
	 (subsection link-examples))
      (group
	 ((name only-path))
	 ;;No src-text because this arglist wouldn't be generated by
	 ;;org-export-as-html, though it might be created by custom link
	 ;;types.
	 (item ((type arglist))
	    '("" "foo" nil "desc" nil nil))
	 (item ((type link-text))
	    "<a href=\"foo\">desc</a>"))
      (group
	 ((name only-fragment))
	 ;;No src-text, same reason
	 (item ((type arglist))
	    '("" "" "bar" "desc" nil nil))
	 (item ((type link-text))
	    "<a href=\"#bar\">desc</a>"))
      (group
	 ((name all-3-parts))
	 (item ((type src-text))
	    "[[http:foo#bar][desc]]")
	 (item ((type arglist))
	    '("http" "foo" "bar" "desc" nil nil))
	 (item ((type link-text))
	    "<a href=\"http:foo#bar\">desc</a>"))

      ;;Filename has to be absolute to trigger substitution.
      (group
	 ((name subst-in-filename))
	 (item ((type src-text))
	    "[[file:/foo/unfoo/.././baz][desc]]")
	 (item ((type arglist))
	    '("file" "/foo/unfoo/.././baz" "" "desc" nil nil))
	 (item ((type link-text))
	    "<a href=\"file:/foo/baz\">desc</a>"))

      (group
	 ((name type=file))
	 (item ((type src-text))
	    "[[file:foo.txt][desc]]")
	 (item ((type arglist))
	    '("file" "foo.txt" "" "desc" nil nil))
	 (item ((type link-text))
	    "<a href=\"file:foo.txt\">desc</a>"))

      ;;We control what location id finds by controlling
      ;;`org-id-locations' in `org-html:thd:isolation'
      (group
	 ((name type=id))
	 (item ((type src-text))
	    "[[id:id-1-in-file1][desc]]")
	 (item ((type arglist))
	    '("" "file1" "id-1-in-file1" "desc" nil nil))
	 (item ((type link-text))
	    "<a href=\"file1#id-1-in-file1\">desc</a>"))
      (group
	 ((name type=ftp))
	 (item ((type src-text))
	    "[[ftp:foo.com][desc]]")
	 (item ((type arglist))
	    '("ftp" "foo.com" "" "desc" nil nil))
	 (item ((type link-text))
	    "<a href=\"ftp:foo.com\">desc</a>"))

      ;;Punt coderef, internal logic is too hairy, would have to control
      ;;`org-export-get-coderef-format'.

      ;;Punt custom links, would have to make a controlled
      ;;`org-link-protocols', which means identifying and binding every
      ;;variable that `org-add-link-type' alters, then binding
      ;;`org-link-protocols' to empty list, then calling
      ;;`org-add-link-type' (possibly for id as well)

      (group
	 ((name convertable))
	 (item ((type src-text))
	    "[[file:foo.org][desc]]")
	 (item ((type arglist))
	    '("file" "foo.org" nil "desc" nil nil))
	 (group
	    ((type link-text))
	    (item ((subname old-conversion))
	       "<a href=\"http:foo.html\">desc</a>")
	    (item ((subname new-conversion))
	       "<a href=\"xform:transformed-foo.org\">desc</a>")
	    (item ((subname no-conversion))
	       "<a href=\"file:foo.org\">desc</a>")))
      ))

;;;_ , Helpers

(defun org-html:th:cvt-fn (opt-plist type path)
   "Trivial URL transformer"
   (declare (ignored opt-plist))
   (list
      "xform"
      (concat "transformed-" path)))

(defun org-html:th:check-link-matches (expected)
   "Build a link text and check it against expected text.
Sensitive to emt:eg narrowing."
   
   (assert
      (equal
	 (apply #'org-html-make-link
	     '(:html-extension "html")
	    (emt:eg (type arglist)))
	 expected)
      t))


;;;_ , org-html-make-link
(emt:deftest-3 
   ((of 'org-html-make-link)
      (:surrounders
	 (list
	    org-html:thd:isolation
	     '(emt:eg:with org-html:thd:examples
		((project org)
		   (library html)
		   (subsection link-examples))))))
   
   (nil
      (emt:eg:map name name
	 (unless
	    (eq name 'convertable)  
	    (emt:doc "Proves: Example arglist gives the expected result.")
	    (org-html:th:check-link-matches
	       (emt:eg (type link-text))))))
   
   (nil
      (emt:eg:narrow ((name convertable))
	 (let
	    (
	       (org-export-html-link-org-files-as-html t)
	       (org-html-cvt-link-fn nil))
	    (emt:doc "Proves: Old org->html conversion works.")
	    (org-html:th:check-link-matches
		  (emt:eg (type link-text) (subname old-conversion))))))
   
   (nil
      (emt:eg:narrow ((name convertable))
	 (let
	    (
	       (org-export-html-link-org-files-as-html nil)
	       (org-html-cvt-link-fn #'org-html:th:cvt-fn))
	    (emt:doc "Proves: New file->url conversion works.")
	    (org-html:th:check-link-matches
	       (emt:eg (type link-text) (subname new-conversion))))))
   
   (nil
      (emt:eg:narrow ((name convertable))
	 (let
	    (
	       (org-export-html-link-org-files-as-html t)
	       (org-html-cvt-link-fn #'org-html:th:cvt-fn))
	    (emt:doc "Proves: New conversion has precedence over old.")
	    (org-html:th:check-link-matches
	       (emt:eg (type link-text) (subname new-conversion))))))
   


   ;;Add tests for making images - but it's nearly direct.

   )
;;;_ , Helpers
(defun org-html:th:build-source (type path fragment &optional desc
				   descp attr may-inline-p)
   ""
   (declare (ignored descp attr may-inline-p))
   (concat
      "[["type":"
      (org-link-escape path)
      (if fragment
	 (cond
	    ((string= type "file")(concat "::" fragment))
	    ((string= type "http")(concat "#" fragment))))
      "]["desc"]]"))
;;;_  . org-html:th:strip-whitepadding
(defun org-html:th:strip-whitepadding (str)
   ""
   
   (with-temp-buffer
      (insert str)
      (goto-char (point-min))
      (while (search-forward "\n" nil t)
	 (replace-match ""))
      (goto-char (point-min))
      (while (search-forward "<p>" nil t)
	 (replace-match ""))
      (goto-char (point-min))
      (while (search-forward "</p>" nil t)
	 (replace-match ""))
      (buffer-string)))
;;;_   , Examples
(defconst org-html:stripwhite:thd:examples
   (emt:eg:define+ ;;xmp:khpjmfi0aze0
      ((project org)(library html)
	 (subsection org-html:th:strip-whitepadding)
	 (type string)
	 (role before))
      (item ((name 0)) 
	 "\na\nb")
      (item ((name 1)) 
	 "\n<p>ab")
      (item ((name 2)) 
	 "\n</p>a\nb")))

;;;_   , Tests
(emt:deftest-3 org-html:th:strip-whitepadding
   (nil
      (emt:eg:with org-html:stripwhite:thd:examples
	 ((project org)(library html)
	    (subsection org-html:th:strip-whitepadding)) 
	 (emt:eg:map name name
	    (emt:doc 
	       "Check: The stripped string matches what's expected.")
	    (assert
	       (string=
		  (org-html:th:strip-whitepadding (emt:eg))
		  "ab"))))))

;;;_ , org-export-as-html

(emt:deftest-3 
   ((of 'org-export-as-html)
      (:surrounders
	 (list
	    org-html:thd:isolation
	    ;;Re-use the link examples.
	    '(emt:eg:with org-html:thd:examples
		((project org)(library html))))))
   (nil
      (emt:eg:narrow ((subsection link-examples)) 
	 (emt:eg:map name name
	    (when
	       (and
		  (not (eq name 'convertable))
		  ;;Dormant for id because it wants to find filename
		  ;;relative to `org-current-export-file', but for
		  ;;buffer export there is none.
		  (not (eq name 'type=id))  
		  (emt:eg:boundp '(type src-text)))
	       (emt:doc 
		  "Situation: the only thing in the buffer is that link")
	       (with-buffer-containing-object
 		  (:string
		     (emt:eg (type src-text)))
		  (org-mode)

		  ;;This calculation has to be done outside the assert
		  ;;or it will be done twice.
		  (emt:doc "Operation: export the buffer as HTML.")
		  (let
		     ((result
			 (org-html:th:strip-whitepadding
			    (org-export-region-as-html
			       (point-min)
			       (point-max)
			       t
			       'string))))
		     (emt:doc 
			"Proves: Example arglist gives the expected result.")
		     (assert
			(string=
			   result
			   (emt:eg (type link-text)))
			t)))))))
   ;;Could also use testpoints to test that we feed the link-builder
   ;;functions as expected.


   ;;Could also make example files and convert them.
   )



;;;_. Footers
;;;_ , Provides

(provide 'org-html/tests)

;;;_ * Local emacs vars.
;;;_  + Local variables:
;;;_  + mode: allout
;;;_  + End:

;;;_ , End
;;; org-html/tests.el ends here