1 ;;; archive-contents.el --- Auto-generate an Emacs Lisp package archive.
3 ;; Copyright (C) 2011, 2012 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/>.
24 (eval-when-compile (require 'cl
))
28 (defconst archive-contents-subdirectory-regexp
29 "\\([^.].*?\\)-\\([0-9]+\\(?:[.][0-9]+\\|\\(?:pre\\|beta\\|alpha\\)[0-9]+\\)*\\)")
31 (defconst archive-re-no-dot
"\\`\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*"
32 "Regular expression matching all files except \".\" and \"..\".")
34 (defun archive--convert-require (elt)
36 (version-to-list (car (cdr elt
)))))
38 (defun archive--strip-rcs-id (str)
39 "Strip RCS version ID from the version string STR.
40 If the result looks like a dotted numeric version, return it.
41 Otherwise return nil."
43 (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str
)
44 (setq str
(substring str
(match-end 0))))
46 (if (version-to-list str
)
50 (defun archive--delete-elc-files (dir &optional only-orphans
)
51 "Recursively delete all .elc files in DIR.
52 Delete backup files also."
53 (dolist (f (directory-files dir t archive-re-no-dot
))
54 (cond ((file-directory-p f
)
55 (archive--delete-elc-files f
))
56 ((or (and (string-match "\\.elc\\'" f
)
57 (not (and only-orphans
58 (file-readable-p (replace-match ".el" t t f
)))))
59 (backup-file-name-p f
))
62 (defun batch-make-archive ()
63 "Process package content directories and generate the archive-contents file."
64 (let ((packages '(1))) ; format-version.
65 (dolist (dir (directory-files default-directory nil archive-re-no-dot
))
67 (if (not (file-directory-p dir
))
68 (error "Skipping non-package file %s" dir
)
69 (let* ((pkg (file-name-nondirectory dir
))
70 (autoloads-file (expand-file-name (concat pkg
"-autoloads.el") dir
))
72 ;; Omit autoloads and .elc files from the package.
73 (if (file-exists-p autoloads-file
)
74 (delete-file autoloads-file
))
75 (archive--delete-elc-files dir
)
76 ;; Test whether this is a simple or multi-file package.
77 (setq simple-p
(archive--simple-package-p dir pkg
))
79 (apply 'archive--process-simple-package
81 (archive--process-multi-file-package dir pkg
))
84 (error (message "%s" (cadr v
)))))
86 (pp (nreverse packages
) (current-buffer))
87 (write-region nil nil
"archive-contents"))))
89 (defun archive--simple-package-p (dir pkg
)
90 "Test whether DIR contains a simple package named PKG.
91 If so, return a list (VERSION DESCRIPTION REQ COMMENTARY), where
92 VERSION is the version string of the simple package, DESCRIPTION
93 is the brief description of the package, REQ is a list of
94 requirements, and COMMENTARY is the package commentary.
95 Otherwise, return nil."
96 (let* ((pkg-file (expand-file-name (concat pkg
"-pkg.el") dir
))
97 (mainfile (expand-file-name (concat pkg
".el") dir
))
98 (files (directory-files dir nil archive-re-no-dot
))
99 version description req commentary
)
100 (dolist (file (prog1 files
(setq files
())))
101 (unless (string-match "\\.elc\\'" file
)
103 (when (and (or (not (file-exists-p pkg-file
))
104 (= (length files
) 2))
105 (file-exists-p mainfile
))
107 (insert-file-contents mainfile
)
108 (goto-char (point-min))
109 (and (looking-at ";;;.*---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$")
111 (setq description
(match-string 1))
113 (or (archive--strip-rcs-id (lm-header "package-version"))
114 (archive--strip-rcs-id (lm-header "version"))
117 ;; Grab the other fields, which are not mandatory.
118 (let ((requires-str (lm-header "package-requires")))
120 (setq req
(mapcar 'archive--convert-require
121 (car (read-from-string requires-str
))))))
122 (setq commentary
(lm-commentary))
123 (list version description req commentary
)))))))
125 (defun archive--process-simple-package (dir pkg vers desc req commentary
)
126 "Deploy the contents of DIR into the archive as a simple package.
127 Rename DIR/PKG.el to PKG-VERS.el, delete DIR, and write the
128 package commentary to PKG-readme.txt. Return the descriptor."
129 ;; Write the readme file.
133 (insert (or commentary
134 (prog1 "No description"
135 (message "Missing commentary in package %s" pkg
))))
136 (goto-char (point-min))
137 (while (looking-at ";*[ \t]*\\(commentary[: \t]*\\)?\n")
138 (delete-region (match-beginning 0)
140 (uncomment-region (point-min) (point-max))
141 (goto-char (point-max))
142 (while (progn (forward-line -
1)
143 (looking-at "[ \t]*\n"))
144 (delete-region (match-beginning 0)
146 (write-region nil nil
(concat pkg
"-readme.txt")))
147 ;; Write DIR/foo.el to foo-VERS.el and delete DIR
148 (rename-file (expand-file-name (concat pkg
".el") dir
)
149 (concat pkg
"-" vers
".el"))
150 (delete-directory dir t
)
151 (cons (intern pkg
) (vector (version-to-list vers
) req desc
'single
)))
153 (defun archive--make-changelog (dir)
154 "Export Bzr log info of DIR into a ChangeLog file."
155 (let ((default-directory (file-name-as-directory (expand-file-name dir
))))
156 (call-process "bzr" nil
'(:file
"ChangeLog") nil
157 "log" "--gnu-changelog" ".")))
159 (defun archive--process-multi-file-package (dir pkg
)
160 "Deploy the contents of DIR into the archive as a multi-file package.
161 Rename DIR/ to PKG-VERS/, and write the package commentary to
162 PKG-readme.txt. Return the descriptor."
163 (let* ((exp (archive--multi-file-package-def dir pkg
))
165 (req (mapcar 'archive--convert-require
(nth 4 exp
)))
166 (readme (expand-file-name "README" dir
)))
167 (archive--make-changelog dir
)
168 (unless (equal (nth 1 exp
) pkg
)
169 (error (format "Package name %s doesn't match file name %s"
171 ;; Write the readme file.
172 (when (file-exists-p readme
)
173 (copy-file readme
(concat pkg
"-readme.txt") 'ok-if-already-exists
))
174 (rename-file dir
(concat pkg
"-" vers
))
175 (cons (intern pkg
) (vector (version-to-list vers
) req
(nth 3 exp
) 'tar
))))
177 (defun archive--multi-file-package-def (dir pkg
)
178 "Reurn the `define-package' form in the file DIR/PKG-pkg.el."
179 (let ((pkg-file (expand-file-name (concat pkg
"-pkg.el") dir
)))
181 (unless (file-exists-p pkg-file
)
182 (error "File not found: %s" pkg-file
))
183 (insert-file-contents pkg-file
)
184 (goto-char (point-min))
185 (read (current-buffer)))))
187 (defun batch-make-site-dir (package-dir site-dir
)
189 (setq package-dir
(expand-file-name package-dir default-directory
))
190 (setq site-dir
(expand-file-name site-dir default-directory
))
191 (dolist (dir (directory-files package-dir t archive-re-no-dot
))
193 (if (not (file-directory-p dir
))
194 (error "Skipping non-package file %s" dir
)
195 (let* ((pkg (file-name-nondirectory dir
))
196 (autoloads-file (expand-file-name
197 (concat pkg
"-autoloads.el") dir
))
199 ;; Omit autoloads and .elc files from the package.
200 (if (file-exists-p autoloads-file
)
201 (delete-file autoloads-file
))
202 (archive--delete-elc-files dir
'only-orphans
)
203 ;; Test whether this is a simple or multi-file package.
204 (setq simple-p
(archive--simple-package-p dir pkg
))
207 (apply 'archive--write-pkg-file dir pkg simple-p
)
208 (setq version
(car simple-p
)))
210 (nth 2 (archive--multi-file-package-def dir pkg
))))
211 (make-symbolic-link (expand-file-name dir package-dir
)
212 (expand-file-name (concat pkg
"-" version
)
215 (let ((make-backup-files nil
))
216 (package-generate-autoloads pkg dir
))
217 (let ((load-path (cons dir load-path
)))
218 ;; FIXME: Don't compile the -pkg.el files!
219 (byte-recompile-directory dir
0))))
221 (error (message "%s" (cadr v
))))))
223 (defun batch-make-site-package (sdir)
224 (let* ((dest (car (file-attributes sdir
)))
225 (pkg (file-name-nondirectory (directory-file-name (or dest sdir
))))
226 (dir (or dest sdir
)))
227 (let ((make-backup-files nil
))
228 (package-generate-autoloads pkg dir
))
229 (let ((load-path (cons dir load-path
)))
230 ;; FIXME: Don't compile the -pkg.el files!
231 (byte-recompile-directory dir
0))))
233 (defun archive--write-pkg-file (pkg-dir name version desc requires
&rest ignored
)
234 (let ((pkg-file (expand-file-name (concat name
"-pkg.el") pkg-dir
))
238 (concat (format ";; Generated package description from %s.el\n"
241 (list 'define-package
246 ;; Turn version lists into string form.
250 (package-version-join (cadr elt
))))
256 ;;; Make the HTML pages for online browsing.
258 (defun archive--html-header (title)
259 (format "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">
263 <meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\">
266 <h1 align=\"center\">%s</h1>"
269 (defun archive--html-bytes-format (bytes) ;Aka memory-usage-format.
270 (setq bytes
(/ bytes
1024.0))
271 (let ((units '(;; "B"
272 "kB" "MB" "GB" "TB")))
273 (while (>= bytes
1024)
274 (setq bytes
(/ bytes
1024.0))
275 (setq units
(cdr units
)))
277 ;; ((integerp bytes) (format "%4d%s" bytes (car units)))
278 ((>= bytes
100) (format "%4.0f%s" bytes
(car units
)))
279 ((>= bytes
10) (format "%4.1f%s" bytes
(car units
)))
280 (t (format "%4.2f%s" bytes
(car units
))))))
282 (defun archive--html-make-pkg (pkg files
)
283 (let ((name (symbol-name (car pkg
)))
284 (latest (package-version-join (aref (cdr pkg
) 0)))
285 (desc (aref (cdr pkg
) 2)))
286 ;; FIXME: Add maintainer info.
288 (insert (archive--html-header (format "GNU ELPA - %s" name
)))
289 (insert (format "<p>Description: %s</p>\n" desc
))
290 (let* ((file (cdr (assoc latest files
)))
291 (attrs (file-attributes file
)))
292 (insert (format "<p>Latest: <a href=%S>%s</a>, %s, %s</p>\n"
294 (format-time-string "%Y-%b-%d" (nth 5 attrs
))
295 (archive--html-bytes-format (nth 7 attrs
)))))
296 ;; FIXME: This URL is wrong for Org.
297 (let ((repurl (concat "http://bzr.sv.gnu.org/lh/emacs/elpa/files/head:/packages/" name
)))
298 (insert (format "<p>Repository: <a href=%S>%s</a></p>" repurl repurl
)))
299 (let ((readme (concat name
"-readme.txt"))
300 (end (copy-marker (point) t
)))
301 (when (file-readable-p readme
)
302 (insert "<p>Full description:<pre>\n")
303 (insert-file-contents readme
)
305 (insert "\n</pre></p>")))
306 (unless (< (length files
) 2)
307 (insert (format "<p>Old versions:<table cellpadding=\"3\" border=\"1\">\n"))
309 (unless (equal (pop file
) latest
)
310 (let ((attrs (file-attributes file
)))
311 (insert (format "<tr><td><a href=%S>%s</a></td><td>%s</td><td>%s</td>\n"
313 (format-time-string "%Y-%b-%d" (nth 5 attrs
))
314 (archive--html-bytes-format (nth 7 attrs
)))))))
315 (insert "</table></body>\n"))
316 (write-region (point-min) (point-max) (concat name
".html")))))
318 (defun archive--html-make-index (pkgs)
320 (insert (archive--html-header "GNU ELPA Packages"))
321 (insert "<table cellpadding=\"3\" border=\"1\">\n")
322 (insert "<tr><th>Package</th><th>Version</th><th>Description</th></tr>\n")
324 (insert (format "<tr><td><a href=\"%s.html\">%s</a></td><td>%s</td><td>%s</td></tr>\n"
326 (package-version-join (aref (cdr pkg
) 0))
327 (aref (cdr pkg
) 2))))
328 (insert "</table></body>\n")
329 (write-region (point-min) (point-max) "index.html")))
331 (defun batch-html-make-index ()
332 (let ((packages (make-hash-table :test
#'equal
))
335 (insert-file-contents "archive-contents")
336 (goto-char (point-min))
337 ;; Skip the first element which is a version number.
338 (cdr (read (current-buffer))))))
339 (dolist (file (directory-files default-directory nil
))
341 ((member file
'("." ".." "elpa.rss" "index.html" "archive-contents")))
342 ((string-match "\\.html\\'" file
))
343 ((string-match "-readme\\.txt\\'" file
)
344 (let ((name (substring file
0 (match-beginning 0))))
345 (puthash name
(gethash name packages
) packages
)))
346 ((string-match "-\\([0-9][^-]*\\)\\.\\(tar\\|el\\)\\'" file
)
347 (let ((name (substring file
0 (match-beginning 0)))
348 (version (match-string 1 file
)))
349 (push (cons version file
) (gethash name packages
))))
350 (t (message "Unknown file %S" file
))))
351 (dolist (pkg archive-contents
)
352 (archive--html-make-pkg pkg
(gethash (symbol-name (car pkg
)) packages
)))
353 ;; FIXME: Add (old?) packages that are in `packages' but not in
355 (archive--html-make-index archive-contents
)))
359 ;; lexical-binding: t
362 (provide 'archive-contents
)
363 ;;; archive-contents.el ends here