summaryrefslogtreecommitdiffstats
path: root/emacs.d/elisp/muse/muse-project.el
diff options
context:
space:
mode:
Diffstat (limited to 'emacs.d/elisp/muse/muse-project.el')
-rw-r--r--emacs.d/elisp/muse/muse-project.el973
1 files changed, 0 insertions, 973 deletions
diff --git a/emacs.d/elisp/muse/muse-project.el b/emacs.d/elisp/muse/muse-project.el
deleted file mode 100644
index 7489706..0000000
--- a/emacs.d/elisp/muse/muse-project.el
+++ /dev/null
@@ -1,973 +0,0 @@
-;;; 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
generated by cgit v1.2.3-54-g00ecf (git 2.39.0) at 2024-07-09 10:49:58 +0000