1 ;;; archive-contents.el --- Auto-generate an Emacs Lisp package archive.
3 ;; Copyright (C) 2011 Free Software Foundation, Inc
5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
7 ;; This program is free software; you can redistribute it and/or modify
8 ;; it under the terms of the GNU General Public License as published by
9 ;; the Free Software Foundation, either version 3 of the License, or
10 ;; (at your option) any later version.
12 ;; This program is distributed in the hope that it will be useful,
13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;; GNU General Public License for more details.
17 ;; You should have received a copy of the GNU General Public License
18 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
26 (defconst archive-contents-subdirectory-regexp
27 "\\([^.].*?\\)-\\([0-9]+\\(?:[.][0-9]+\\|\\(?:pre\\|beta\\|alpha\\)[0-9]+\\)*\\)")
29 (defconst archive-re-no-dot "\\`\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*"
30 "Regular expression matching all files except \".\" and \"..\".")
32 (defun archive--convert-require (elt)
34 (version-to-list (car (cdr elt)))))
36 (defun archive--strip-rcs-id (str)
37 "Strip RCS version ID from the version string STR.
38 If the result looks like a dotted numeric version, return it.
39 Otherwise return nil."
41 (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str)
42 (setq str (substring str (match-end 0))))
44 (if (version-to-list str)
48 (defun archive--delete-elc-files (dir &optional only-orphans)
49 "Recursively delete all .elc files in DIR.
50 Delete backup files also."
51 (dolist (f (directory-files dir t archive-re-no-dot))
52 (cond ((file-directory-p f)
53 (archive--delete-elc-files f))
54 ((or (and (string-match "\\.elc\\'" f)
55 (not (and only-orphans
56 (file-readable-p (replace-match ".el" t t f)))))
57 (backup-file-name-p f))
60 (defun batch-make-archive ()
61 "Process package content directories and generate the archive-contents file."
62 (let ((packages '(1))) ; format-version.
63 (dolist (dir (directory-files default-directory nil archive-re-no-dot))
65 (if (not (file-directory-p dir))
66 (error "Skipping non-package file %s" dir)
67 (let* ((pkg (file-name-nondirectory dir))
68 (autoloads-file (expand-file-name (concat pkg "-autoloads.el") dir))
70 ;; Omit autoloads and .elc files from the package.
71 (if (file-exists-p autoloads-file)
72 (delete-file autoloads-file))
73 (archive--delete-elc-files dir)
74 ;; Test whether this is a simple or multi-file package.
75 (setq simple-p (archive--simple-package-p dir pkg))
77 (apply 'archive--process-simple-package
79 (archive--process-multi-file-package dir pkg))
82 (error (message "%s" (cadr v)))))
84 (pp (nreverse packages) (current-buffer))
85 (write-region nil nil "archive-contents"))))
87 (defun archive--simple-package-p (dir pkg)
88 "Test whether DIR contains a simple package named PKG.
89 If so, return a list (VERSION DESCRIPTION REQ COMMENTARY), where
90 VERSION is the version string of the simple package, DESCRIPTION
91 is the brief description of the package, REQ is a list of
92 requirements, and COMMENTARY is the package commentary.
93 Otherwise, return nil."
94 (let* ((pkg-file (expand-file-name (concat pkg "-pkg.el") dir))
95 (mainfile (expand-file-name (concat pkg ".el") dir))
96 (files (directory-files dir nil archive-re-no-dot))
97 version description req commentary)
98 (dolist (file (prog1 files (setq files ())))
99 (unless (string-match "\\.elc\\'" file)
101 (when (and (or (not (file-exists-p pkg-file))
102 (= (length files) 2))
103 (file-exists-p mainfile))
105 (insert-file-contents mainfile)
106 (goto-char (point-min))
107 (and (looking-at ";;;.*---[ \t]*\\(.*\\)\\(-\\*-.*-\\*-[ \t]*\\)?$")
109 (setq description (match-string 1))
111 (or (archive--strip-rcs-id (lm-header "package-version"))
112 (archive--strip-rcs-id (lm-header "version"))
115 ;; Grab the other fields, which are not mandatory.
116 (let ((requires-str (lm-header "package-requires")))
118 (setq req (mapcar 'archive--convert-require
119 (car (read-from-string requires-str))))))
120 (setq commentary (lm-commentary))
121 (list version description req commentary)))))))
123 (defun archive--process-simple-package (dir pkg vers desc req commentary)
124 "Deploy the contents of DIR into the archive as a simple package.
125 Rename DIR/PKG.el to PKG-VERS.el, delete DIR, and write the
126 package commentary to PKG-readme.txt. Return the descriptor."
127 ;; Write the readme file.
131 (insert (or commentary
132 (prog1 "No description"
133 (message "Missing commentary in package %s" pkg))))
134 (goto-char (point-min))
135 (while (looking-at ";*[ \t]*\\(commentary[: \t]*\\)?\n")
136 (delete-region (match-beginning 0)
138 (uncomment-region (point-min) (point-max))
139 (goto-char (point-max))
140 (while (progn (forward-line -1)
141 (looking-at "[ \t]*\n"))
142 (delete-region (match-beginning 0)
144 (write-region nil nil (concat pkg "-readme.txt")))
145 ;; Write DIR/foo.el to foo-VERS.el and delete DIR
146 (rename-file (expand-file-name (concat pkg ".el") dir)
147 (concat pkg "-" vers ".el"))
148 (delete-directory dir t)
149 (cons (intern pkg) (vector (version-to-list vers) req desc 'single)))
151 (defun archive--process-multi-file-package (dir pkg)
152 "Deploy the contents of DIR into the archive as a multi-file package.
153 Rename DIR/ to PKG-VERS/, and write the package commentary to
154 PKG-readme.txt. Return the descriptor."
155 (let* ((exp (archive--multi-file-package-def dir pkg))
157 (req (mapcar 'archive--convert-require (nth 4 exp)))
158 (readme (expand-file-name "README" dir)))
159 (unless (equal (nth 1 exp) pkg)
160 (error (format "Package name %s doesn't match file name %s"
162 ;; Write the readme file.
163 (when (file-exists-p readme)
164 (copy-file readme (concat pkg "-readme.txt") 'ok-if-already-exists))
165 (rename-file dir (concat pkg "-" vers))
166 (cons (intern pkg) (vector (version-to-list vers) req (nth 3 exp) 'tar))))
168 (defun archive--multi-file-package-def (dir pkg)
169 "Reurn the `define-package' form in the file DIR/PKG-pkg.el."
170 (let ((pkg-file (expand-file-name (concat pkg "-pkg.el") dir)))
172 (unless (file-exists-p pkg-file)
173 (error "File not found: %s" pkg-file))
174 (insert-file-contents pkg-file)
175 (goto-char (point-min))
176 (read (current-buffer)))))
178 (defun batch-make-site-dir (package-dir site-dir)
180 (setq package-dir (expand-file-name package-dir default-directory))
181 (setq site-dir (expand-file-name site-dir default-directory))
182 (dolist (dir (directory-files package-dir t archive-re-no-dot))
184 (if (not (file-directory-p dir))
185 (error "Skipping non-package file %s" dir)
186 (let* ((pkg (file-name-nondirectory dir))
187 (autoloads-file (expand-file-name (concat pkg "-autoloads.el") dir))
189 ;; Omit autoloads and .elc files from the package.
190 (if (file-exists-p autoloads-file)
191 (delete-file autoloads-file))
192 (archive--delete-elc-files dir 'only-orphans)
193 ;; Test whether this is a simple or multi-file package.
194 (setq simple-p (archive--simple-package-p dir pkg))
197 (apply 'archive--write-pkg-file dir pkg simple-p)
198 (setq version (car simple-p)))
200 (nth 2 (archive--multi-file-package-def dir pkg))))
201 (make-symbolic-link (expand-file-name dir package-dir)
202 (expand-file-name (concat pkg "-" version)
205 (let ((make-backup-files nil))
206 (package-generate-autoloads pkg dir))
207 (let ((load-path (cons dir load-path)))
208 ;; FIXME: Don't compile the -pkg.el files!
209 (byte-recompile-directory dir 0))))
211 (error (message "%s" (cadr v))))))
213 (defun archive--write-pkg-file (pkg-dir name version desc requires &rest ignored)
214 (let ((pkg-file (expand-file-name (concat name "-pkg.el") pkg-dir))
218 (concat (format ";; Generated package description from %s.el\n"
221 (list 'define-package
226 ;; Turn version lists into string form.
230 (package-version-join (cadr elt))))
238 ;; no-byte-compile: t
239 ;; lexical-binding: t
242 (provide 'archive-contents)
243 ;;; archive-contents.el ends here