974 lines
41 KiB
EmacsLisp
974 lines
41 KiB
EmacsLisp
;;; muse-project.el --- handle Muse projects
|
|
|
|
;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010
|
|
;; Free Software Foundation, Inc.
|
|
|
|
;; This file is part of Emacs Muse. It is not part of GNU Emacs.
|
|
|
|
;; Emacs Muse 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 3, or (at your
|
|
;; option) any later version.
|
|
|
|
;; Emacs Muse 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 Emacs Muse; see the file COPYING. If not, write to the
|
|
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
|
;; Boston, MA 02110-1301, USA.
|
|
|
|
;;; Commentary:
|
|
|
|
;;; Contributors:
|
|
|
|
;;; Code:
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Muse Project Maintainance
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(provide 'muse-project)
|
|
|
|
(require 'muse)
|
|
(require 'muse-publish)
|
|
(require 'cus-edit)
|
|
|
|
(defgroup muse-project nil
|
|
"Options controlling the behavior of Muse project handling."
|
|
:group 'muse)
|
|
|
|
(defcustom muse-before-project-publish-hook nil
|
|
"A hook run before a project is published.
|
|
Each function is passed the project object, a cons with the format
|
|
(PROJNAME . SETTINGS)"
|
|
:type 'hook
|
|
:group 'muse-project)
|
|
|
|
(defcustom muse-after-project-publish-hook nil
|
|
"A hook run after a project is published.
|
|
Each function is passed the project object, a cons with the format
|
|
(PROJNAME . SETTINGS)"
|
|
:type 'hook
|
|
:group 'muse-project)
|
|
|
|
(defvar muse-project-alist-using-customize nil
|
|
"Used internally by Muse to indicate whether `muse-project-alist'
|
|
has been modified via the customize interface.")
|
|
(make-variable-buffer-local 'muse-project-alist-using-customize)
|
|
|
|
(defmacro with-muse-project (project &rest body)
|
|
`(progn
|
|
(unless (muse-project ,project)
|
|
(error "Can't find project %s" ,project))
|
|
(with-temp-buffer
|
|
(muse-mode)
|
|
(setq muse-current-project (muse-project ,project))
|
|
(muse-project-set-variables)
|
|
,@body)))
|
|
|
|
(put 'with-muse-project 'lisp-indent-function 0)
|
|
(put 'with-muse-project 'edebug-form-spec '(sexp body))
|
|
|
|
(defun muse-project-alist-get (sym)
|
|
"Turn `muse-project-alist' into something we can customize easily."
|
|
(when (boundp sym)
|
|
(setq muse-project-alist-using-customize t)
|
|
(let* ((val (copy-alist (symbol-value sym)))
|
|
(head val))
|
|
(while val
|
|
(let ((head (car (cdar val)))
|
|
res)
|
|
;; Turn settings of first part into cons cells, symbol->string
|
|
(while head
|
|
(cond ((stringp (car head))
|
|
(add-to-list 'res (car head) t)
|
|
(setq head (cdr head)))
|
|
((symbolp (car head))
|
|
(add-to-list 'res (list (symbol-name (car head))
|
|
(cadr head)) t)
|
|
(setq head (cddr head)))
|
|
(t
|
|
(setq head (cdr head)))))
|
|
(setcdr (car val) (cons res (cdr (cdar val)))))
|
|
(let ((styles (cdar val)))
|
|
;; Symbol->string in every style
|
|
(while (cdr styles)
|
|
(let ((head (cadr styles))
|
|
res)
|
|
(while (consp head)
|
|
(setq res (plist-put res (symbol-name (car head))
|
|
(cadr head)))
|
|
(setq head (cddr head)))
|
|
(setcdr styles (cons res (cddr styles))))
|
|
(setq styles (cdr styles))))
|
|
(setq val (cdr val)))
|
|
head)))
|
|
|
|
(defun muse-project-alist-set (sym val)
|
|
"Turn customized version of `muse-project-alist' into something
|
|
Muse can make use of."
|
|
(set sym val)
|
|
(when muse-project-alist-using-customize
|
|
;; Make sure the unescaped version is written to .emacs
|
|
(put sym 'saved-value (list (custom-quote val)))
|
|
;; Perform unescaping
|
|
(while val
|
|
(let ((head (car (cdar val)))
|
|
res)
|
|
;; Turn cons cells into flat list, string->symbol
|
|
(while head
|
|
(cond ((stringp (car head))
|
|
(add-to-list 'res (car head) t))
|
|
((consp (car head))
|
|
(add-to-list 'res (intern (caar head)) t)
|
|
(add-to-list 'res (car (cdar head)) t)))
|
|
(setq head (cdr head)))
|
|
(setcdr (car val) (cons res (cdr (cdar val)))))
|
|
(let ((styles (cdar val)))
|
|
;; String->symbol in every style
|
|
(while (cdr styles)
|
|
(let ((head (cadr styles))
|
|
res)
|
|
(while (consp head)
|
|
(setq res (plist-put res (intern (car head))
|
|
(cadr head)))
|
|
(setq head (cddr head)))
|
|
(setcdr styles (cons res (cddr styles))))
|
|
(setq styles (cdr styles))))
|
|
(setq val (cdr val)))))
|
|
|
|
(define-widget 'muse-project 'default
|
|
"A widget that defines a Muse project."
|
|
:format "\n%v"
|
|
:value-create 'muse-widget-type-value-create
|
|
:value-get 'muse-widget-child-value-get
|
|
:value-delete 'ignore
|
|
:match 'muse-widget-type-match
|
|
:type '(cons :format " %v"
|
|
(repeat :tag "Settings" :format "%{%t%}:\n%v%i\n\n"
|
|
(choice
|
|
(string :tag "Directory")
|
|
(list :tag "Book function"
|
|
(const :tag ":book-funcall" ":book-funcall")
|
|
(choice (function)
|
|
(sexp :tag "Unknown")))
|
|
(list :tag "Book part"
|
|
(const :tag ":book-part" ":book-part")
|
|
(string :tag "Name"))
|
|
(list :tag "Book style"
|
|
(const :tag ":book-style" ":book-style")
|
|
(string :tag "Style"))
|
|
(list :tag "Default file"
|
|
(const :tag ":default" ":default")
|
|
(string :tag "File"))
|
|
(list :tag "End of book"
|
|
(const :tag ":book-end" ":book-end")
|
|
(const t))
|
|
(list :tag "Force publishing"
|
|
(const :tag ":force-publish" ":force-publish")
|
|
(repeat (string :tag "File")))
|
|
(list :tag "Major mode"
|
|
(const :tag ":major-mode" ":major-mode")
|
|
(choice (function :tag "Mode")
|
|
(sexp :tag "Unknown")))
|
|
(list :tag "New chapter"
|
|
(const :tag ":book-chapter" ":book-chapter")
|
|
(string :tag "Name"))
|
|
(list :tag "No chapters"
|
|
(const :tag ":nochapters" ":nochapters")
|
|
(const t))
|
|
(list :tag "Project-level publishing function"
|
|
(const :tag ":publish-project"
|
|
":publish-project")
|
|
(choice (function :tag "Function")
|
|
(sexp :tag "Unknown")))
|
|
(list :tag "Set variables"
|
|
(const :tag ":set" ":set")
|
|
(repeat (list :inline t
|
|
(symbol :tag "Variable")
|
|
(sexp :tag "Setting"))))
|
|
(list :tag "Visit links using"
|
|
(const :tag ":visit-link" ":visit-link")
|
|
(choice (function)
|
|
(sexp :tag "Unknown")))))
|
|
(repeat :tag "Output styles" :format "%{%t%}:\n%v%i\n\n"
|
|
(set :tag "Style"
|
|
(list :inline t
|
|
:tag "Publishing style"
|
|
(const :tag ":base" ":base")
|
|
(string :tag "Style"))
|
|
(list :inline t
|
|
:tag "Base URL"
|
|
(const :tag ":base-url" ":base-url")
|
|
(string :tag "URL"))
|
|
(list :inline t
|
|
:tag "Exclude matching"
|
|
(const :tag ":exclude" ":exclude")
|
|
(regexp))
|
|
(list :inline t
|
|
:tag "Include matching"
|
|
(const :tag ":include" ":include")
|
|
(regexp))
|
|
(list :inline t
|
|
:tag "Timestamps file"
|
|
(const :tag ":timestamps" ":timestamps")
|
|
(file))
|
|
(list :inline t
|
|
:tag "Path"
|
|
(const :tag ":path" ":path")
|
|
(string :tag "Path"))))))
|
|
|
|
(defcustom muse-project-alist nil
|
|
"An alist of Muse projects.
|
|
A project defines a fileset, and a list of custom attributes for use
|
|
when publishing files in that project."
|
|
:type '(choice (const :tag "No projects defined." nil)
|
|
(repeat (cons :format "%{%t%}:\n\n%v"
|
|
:tag "Project" :indent 4
|
|
(string :tag "Project name")
|
|
muse-project))
|
|
(sexp :tag "Cannot parse expression"))
|
|
:get 'muse-project-alist-get
|
|
:set 'muse-project-alist-set
|
|
:group 'muse-project)
|
|
|
|
;; Make it easier to specify a muse-project-alist entry
|
|
|
|
(defcustom muse-project-ignore-regexp
|
|
(concat "\\`\\(#.*#\\|.*,v\\|.*~\\|\\.\\.?\\|\\.#.*\\|,.*\\)\\'\\|"
|
|
"/\\(CVS\\|RCS\\|\\.arch-ids\\|{arch}\\|,.*\\|\\.svn\\|"
|
|
"\\.hg\\|\\.git\\|\\.bzr\\|_darcs\\)\\(/\\|\\'\\)")
|
|
"A regexp matching files to be ignored in Muse directories.
|
|
|
|
You should set `case-fold-search' to nil before using this regexp
|
|
in code."
|
|
:type 'regexp
|
|
:group 'muse-regexp)
|
|
|
|
(defcustom muse-project-publish-private-files t
|
|
"If this is non-nil, files will be published even if their permissions
|
|
are set so that no one else on the filesystem can read them.
|
|
|
|
Set this to nil if you would like to indicate that some files
|
|
should not be published by manually doing \"chmod o-rwx\" on
|
|
them.
|
|
|
|
This setting has no effect under Windows (that is, all files are
|
|
published regardless of permissions) because Windows lacks the
|
|
needed filesystem attributes."
|
|
:type 'boolean
|
|
:group 'muse-project)
|
|
|
|
(defun muse-project-recurse-directory (base)
|
|
"Recusively retrieve all of the directories underneath BASE.
|
|
A list of these directories is returned.
|
|
|
|
Directories starting with \".\" will be ignored, as well as those
|
|
which match `muse-project-ignore-regexp'."
|
|
(let ((case-fold-search nil)
|
|
list dir)
|
|
(when (and (file-directory-p base)
|
|
(not (string-match muse-project-ignore-regexp base)))
|
|
(dolist (file (directory-files base t "^[^.]"))
|
|
(when (and (file-directory-p file)
|
|
(not (string-match muse-project-ignore-regexp file)))
|
|
(setq dir (file-name-nondirectory file))
|
|
(push dir list)
|
|
(nconc list (mapcar #'(lambda (item)
|
|
(concat dir "/" item))
|
|
(muse-project-recurse-directory file)))))
|
|
list)))
|
|
|
|
(defun muse-project-alist-styles (entry-dir output-dir style &rest other)
|
|
"Return a list of styles to use in a `muse-project-alist' entry.
|
|
ENTRY-DIR is the top-level directory of the project.
|
|
OUTPUT-DIR is where Muse files are published, keeping directory structure.
|
|
STYLE is the publishing style to use.
|
|
|
|
OTHER contains other definitions to add to each style. It is optional.
|
|
|
|
For an example of the use of this function, see
|
|
`examples/mwolson/muse-init.el' from the Muse distribution."
|
|
(let ((fnd (file-name-nondirectory entry-dir)))
|
|
(when (string= fnd "")
|
|
;; deal with cases like "foo/" that have a trailing slash
|
|
(setq fnd (file-name-nondirectory (substring entry-dir 0 -1))))
|
|
(cons `(:base ,style :path ,(if (muse-file-remote-p output-dir)
|
|
output-dir
|
|
(expand-file-name output-dir))
|
|
:include ,(concat "/" fnd "/[^/]+$")
|
|
,@other)
|
|
(mapcar (lambda (dir)
|
|
`(:base ,style
|
|
:path ,(expand-file-name dir output-dir)
|
|
:include ,(concat "/" dir "/[^/]+$")
|
|
,@other))
|
|
(muse-project-recurse-directory entry-dir)))))
|
|
|
|
(defun muse-project-alist-dirs (entry-dir)
|
|
"Return a list of directories to use in a `muse-project-alist' entry.
|
|
ENTRY-DIR is the top-level directory of the project.
|
|
|
|
For an example of the use of this function, see
|
|
`examples/mwolson/muse-init.el' from the Muse distribution."
|
|
(cons (expand-file-name entry-dir)
|
|
(mapcar (lambda (dir) (expand-file-name dir entry-dir))
|
|
(muse-project-recurse-directory entry-dir))))
|
|
|
|
;; Constructing the file-alist
|
|
|
|
(defvar muse-project-file-alist nil
|
|
"This variable is automagically constructed as needed.")
|
|
|
|
(defvar muse-project-file-alist-hook nil
|
|
"Functions that are to be exectuted immediately after updating
|
|
`muse-project-file-alist'.")
|
|
|
|
(defvar muse-current-project nil
|
|
"Project we are currently visiting.")
|
|
(make-variable-buffer-local 'muse-current-project)
|
|
(defvar muse-current-project-global nil
|
|
"Project we are currently visiting. This is used to propagate the value
|
|
of `muse-current-project' into a new buffer during publishing.")
|
|
|
|
(defvar muse-current-output-style nil
|
|
"The output style that we are currently using for publishing files.")
|
|
|
|
(defsubst muse-project (&optional project)
|
|
"Resolve the given PROJECT into a full Muse project, if it is a string."
|
|
(if (null project)
|
|
(or muse-current-project
|
|
(muse-project-of-file))
|
|
(if (stringp project)
|
|
(assoc project muse-project-alist)
|
|
(muse-assert (consp project))
|
|
project)))
|
|
|
|
(defun muse-project-page-file (page project &optional no-check-p)
|
|
"Return a filename if PAGE exists within the given Muse PROJECT."
|
|
(setq project (muse-project project))
|
|
(if (null page)
|
|
;; if not given a page, return the first directory instead
|
|
(let ((pats (cadr project)))
|
|
(catch 'done
|
|
(while pats
|
|
(if (symbolp (car pats))
|
|
(setq pats (cddr pats))
|
|
(throw 'done (file-name-as-directory (car pats)))))))
|
|
(let ((dir (file-name-directory page))
|
|
(expanded-path nil))
|
|
(when dir
|
|
(setq expanded-path (concat (expand-file-name
|
|
page
|
|
(file-name-directory (muse-current-file)))
|
|
(when muse-file-extension
|
|
(concat "." muse-file-extension))))
|
|
(setq page (file-name-nondirectory page)))
|
|
(let ((files (muse-collect-alist
|
|
(muse-project-file-alist project no-check-p)
|
|
page))
|
|
(matches nil))
|
|
(if dir
|
|
(catch 'done
|
|
(save-match-data
|
|
(dolist (file files)
|
|
(if (and expanded-path
|
|
(string= expanded-path (cdr file)))
|
|
(throw 'done (cdr file))
|
|
(let ((pos (string-match (concat (regexp-quote dir) "\\'")
|
|
(file-name-directory
|
|
(cdr file)))))
|
|
(when pos
|
|
(setq matches (cons (cons pos (cdr file))
|
|
matches)))))))
|
|
;; if we haven't found an exact match, pick a candidate
|
|
(car (muse-sort-by-rating matches)))
|
|
(dolist (file files)
|
|
(setq matches (cons (cons (length (cdr file)) (cdr file))
|
|
matches)))
|
|
(car (muse-sort-by-rating matches '<)))))))
|
|
|
|
(defun muse-project-private-p (file)
|
|
"Return non-nil if NAME is a private page with PROJECT."
|
|
(unless (or muse-under-windows-p
|
|
muse-project-publish-private-files)
|
|
(setq file (file-truename file))
|
|
(if (file-attributes file) ; don't publish if no attributes exist
|
|
(or (when (eq ?- (aref (nth 8 (file-attributes
|
|
(file-name-directory file))) 7))
|
|
(message (concat
|
|
"The " (file-name-directory file)
|
|
" directory must be readable by others"
|
|
" in order for its contents to be published.")))
|
|
(eq ?- (aref (nth 8 (file-attributes file)) 7)))
|
|
t)))
|
|
|
|
(defun muse-project-file-entries (path)
|
|
(let* ((names (list t))
|
|
(lnames names)
|
|
(case-fold-search nil))
|
|
(cond
|
|
((file-directory-p path)
|
|
(dolist (file (directory-files
|
|
path t (when (and muse-file-extension
|
|
(not (string= muse-file-extension "")))
|
|
(concat "." muse-file-extension "\\'"))))
|
|
(unless (or (string-match muse-project-ignore-regexp file)
|
|
(string-match muse-project-ignore-regexp
|
|
(file-name-nondirectory file))
|
|
(file-directory-p file))
|
|
(setcdr lnames
|
|
(cons (cons (muse-page-name file) file) nil))
|
|
(setq lnames (cdr lnames)))))
|
|
((file-readable-p path)
|
|
(setcdr lnames
|
|
(cons (cons (muse-page-name path) path) nil))
|
|
(setq lnames (cdr lnames)))
|
|
(t ; regexp
|
|
(muse-assert (file-name-directory path))
|
|
(dolist (file (directory-files
|
|
(file-name-directory path) t
|
|
(file-name-nondirectory path)))
|
|
(unless (or (string-match muse-project-ignore-regexp file)
|
|
(string-match muse-project-ignore-regexp
|
|
(file-name-nondirectory file)))
|
|
(setcdr lnames
|
|
(cons (cons (muse-page-name file) file) nil))
|
|
(setq lnames (cdr lnames))))))
|
|
(cdr names)))
|
|
|
|
(defvar muse-updating-file-alist-p nil
|
|
"Make sure that recursive calls to `muse-project-file-alist' are bounded.")
|
|
|
|
(defun muse-project-determine-last-mod (project &optional no-check-p)
|
|
"Return the most recent last-modified timestamp of dirs in PROJECT."
|
|
(let ((last-mod nil))
|
|
(unless (or muse-under-windows-p no-check-p)
|
|
(let ((pats (cadr project)))
|
|
(while pats
|
|
(if (symbolp (car pats))
|
|
(setq pats (cddr pats))
|
|
(let* ((fnd (file-name-directory (car pats)))
|
|
(dir (cond ((file-directory-p (car pats))
|
|
(car pats))
|
|
((and (not (file-readable-p (car pats)))
|
|
fnd
|
|
(file-directory-p fnd))
|
|
fnd))))
|
|
(when dir
|
|
(let ((mod-time (nth 5 (file-attributes dir))))
|
|
(when (or (null last-mod)
|
|
(and mod-time
|
|
(muse-time-less-p last-mod mod-time)))
|
|
(setq last-mod mod-time)))))
|
|
(setq pats (cdr pats))))))
|
|
last-mod))
|
|
|
|
(defun muse-project-file-alist (&optional project no-check-p)
|
|
"Return member filenames for the given Muse PROJECT.
|
|
Also, update the `muse-project-file-alist' variable.
|
|
|
|
On UNIX, this alist is only updated if one of the directories'
|
|
contents have changed. On Windows, it is always reread from
|
|
disk.
|
|
|
|
If NO-CHECK-P is non-nil, do not update the alist, just return
|
|
the current one."
|
|
(setq project (muse-project project))
|
|
(when (and project muse-project-alist)
|
|
(let* ((file-alist (assoc (car project) muse-project-file-alist))
|
|
(last-mod (muse-project-determine-last-mod project no-check-p)))
|
|
;; Either return the currently known list, or read it again from
|
|
;; disk
|
|
(if (or (and no-check-p (cadr file-alist))
|
|
muse-updating-file-alist-p
|
|
(not (or muse-under-windows-p
|
|
(null (cddr file-alist))
|
|
(null last-mod)
|
|
(muse-time-less-p (cddr file-alist) last-mod))))
|
|
(cadr file-alist)
|
|
(if file-alist
|
|
(setcdr (cdr file-alist) last-mod)
|
|
(setq file-alist (cons (car project) (cons nil last-mod))
|
|
muse-project-file-alist
|
|
(cons file-alist muse-project-file-alist)))
|
|
;; Read in all of the file entries
|
|
(let ((muse-updating-file-alist-p t))
|
|
(prog1
|
|
(save-match-data
|
|
(setcar
|
|
(cdr file-alist)
|
|
(let* ((names (list t))
|
|
(pats (cadr project)))
|
|
(while pats
|
|
(if (symbolp (car pats))
|
|
(setq pats (cddr pats))
|
|
(nconc names (muse-project-file-entries (car pats)))
|
|
(setq pats (cdr pats))))
|
|
(cdr names))))
|
|
(run-hooks 'muse-project-file-alist-hook)))))))
|
|
|
|
(defun muse-project-add-to-alist (file &optional project)
|
|
"Make sure FILE is added to `muse-project-file-alist'.
|
|
|
|
It works by either calling the `muse-project-file-alist' function
|
|
if a directory has been modified since we last checked, or
|
|
manually forcing the file entry to exist in the alist. This
|
|
works around an issue where if several files being saved at the
|
|
same time, only the first one will make it into the alist. It is
|
|
meant to be called by `muse-project-after-save-hook'.
|
|
|
|
The project of the file is determined by either the PROJECT
|
|
argument, or `muse-project-of-file' if PROJECT is not specified."
|
|
(setq project (or (muse-project project) (muse-project-of-file file)))
|
|
(when (and project muse-project-alist)
|
|
(let* ((file-alist (assoc (car project) muse-project-file-alist))
|
|
(last-mod (muse-project-determine-last-mod project)))
|
|
;; Determine whether we need to call this
|
|
(if (or (null (cddr file-alist))
|
|
(null last-mod)
|
|
(muse-time-less-p (cddr file-alist) last-mod))
|
|
;; The directory will show up as modified, so go ahead and
|
|
;; call `muse-project-file-alist'
|
|
(muse-project-file-alist project)
|
|
;; It is not showing as modified, so forcefully add the
|
|
;; current file to the project file-alist
|
|
(let ((muse-updating-file-alist-p t))
|
|
(prog1
|
|
(save-match-data
|
|
(setcar (cdr file-alist)
|
|
(nconc (muse-project-file-entries file)
|
|
(cadr file-alist))))
|
|
(run-hooks 'muse-project-file-alist-hook)))))))
|
|
|
|
(defun muse-project-of-file (&optional pathname)
|
|
"Determine which project the given PATHNAME relates to.
|
|
If PATHNAME is nil, the current buffer's filename is used."
|
|
(if (and (null pathname) muse-current-project)
|
|
muse-current-project
|
|
(unless pathname (setq pathname (muse-current-file)))
|
|
(save-match-data
|
|
(when (and (stringp pathname)
|
|
muse-project-alist
|
|
(not (string= pathname ""))
|
|
(not (let ((case-fold-search nil))
|
|
(or (string-match muse-project-ignore-regexp
|
|
pathname)
|
|
(string-match muse-project-ignore-regexp
|
|
(file-name-nondirectory
|
|
pathname))))))
|
|
(let* ((file (file-truename pathname))
|
|
(dir (file-name-directory file))
|
|
found rating matches)
|
|
(catch 'found
|
|
(dolist (project-entry muse-project-alist)
|
|
(let ((pats (cadr project-entry)))
|
|
(while pats
|
|
(if (symbolp (car pats))
|
|
(setq pats (cddr pats))
|
|
(let ((tname (file-truename (car pats))))
|
|
(cond ((or (string= tname file)
|
|
(string= (file-name-as-directory tname) dir))
|
|
(throw 'found project-entry))
|
|
((string-match (concat "\\`" (regexp-quote tname))
|
|
file)
|
|
(setq matches (cons (cons (match-end 0)
|
|
project-entry)
|
|
matches)))))
|
|
(setq pats (cdr pats))))))
|
|
;; if we haven't found an exact match, pick a candidate
|
|
(car (muse-sort-by-rating matches))))))))
|
|
|
|
(defun muse-project-after-save-hook ()
|
|
"Update Muse's file-alist if we are saving a Muse file."
|
|
(let ((project (muse-project-of-file)))
|
|
(when project
|
|
(muse-project-add-to-alist (buffer-file-name) project))))
|
|
|
|
(add-hook 'after-save-hook 'muse-project-after-save-hook)
|
|
|
|
(defun muse-read-project (prompt &optional no-check-p no-assume)
|
|
"Read a project name from the minibuffer, if it can't be figured
|
|
out."
|
|
(if (null muse-project-alist)
|
|
(error "There are no Muse projects defined; see `muse-project-alist'")
|
|
(or (unless no-check-p
|
|
(muse-project-of-file))
|
|
(if (and (not no-assume)
|
|
(= 1 (length muse-project-alist)))
|
|
(car muse-project-alist)
|
|
(assoc (funcall muse-completing-read-function
|
|
prompt muse-project-alist)
|
|
muse-project-alist)))))
|
|
|
|
(defvar muse-project-page-history nil)
|
|
|
|
(defun muse-read-project-file (project prompt &optional default)
|
|
(let* ((file-list (muse-delete-dups
|
|
(mapcar #'(lambda (a) (list (car a)))
|
|
(muse-project-file-alist project))))
|
|
(name (funcall muse-completing-read-function
|
|
prompt file-list nil nil nil
|
|
'muse-project-page-history default)))
|
|
(cons name (muse-project-page-file name project))))
|
|
|
|
;;;###autoload
|
|
(defun muse-project-find-file (name project &optional command directory)
|
|
"Open the Muse page given by NAME in PROJECT.
|
|
If COMMAND is non-nil, it is the function used to visit the file.
|
|
If DIRECTORY is non-nil, it is the directory in which the page
|
|
will be created if it does not already exist. Otherwise, the
|
|
first directory within the project's fileset is used."
|
|
(interactive
|
|
(let* ((project (muse-read-project "Find in project: "
|
|
current-prefix-arg))
|
|
(default (muse-get-keyword :default (cadr project)))
|
|
(entry (muse-read-project-file
|
|
project (if default
|
|
(format "Find page: (default: %s) "
|
|
default)
|
|
"Find page: ")
|
|
default)))
|
|
(list entry project)))
|
|
(setq project (muse-project project))
|
|
(let ((project-name (car project)))
|
|
(unless (interactive-p)
|
|
(setq project (muse-project project)
|
|
name (cons name (muse-project-page-file name project))))
|
|
;; If we're given a relative or absolute filename, open it as-is
|
|
(if (and (car name)
|
|
(save-match-data
|
|
(or (string-match "\\`\\.+/" (car name))
|
|
(string-match muse-file-regexp (car name))
|
|
(string-match muse-image-regexp (car name)))))
|
|
(setcdr name (car name))
|
|
;; At this point, name is (PAGE . FILE).
|
|
(unless (cdr name)
|
|
(let ((pats (cadr project)))
|
|
(while (and pats (null directory))
|
|
(if (symbolp (car pats))
|
|
(setq pats (cddr pats))
|
|
(if (file-directory-p (car pats))
|
|
(setq directory (car pats) pats nil)
|
|
(setq pats (cdr pats))))))
|
|
(when directory
|
|
(let ((filename (expand-file-name (car name) directory)))
|
|
(when (and muse-file-extension
|
|
(not (string= muse-file-extension ""))
|
|
(not (file-exists-p (car name))))
|
|
(setq filename (concat filename "." muse-file-extension)))
|
|
(unless (file-exists-p directory)
|
|
(make-directory directory t))
|
|
(setcdr name filename)))))
|
|
;; Open the file
|
|
(if (cdr name)
|
|
(funcall (or command 'find-file) (cdr name))
|
|
(error "There is no page %s in project %s"
|
|
(car name) project-name))))
|
|
|
|
(defun muse-project-choose-style (closure test styles)
|
|
"Run TEST on STYLES and return first style where TEST yields non-nil.
|
|
TEST should take two arguments. The first is CLOSURE, which is
|
|
passed verbatim. The second if the current style to consider.
|
|
|
|
If no style passes TEST, return the first style."
|
|
(or (catch 'winner
|
|
(dolist (style styles)
|
|
(when (funcall test closure style)
|
|
(throw 'winner style))))
|
|
(car styles)))
|
|
|
|
(defun muse-project-choose-style-by-link-suffix (given-suffix style)
|
|
"If the given STYLE has a link-suffix that equals GIVEN-SUFFIX,
|
|
return non-nil."
|
|
(let ((link-suffix (or (muse-style-element :link-suffix style)
|
|
(muse-style-element :suffix style))))
|
|
(and (stringp link-suffix)
|
|
(string= given-suffix link-suffix))))
|
|
|
|
(defun muse-project-applicable-styles (file styles)
|
|
"Given STYLES, return a list of the ones that are considered for FILE.
|
|
The name of a project may be used for STYLES."
|
|
(when (stringp styles)
|
|
(setq styles (cddr (muse-project styles))))
|
|
(when (and file styles)
|
|
(let ((used-styles nil))
|
|
(dolist (style styles)
|
|
(let ((include-regexp (muse-style-element :include style))
|
|
(exclude-regexp (muse-style-element :exclude style))
|
|
(rating nil))
|
|
(when (and (or (and (null include-regexp)
|
|
(null exclude-regexp))
|
|
(if include-regexp
|
|
(setq rating (string-match include-regexp file))
|
|
(not (string-match exclude-regexp file))))
|
|
(file-exists-p file)
|
|
(not (muse-project-private-p file)))
|
|
(setq used-styles (cons (cons rating style) used-styles)))))
|
|
(muse-sort-by-rating (nreverse used-styles)))))
|
|
|
|
(defun muse-project-get-applicable-style (file styles)
|
|
"Choose a style from the STYLES that FILE can publish to.
|
|
The user is prompted if several styles are found."
|
|
(muse-publish-get-style
|
|
(mapcar (lambda (style)
|
|
(cons (muse-get-keyword :base style) style))
|
|
(muse-project-applicable-styles file styles))))
|
|
|
|
(defun muse-project-resolve-directory (page local-style remote-style)
|
|
"Figure out the directory part of the path that provides a link to PAGE.
|
|
LOCAL-STYLE is the style of the current Muse file, and
|
|
REMOTE-STYLE is the style associated with PAGE.
|
|
|
|
If REMOTE-STYLE has a :base-url element, concatenate it and PAGE.
|
|
Otherwise, return a relative link."
|
|
(let ((prefix (muse-style-element :base-url remote-style)))
|
|
(if prefix
|
|
(concat prefix page)
|
|
(file-relative-name (expand-file-name
|
|
(file-name-nondirectory page)
|
|
(muse-style-element :path remote-style))
|
|
(expand-file-name
|
|
(muse-style-element :path local-style))))))
|
|
|
|
(defun muse-project-resolve-link (page local-style remote-styles)
|
|
"Return a published link from the output path of one file to another file.
|
|
|
|
The best match for PAGE is determined by comparing the link
|
|
suffix of the given local style and that of the remote styles.
|
|
|
|
The remote styles are usually populated by
|
|
`muse-project-applicable-styles'.
|
|
|
|
If no remote style is found, return PAGE verbatim
|
|
|
|
If PAGE has a :base-url associated with it, return the
|
|
concatenation of the :base-url value and PAGE.
|
|
|
|
Otherwise, return a relative path from the directory of
|
|
LOCAL-STYLE to the best directory among REMOTE-STYLES."
|
|
(let ((link-suffix (or (muse-style-element :link-suffix local-style)
|
|
(muse-style-element :suffix local-style)))
|
|
remote-style)
|
|
(if (not (stringp link-suffix))
|
|
(setq remote-style (car remote-styles))
|
|
(setq remote-style (muse-project-choose-style
|
|
link-suffix
|
|
#'muse-project-choose-style-by-link-suffix
|
|
remote-styles)))
|
|
(if (null remote-style)
|
|
page
|
|
(setq page (muse-project-resolve-directory
|
|
page local-style remote-style))
|
|
(concat (file-name-directory page)
|
|
(muse-publish-link-name page remote-style)))))
|
|
|
|
(defun muse-project-current-output-style (&optional file project)
|
|
(or muse-current-output-style
|
|
(progn
|
|
(unless file (setq file (muse-current-file)))
|
|
(unless project (setq project (muse-project-of-file file)))
|
|
(car (muse-project-applicable-styles file (cddr project))))))
|
|
|
|
(defun muse-project-link-page (page)
|
|
(let ((project (muse-project-of-file)))
|
|
(muse-project-resolve-link page
|
|
(muse-project-current-output-style)
|
|
(muse-project-applicable-styles
|
|
(muse-project-page-file page project)
|
|
(cddr project)))))
|
|
|
|
(defun muse-project-publish-file-default (file style output-dir force)
|
|
;; ensure the publishing location is available
|
|
(unless (file-exists-p output-dir)
|
|
(message "Creating publishing directory %s" output-dir)
|
|
(make-directory output-dir t))
|
|
;; publish the member file!
|
|
(muse-publish-file file style output-dir force))
|
|
|
|
(defun muse-project-publish-file (file styles &optional force)
|
|
(setq styles (muse-project-applicable-styles file styles))
|
|
(let (published)
|
|
(dolist (style styles)
|
|
(if (or (not (listp style))
|
|
(not (cdr style)))
|
|
(muse-display-warning
|
|
(concat "Skipping malformed muse-project-alist style."
|
|
"\nPlease double-check your configuration,"))
|
|
(let ((output-dir (muse-style-element :path style))
|
|
(muse-current-output-style style)
|
|
(fun (or (muse-style-element :publish style t)
|
|
'muse-project-publish-file-default)))
|
|
(when (funcall fun file style output-dir force)
|
|
(setq published t)))))
|
|
published))
|
|
|
|
;;;###autoload
|
|
(defun muse-project-publish-this-file (&optional force style)
|
|
"Publish the currently-visited file according to `muse-project-alist',
|
|
prompting if more than one style applies.
|
|
|
|
If FORCE is given, publish the file even if it is up-to-date.
|
|
|
|
If STYLE is given, use that publishing style rather than
|
|
prompting for one."
|
|
(interactive (list current-prefix-arg))
|
|
(let ((muse-current-project (muse-project-of-file)))
|
|
(if (not muse-current-project)
|
|
;; file is not part of a project, so fall back to muse-publish
|
|
(if (interactive-p) (call-interactively 'muse-publish-this-file)
|
|
(muse-publish-this-file style nil force))
|
|
(unless style
|
|
(setq style (muse-project-get-applicable-style
|
|
buffer-file-name (cddr muse-current-project))))
|
|
(let* ((output-dir (muse-style-element :path style))
|
|
(muse-current-project-global muse-current-project)
|
|
(muse-current-output-style (list :base (car style)
|
|
:path output-dir))
|
|
(fun (or (muse-style-element :publish style t)
|
|
'muse-project-publish-file-default)))
|
|
(unless (funcall fun buffer-file-name style output-dir force)
|
|
(message (concat "The published version is up-to-date; use"
|
|
" C-u C-c C-t to force an update.")))))))
|
|
|
|
(defun muse-project-save-buffers (&optional project)
|
|
(setq project (muse-project project))
|
|
(when project
|
|
(save-excursion
|
|
(map-y-or-n-p
|
|
(function
|
|
(lambda (buffer)
|
|
(and (buffer-modified-p buffer)
|
|
(not (buffer-base-buffer buffer))
|
|
(or (buffer-file-name buffer)
|
|
(progn
|
|
(set-buffer buffer)
|
|
(and buffer-offer-save
|
|
(> (buffer-size) 0))))
|
|
(with-current-buffer buffer
|
|
(let ((proj (muse-project-of-file)))
|
|
(and proj (string= (car proj)
|
|
(car project)))))
|
|
(if (buffer-file-name buffer)
|
|
(format "Save file %s? "
|
|
(buffer-file-name buffer))
|
|
(format "Save buffer %s? "
|
|
(buffer-name buffer))))))
|
|
(function
|
|
(lambda (buffer)
|
|
(set-buffer buffer)
|
|
(save-buffer)))
|
|
(buffer-list)
|
|
'("buffer" "buffers" "save")
|
|
(if (boundp 'save-some-buffers-action-alist)
|
|
save-some-buffers-action-alist)))))
|
|
|
|
(defun muse-project-publish-default (project styles &optional force)
|
|
"Publish the pages of PROJECT that need publishing."
|
|
(setq project (muse-project project))
|
|
(let ((published nil))
|
|
;; publish all files in the project, for each style; the actual
|
|
;; publishing will only happen if the files are newer than the
|
|
;; last published output, or if the file is listed in
|
|
;; :force-publish. Files in :force-publish will not trigger the
|
|
;; "All pages need to be published" message.
|
|
(let ((forced-files (muse-get-keyword :force-publish (cadr project)))
|
|
(file-alist (muse-project-file-alist project)))
|
|
(dolist (pair file-alist)
|
|
(when (muse-project-publish-file (cdr pair) styles force)
|
|
(setq forced-files (delete (car pair) forced-files))
|
|
(setq published t)))
|
|
(dolist (file forced-files)
|
|
(muse-project-publish-file (cdr (assoc file file-alist)) styles t)))
|
|
;; run hook after publishing ends
|
|
(run-hook-with-args 'muse-after-project-publish-hook project)
|
|
;; notify the user that everything is now done
|
|
(if published
|
|
(message "All pages in %s have been published." (car project))
|
|
(message "No pages in %s need publishing at this time."
|
|
(car project)))))
|
|
|
|
;;;###autoload
|
|
(defun muse-project-publish (project &optional force)
|
|
"Publish the pages of PROJECT that need publishing."
|
|
(interactive (list (muse-read-project "Publish project: " nil t)
|
|
current-prefix-arg))
|
|
(setq project (muse-project project))
|
|
(let ((styles (cddr project))
|
|
(muse-current-project project)
|
|
(muse-current-project-global project))
|
|
;; determine the style from the project, or else ask
|
|
(unless styles
|
|
(setq styles (list (muse-publish-get-style))))
|
|
(unless project
|
|
(error "Cannot find a project to publish"))
|
|
;; prompt to save any buffers related to this project
|
|
(muse-project-save-buffers project)
|
|
;; run hook before publishing begins
|
|
(run-hook-with-args 'muse-before-project-publish-hook project)
|
|
;; run the project-level publisher
|
|
(let ((fun (or (muse-get-keyword :publish-project (cadr project) t)
|
|
'muse-project-publish-default)))
|
|
(funcall fun project styles force))))
|
|
|
|
(defun muse-project-batch-publish ()
|
|
"Publish Muse files in batch mode."
|
|
(let ((muse-batch-publishing-p t)
|
|
force)
|
|
(if (string= "--force" (or (car command-line-args-left) ""))
|
|
(setq force t
|
|
command-line-args-left (cdr command-line-args-left)))
|
|
(if command-line-args-left
|
|
(dolist (project command-line-args-left)
|
|
(message "Publishing project %s ..." project)
|
|
(muse-project-publish project force))
|
|
(message "No projects specified."))))
|
|
|
|
(eval-when-compile
|
|
(put 'make-local-hook 'byte-compile nil))
|
|
|
|
(defun muse-project-set-variables ()
|
|
"Load project-specific variables."
|
|
(when (and muse-current-project-global (null muse-current-project))
|
|
(setq muse-current-project muse-current-project-global))
|
|
(let ((vars (muse-get-keyword :set (cadr muse-current-project)))
|
|
sym custom-set var)
|
|
(while vars
|
|
(setq sym (car vars))
|
|
(setq custom-set (or (get sym 'custom-set) 'set))
|
|
(setq var (if (eq (get sym 'custom-type) 'hook)
|
|
(make-local-hook sym)
|
|
(make-local-variable sym)))
|
|
(funcall custom-set var (car (cdr vars)))
|
|
(setq vars (cdr (cdr vars))))))
|
|
|
|
(custom-add-option 'muse-before-publish-hook 'muse-project-set-variables)
|
|
(add-to-list 'muse-before-publish-hook 'muse-project-set-variables)
|
|
|
|
(defun muse-project-delete-output-files (project)
|
|
(interactive
|
|
(list (muse-read-project "Remove all output files for project: " nil t)))
|
|
(setq project (muse-project project))
|
|
(let ((file-alist (muse-project-file-alist project))
|
|
(styles (cddr project))
|
|
output-file path)
|
|
(dolist (entry file-alist)
|
|
(dolist (style styles)
|
|
(setq output-file
|
|
(and (setq path (muse-style-element :path style))
|
|
(expand-file-name
|
|
(concat (muse-style-element :prefix style)
|
|
(car entry)
|
|
(or (muse-style-element :osuffix style)
|
|
(muse-style-element :suffix style)))
|
|
path)))
|
|
(if output-file
|
|
(muse-delete-file-if-exists output-file))))))
|
|
|
|
;;; muse-project.el ends here
|