ox-publish: Improve control over site map

* lisp/ox-publish.el (org-publish-project-alist): Document
  new :sitemap-format-entry property, and change to `:sitemap-function'.
(org-publish-sitemap-file-entry-format): Make variable obsolete.
(org-publish-org-sitemap): Remove function.
(org-publish--sitemap-files-to-lisp):
(org-publish-sitemap):
(org-publish-sitemap-default-entry):
(org-publish-sitemap-default): New functions.
(org-publish-projects): Use new functions.
* lisp/org-compat: Implement directory-name-p when not available.

* doc/org.texi (Sitemap): Update documentation.

:sitemap-function is more specialized so it is easier to manipulate.  In
particular, it can make use of built-in `org-list-to-*' functions.
Also, :sitemap-format-entry, as a function, is less limited than
`org-publish-sitemap-file-entry-format' format string.

doc/org.texi

@@ -14532,10 +14532,20 @@ becomes @file{sitemap.html}).
 @item @code{:sitemap-title}
 @tab Title of sitemap page.  Defaults to name of file.
 
+@item @code{:sitemap-format-entry}
+@tab With this option one can tell how a site-map entry is formatted in the
+site-map.  It is a function called with three arguments: the absolute file or
+directory name, the base directory of the project and the site-map style.  It
+is expected to return a string.  Default value turns file names into links
+and use document titles as descriptions.
+
 @item @code{:sitemap-function}
-@tab Plug-in function to use for generation of the sitemap.
-Defaults to @code{org-publish-org-sitemap}, which generates a plain list
-of links to all files in the project.
+@tab Plug-in function to use for generation of the sitemap.  It is called
+with two arguments: the title of the site-map and a representation of the
+files and directories involved in the project as a radio list (@pxref{Radio
+lists}).  The latter can further be transformed using
+@code{org-list-to-generic}, @code{org-list-to-subtree} and alike.  Default
+value generates a plain list of links to all files in the project.
 
 @item @code{:sitemap-sort-folders}
 @tab Where folders should appear in the sitemap.  Set this to @code{first}
@@ -14553,14 +14563,6 @@ a file is retrieved with @code{org-publish-find-date}.
 @item @code{:sitemap-ignore-case}
 @tab Should sorting be case-sensitive?  Default @code{nil}.
 
-@item @code{:sitemap-file-entry-format}
-@tab With this option one can tell how a sitemap's entry is formatted in the
-sitemap.  This is a format string with some escape sequences: @code{%t} stands
-for the title of the file, @code{%a} stands for the author of the file and
-@code{%d} stands for the date of the file.  The date is retrieved with the
-@code{org-publish-find-date} function and formatted with
-@code{org-publish-sitemap-date-format}.  Default @code{%t}.
-
 @item @code{:sitemap-date-format}
 @tab Format string for the @code{format-time-string} function that tells how
 a sitemap entry's date is to be formatted.  This property bypasses

etc/ORG-NEWS

@@ -12,11 +12,6 @@ Please send Org bug reports to mailto:emacs-orgmode@gnu.org.
 
 ** Incompatible changes
 
-*** Change signature for some properties in ~org-list-to-generic~
-
-~:istart~, ~:icount~, ~:iend~ and ~:isep~ now expect the type of the
-list as their first argument.
-
 *** ~org-capture-templates~ no longer accepts S-expressions as file names
 
 Since functions are allowed there, a straightforward way to migrate
@@ -28,6 +23,16 @@ into
 
 : (file (lambda () (sexp)))
 
+*** Change signature for ~:sitemap-function~
+
+~:sitemap-function~ now expects to be called with two arguments.  See
+~org-publish-project-alist~ for details.
+
+*** Change signature for some properties in ~org-list-to-generic~
+
+~:istart~, ~:icount~, ~:iend~ and ~:isep~ now expect the type of the
+list as their first argument.
+
 ** New features
 *** Agenda
 **** New variable : ~org-agenda-show-future-repeats~
@@ -121,6 +126,13 @@ For an equivalent to a ~nil~ value, set
 ~org-agenda-show-future-repeats~ to nil and
 ~org-agenda-prefer-last-repeat~ to ~t~.
 
+** Removed options
+
+*** ~org-publish-sitemap-file-entry-format~ is deprecated
+
+One can provide new ~:sitemap-format-entry~ property for a function
+equivalent to the removed format string.
+
 ** New functions
 
 *** ~org-list-to-org~

lisp/org-compat.el

@@ -60,6 +60,17 @@
   (defalias 'format-message 'format)
   (defalias 'gui-get-selection 'x-get-selection))
 
+  ;; From "files.el"
+  (defsubst directory-name-p (name)
+    "Return non-nil if NAME ends with a directory separator character."
+  (let ((len (length name))
+        (lastc ?.))
+    (if (> len 0)
+        (setq lastc (aref name (1- len))))
+    (or (= lastc ?/)
+        (and (memq system-type '(windows-nt ms-dos))
+             (= lastc ?\\)))))
+
 
 ;;; Obsolete aliases (remove them once the next major release is released).
 
@@ -288,6 +299,20 @@ See `org-link-parameters' for documentation on the other parameters."
   (org-unbracket-string "\"" "\"" s))
 (make-obsolete 'org-remove-double-quotes 'org-unbracket-string "Org 9.0")
 
+(defcustom org-publish-sitemap-file-entry-format "%t"
+  "Format string for site-map file entry.
+You could use brackets to delimit on what part the link will be.
+
+%t is the title.
+%a is the author.
+%d is the date formatted using `org-publish-sitemap-date-format'."
+  :group 'org-export-publish
+  :type 'string)
+(make-obsolete-variable
+ 'org-publish-sitemap-file-entry-format
+ "set `:sitemap-format-entry' in `org-publish-project-alist' instead."
+ "Org 9.1")
+
 ;;;; Obsolete link types
 
 (eval-after-load 'org

lisp/ox-publish.el

@@ -208,18 +208,12 @@ a site-map of files or summary page for a given project.
 
   `:sitemap-filename'
 
-    Filename for output of sitemap.  Defaults to \"sitemap.org\".
+    Filename for output of site-map.  Defaults to \"sitemap.org\".
 
   `:sitemap-title'
 
     Title of site-map page.  Defaults to name of file.
 
-  `:sitemap-function'
-
-    Plugin function to use for generation of site-map.  Defaults
-    to `org-publish-org-sitemap', which generates a plain list of
-    links to all files in the project.
-
   `:sitemap-style'
 
     Can be `list' (site-map is just an itemized list of the
@@ -233,6 +227,26 @@ a site-map of files or summary page for a given project.
     cool URIs (see http://www.w3.org/Provider/Style/URI).
     Defaults to nil.
 
+  `:sitemap-format-entry'
+
+    Plugin function used to format entries in the site-map.  It
+    is called with three arguments: the absolute file or
+    directory name to format, the base directory of the project
+    and the site-map style.  It has to return a string.  Defaults
+    to `org-publish-sitemap-default-entry', which turns file
+    names into links and use document titles as descriptions.
+
+  `:sitemap-function'
+
+    Plugin function to use for generation of site-map.  It is
+    called with two arguments: the title of the site-map, as
+    a string, and a representation of the files involved in the
+    project, as returned by `org-list-to-lisp'.  The latter can
+    further be transformed using `org-list-to-generic',
+    `org-list-to-subtree' and alike.  It has to return a string.
+    Defaults to `org-publish-sitemap-default', which generates
+    a plain list of links to all files in the project.
+
 If you create a site-map file, adjust the sorting like this:
 
   `:sitemap-sort-folders'
@@ -327,16 +341,6 @@ See `format-time-string' for allowed formatters."
   :group 'org-export-publish
   :type 'string)
 
-(defcustom org-publish-sitemap-file-entry-format "%t"
-  "Format string for site-map file entry.
-You could use brackets to delimit on what part the link will be.
-
-%t is the title.
-%a is the author.
-%d is the date formatted using `org-publish-sitemap-date-format'."
-  :group 'org-export-publish
-  :type 'string)
-
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -403,7 +407,6 @@ This splices all the components into the list."
 (defvar org-publish-sitemap-ignore-case)
 (defvar org-publish-sitemap-requested)
 (defvar org-publish-sitemap-date-format)
-(defvar org-publish-sitemap-file-entry-format)
 (defun org-publish-compare-directory-files (a b)
   "Predicate for `sort', that sorts folders and files for sitemap."
   (let ((retval t))
@@ -687,16 +690,10 @@ If `:auto-sitemap' is set, publish the sitemap too.  If
 	(let ((sitemap-filename
 	       (or (plist-get project-plist :sitemap-filename)
 		   "sitemap.org"))
-	      (sitemap-function
-	       (or (plist-get project-plist :sitemap-function)
-		   #'org-publish-org-sitemap))
 	      (org-publish-sitemap-date-format
 	       (or (plist-get project-plist :sitemap-date-format)
-		   org-publish-sitemap-date-format))
-	      (org-publish-sitemap-file-entry-format
-	       (or (plist-get project-plist :sitemap-file-entry-format)
-		   org-publish-sitemap-file-entry-format)))
-	  (funcall sitemap-function project sitemap-filename)))
+		   org-publish-sitemap-date-format)))
+	  (org-publish-sitemap project sitemap-filename)))
       ;; Publish all files from PROJECT excepted "theindex.org".  Its
       ;; publishing will be deferred until "theindex.inc" is
       ;; populated.
@@ -717,92 +714,78 @@ If `:auto-sitemap' is set, publish the sitemap too.  If
 	      ((functionp fun) (funcall fun project-plist))))
       (org-publish-write-cache-file))))
 
-(defun org-publish-org-sitemap (project &optional sitemap-filename)
+(defun org-publish--sitemap-files-to-lisp (files root style entry-format)
+  "Represent FILES as a parsed plain list.
+FILES is the list of files in the site map.  ROOT is the project
+base directory.  STYLE determines is either `list' or `tree'.
+ENTRY-FORMAT is a function called on each file which should
+return a string.  Return value is a list as returned by
+`org-list-to-lisp'."
+  (pcase style
+    (`list
+     (cons 'unordered
+	   (mapcar (lambda (f) (list (funcall entry-format f root style)))
+		   files)))
+    (`tree
+     (letrec ((files-only (cl-remove-if #'directory-name-p files))
+	      ;; Extract directories from true files so as to avoid
+	      ;; publishing empty, or missing (e.g., when using
+	      ;; `:include' property) directories.
+	      (directories (org-uniquify
+			    (mapcar #'file-name-directory files-only)))
+	      (subtree-to-list
+	       (lambda (dir)
+		 (cons 'unordered
+		       (nconc
+			;; Files in DIR.
+			(mapcar
+			 (lambda (f) (list (funcall entry-format f root style)))
+			 (cl-remove-if-not
+			  (lambda (f) (string= dir (file-name-directory f)))
+			  files-only))
+			;; Direct sub-directories.
+			(mapcar
+			 (lambda (sub)
+			   (list (funcall entry-format sub root style)
+				 (funcall subtree-to-list sub)))
+			 (cl-remove-if-not
+			  (lambda (f)
+			    (string=
+			     dir
+			     ;; Parent directory.
+			     (file-name-directory (directory-file-name f))))
+			  directories)))))))
+       (funcall subtree-to-list root)))
+    (_ (user-error "Unknown sitemap style: `%s'" style))))
+
+(defun org-publish-sitemap (project &optional sitemap-filename)
   "Create a sitemap of pages in set defined by PROJECT.
 Optionally set the filename of the sitemap with SITEMAP-FILENAME.
 Default for SITEMAP-FILENAME is `sitemap.org'."
   (let* ((project-plist (cdr project))
-	 (dir (file-name-as-directory
-	       (plist-get project-plist :base-directory)))
-	 (localdir (file-name-directory dir))
-	 (indent-str (make-string 2 ?\ ))
-	 (exclude-regexp (plist-get project-plist :exclude))
-	 (files (nreverse
-		 (org-publish-get-base-files project exclude-regexp)))
-	 (sitemap-filename (concat dir (or sitemap-filename "sitemap.org")))
-	 (sitemap-title (or (plist-get project-plist :sitemap-title)
-			  (concat "Sitemap for project " (car project))))
-	 (sitemap-style (or (plist-get project-plist :sitemap-style)
-			    'tree))
-	 (sitemap-sans-extension
-	  (plist-get project-plist :sitemap-sans-extension))
-	 (visiting (find-buffer-visiting sitemap-filename))
-	 file sitemap-buffer)
-    (with-current-buffer
-	(let ((org-inhibit-startup t))
-	  (setq sitemap-buffer
-		(or visiting (find-file sitemap-filename))))
-      (erase-buffer)
-      (insert (concat "#+TITLE: " sitemap-title "\n\n"))
-      (while (setq file (pop files))
-	(let ((link (file-relative-name file dir))
-	      (oldlocal localdir))
-	  (when sitemap-sans-extension
-	    (setq link (file-name-sans-extension link)))
-	  ;; sitemap shouldn't list itself
-	  (unless (equal (file-truename sitemap-filename)
-			 (file-truename file))
-	    (if (eq sitemap-style 'list)
-		(message "Generating list-style sitemap for %s" sitemap-title)
-	      (message "Generating tree-style sitemap for %s" sitemap-title)
-	      (setq localdir (concat (file-name-as-directory dir)
-				     (file-name-directory link)))
-	      (unless (string= localdir oldlocal)
-		(if (string= localdir dir)
-		    (setq indent-str (make-string 2 ?\ ))
-		  (let ((subdirs
-			 (split-string
-			  (directory-file-name
-			   (file-name-directory
-			    (file-relative-name localdir dir))) "/"))
-			(subdir "")
-			(old-subdirs (split-string
-				      (file-relative-name oldlocal dir) "/")))
-		    (setq indent-str (make-string 2 ?\ ))
-		    (while (string= (car old-subdirs) (car subdirs))
-		      (setq indent-str (concat indent-str (make-string 2 ?\ )))
-		      (pop old-subdirs)
-		      (pop subdirs))
-		    (dolist (d subdirs)
-		      (setq subdir (concat subdir d "/"))
-		      (insert (concat indent-str " + " d "\n"))
-		      (setq indent-str (make-string
-					(+ (length indent-str) 2) ?\ )))))))
-	    ;; This is common to 'flat and 'tree
-	    (let ((entry
-		   (org-publish-format-file-entry
-		    org-publish-sitemap-file-entry-format file project-plist))
-		  (regexp "\\(.*\\)\\[\\([^][]+\\)\\]\\(.*\\)"))
-	      (cond ((string-match-p regexp entry)
-		     (string-match regexp entry)
-		     (insert (concat indent-str " + " (match-string 1 entry)
-				     "[[file:" link "]["
-				     (match-string 2 entry)
-				     "]]" (match-string 3 entry) "\n")))
-		    (t
-		     (insert (concat indent-str " + [[file:" link "]["
-				     entry
-				     "]]\n"))))))))
-      (save-buffer))
-    (or visiting (kill-buffer sitemap-buffer))))
-
-(defun org-publish-format-file-entry (fmt file project-plist)
-  (format-spec
-   fmt
-   `((?t . ,(org-publish-find-title file t))
-     (?d . ,(format-time-string org-publish-sitemap-date-format
-				(org-publish-find-date file)))
-     (?a . ,(or (plist-get project-plist :author) user-full-name)))))
+	 (root (expand-file-name
+		(file-name-as-directory
+		 (plist-get project-plist :base-directory))))
+	 (sitemap-filename (concat root (or sitemap-filename "sitemap.org")))
+	 (title (or (plist-get project-plist :sitemap-title)
+		    (concat "Sitemap for project " (car project))))
+	 (style (or (plist-get project-plist :sitemap-style) 'tree))
+	 (sitemap-builder (or (plist-get project-plist :sitemap-function)
+			      #'org-publish-sitemap-default))
+	 (format-entry (or (plist-get project-plist :sitemap-format-entry)
+			   #'org-publish-sitemap-default-entry)))
+    (message "Generating sitemap for %s" title)
+    (with-temp-file sitemap-filename
+      (insert
+       (let ((files (remove sitemap-filename
+			    (org-publish-get-base-files
+			     project (plist-get project-plist :exclude)))))
+	 (when (plist-get project-plist :sitemap-sans-extension)
+	   (setq files (mapcar #'file-name-sans-extension files)))
+	 (funcall sitemap-builder
+		  title
+		  (org-publish--sitemap-files-to-lisp
+		   files root style format-entry)))))))
 
 (defun org-publish-find-title (file &optional reset)
   "Find the title of FILE in project."
@@ -856,6 +839,26 @@ time in `current-time' format."
 	    ((file-exists-p file) (nth 5 (file-attributes file)))
 	    (t (error "No such file: \"%s\"" file))))))
 
+(defun org-publish-sitemap-default-entry (entry root style)
+  "Default format for site map ENTRY, as a string.
+ENTRY is a file name.  ROOT is the base directory of the current
+project.  STYLE is the style of the sitemap."
+  (cond ((not (directory-name-p entry))
+	 (format "[[file:%s][%s]]"
+		 (file-relative-name entry root)
+		 (org-publish-find-title entry)))
+	((eq style 'tree)
+	 ;; Return only last subdir.
+	 (file-name-nondirectory (directory-file-name entry)))
+	(t (file-relative-name entry root))))
+
+(defun org-publish-sitemap-default (title list)
+  "Default site map, as a string.
+TITLE is the the title of the site map.  LIST is an internal
+representation for the files to include, as returned by
+`org-list-to-lisp'."
+  (concat "#+TITLE: " title "\n\n"
+	  (org-list-to-org list)))
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;