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 (message "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))
83 (error (error "Error in %s: %S" dir v))))
85 (pp (nreverse packages) (current-buffer))
86 (write-region nil nil "archive-contents"))))
88 (defun batch-prepare-packages ()
89 "Prepare the `packages' directory inside the Bzr checkout.
90 Expects to be called from within the `packages' directory.
91 \"Prepare\" here is for subsequent construction of the packages and archive,
92 so it is meant to refresh any generated files we may need.
93 Currently only refreshes the ChangeLog files."
94 (let* ((wit ".changelog-witness")
95 (prevno (or (with-temp-buffer
96 (ignore-errors (insert-file-contents wit))
97 (when (looking-at "[1-9][0-9]*\\'")
98 (string-to-number (match-string 0))))
101 (or (with-temp-buffer
102 (call-process "bzr" nil '(t) nil "revno")
103 (goto-char (point-min))
104 (when (looking-at "[1-9][0-9]*$")
105 (string-to-number (match-string 0))))
106 (error "bzr revno did not return a number as expected")))
108 (unless (= prevno new-revno)
110 (unless (zerop (call-process "bzr" nil '(t) nil "log" "-v"
111 (format "-r%d.." (1+ prevno))))
112 (error "Error signaled by bzr log -v -r%d.." (1+ prevno)))
113 (goto-char (point-min))
114 (while (re-search-forward "^ packages/\\([-[:alnum:]]+\\)/" nil t)
115 (pushnew (match-string 1) pkgs :test #'equal))))
118 (if (file-directory-p pkg)
119 (archive--make-changelog pkg))
120 (error (message "Error: %S" v))))
121 (write-region (number-to-string new-revno) nil wit nil 'quiet)))
123 (defun archive--simple-package-p (dir pkg)
124 "Test whether DIR contains a simple package named PKG.
125 If so, return a list (VERSION DESCRIPTION REQ COMMENTARY), where
126 VERSION is the version string of the simple package, DESCRIPTION
127 is the brief description of the package, REQ is a list of
128 requirements, and COMMENTARY is the package commentary.
129 Otherwise, return nil."
130 (let* ((pkg-file (expand-file-name (concat pkg "-pkg.el") dir))
131 (mainfile (expand-file-name (concat pkg ".el") dir))
132 (files (directory-files dir nil archive-re-no-dot))
133 version description req commentary)
134 (dolist (file (prog1 files (setq files ())))
135 (unless (string-match "\\.elc\\'" file)
137 (setq files (delete (concat pkg "-pkg.el") files))
138 (setq files (delete (concat pkg "-autoloads.el") files))
139 (setq files (delete "ChangeLog" files))
141 ((and (or (not (file-exists-p pkg-file))
142 (= (length files) 1))
143 (file-exists-p mainfile))
145 (insert-file-contents mainfile)
146 (goto-char (point-min))
147 (if (not (looking-at ";;;.*---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$"))
148 (error "Can't parse first line of %s" mainfile)
149 (setq description (match-string 1))
151 (or (archive--strip-rcs-id (lm-header "package-version"))
152 (archive--strip-rcs-id (lm-header "version"))
153 (error "Missing `version' header")))
154 ;; Grab the other fields, which are not mandatory.
155 (let ((requires-str (lm-header "package-requires")))
157 (setq req (mapcar 'archive--convert-require
158 (car (read-from-string requires-str))))))
159 (setq commentary (lm-commentary))
160 (list version description req commentary))))
161 ((not (file-exists-p pkg-file))
162 (error "Can find single file nor package desc file in %s" dir)))))
164 (defun archive--process-simple-package (dir pkg vers desc req commentary)
165 "Deploy the contents of DIR into the archive as a simple package.
166 Rename DIR/PKG.el to PKG-VERS.el, delete DIR, and write the
167 package commentary to PKG-readme.txt. Return the descriptor."
168 ;; Write the readme file.
172 (insert (or commentary
173 (prog1 "No description"
174 (message "Missing commentary in package %s" pkg))))
175 (goto-char (point-min))
176 (while (looking-at ";*[ \t]*\\(commentary[: \t]*\\)?\n")
177 (delete-region (match-beginning 0)
179 (uncomment-region (point-min) (point-max))
180 (goto-char (point-max))
181 (while (progn (forward-line -1)
182 (looking-at "[ \t]*\n"))
183 (delete-region (match-beginning 0)
185 (write-region nil nil (concat pkg "-readme.txt")))
186 ;; Write DIR/foo.el to foo-VERS.el and delete DIR
187 (rename-file (expand-file-name (concat pkg ".el") dir)
188 (concat pkg "-" vers ".el"))
189 ;; Add the content of the ChangeLog.
190 (let ((cl (expand-file-name "ChangeLog" dir)))
191 (with-current-buffer (find-file-noselect (concat pkg "-" vers ".el"))
192 (goto-char (point-max))
193 (re-search-backward "^;;;.*ends here")
194 (re-search-backward "^(provide")
195 (skip-chars-backward " \t\n")
196 (insert "\n\n;;;; ChangeLog:\n\n")
197 (let* ((start (point))
198 (end (copy-marker start t)))
199 (insert-file-contents cl)
201 (unless (bolp) (insert "\n"))
202 (while (progn (forward-line -1) (>= (point) start))
204 (set (make-local-variable 'backup-inhibited) t)
207 (delete-directory dir t)
208 (cons (intern pkg) (vector (version-to-list vers) req desc 'single)))
210 (defun archive--make-changelog (dir)
211 "Export Bzr log info of DIR into a ChangeLog file."
212 (message "Refreshing ChangeLog in %S" dir)
213 (let ((default-directory (file-name-as-directory (expand-file-name dir))))
215 (set-buffer-multibyte nil)
216 (let ((coding-system-for-read 'binary)
217 (coding-system-for-write 'binary))
218 (if (file-readable-p "ChangeLog") (insert-file-contents "ChangeLog"))
219 (let ((old-md5 (md5 (current-buffer))))
221 (call-process "bzr" nil (current-buffer) nil
222 "log" "--gnu-changelog" ".")
223 (if (equal old-md5 (md5 (current-buffer)))
224 (message "ChangeLog's md5 unchanged for %S" dir)
225 (write-region (point-min) (point-max) "ChangeLog" nil 'quiet)))))))
227 (defun archive--process-multi-file-package (dir pkg)
228 "Deploy the contents of DIR into the archive as a multi-file package.
229 Rename DIR/ to PKG-VERS/, and write the package commentary to
230 PKG-readme.txt. Return the descriptor."
231 (let* ((exp (archive--multi-file-package-def dir pkg))
233 (req (mapcar 'archive--convert-require (nth 4 exp)))
234 (readme (expand-file-name "README" dir)))
235 (unless (equal (nth 1 exp) pkg)
236 (error (format "Package name %s doesn't match file name %s"
238 ;; Write the readme file.
239 (when (file-exists-p readme)
240 (copy-file readme (concat pkg "-readme.txt") 'ok-if-already-exists))
241 (rename-file dir (concat pkg "-" vers))
242 (cons (intern pkg) (vector (version-to-list vers) req (nth 3 exp) 'tar))))
244 (defun archive--multi-file-package-def (dir pkg)
245 "Reurn the `define-package' form in the file DIR/PKG-pkg.el."
246 (let ((pkg-file (expand-file-name (concat pkg "-pkg.el") dir)))
248 (unless (file-exists-p pkg-file)
249 (error "File not found: %s" pkg-file))
250 (insert-file-contents pkg-file)
251 (goto-char (point-min))
252 (read (current-buffer)))))
254 (defun batch-make-site-dir (package-dir site-dir)
256 (setq package-dir (expand-file-name package-dir default-directory))
257 (setq site-dir (expand-file-name site-dir default-directory))
258 (dolist (dir (directory-files package-dir t archive-re-no-dot))
259 (if (not (file-directory-p dir))
260 (message "Skipping non-package file %s" dir)
261 (let* ((pkg (file-name-nondirectory dir))
262 (autoloads-file (expand-file-name
263 (concat pkg "-autoloads.el") dir))
265 ;; Omit autoloads and .elc files from the package.
266 (if (file-exists-p autoloads-file)
267 (delete-file autoloads-file))
268 (archive--delete-elc-files dir 'only-orphans)
269 ;; Test whether this is a simple or multi-file package.
270 (setq simple-p (archive--simple-package-p dir pkg))
273 (apply 'archive--write-pkg-file dir pkg simple-p)
274 (setq version (car simple-p)))
276 (nth 2 (archive--multi-file-package-def dir pkg))))
277 (make-symbolic-link (expand-file-name dir package-dir)
278 (expand-file-name (concat pkg "-" version)
281 (let ((make-backup-files nil))
282 (package-generate-autoloads pkg dir))
283 (let ((load-path (cons dir load-path)))
284 ;; FIXME: Don't compile the -pkg.el files!
285 (byte-recompile-directory dir 0))))))
287 (defun batch-make-site-package (sdir)
288 (let* ((dest (car (file-attributes sdir)))
289 (pkg (file-name-nondirectory (directory-file-name (or dest sdir))))
290 (dir (or dest sdir)))
291 (let ((make-backup-files nil))
292 (package-generate-autoloads pkg dir))
293 (let ((load-path (cons dir load-path)))
294 ;; FIXME: Don't compile the -pkg.el files!
295 (byte-recompile-directory dir 0))))
297 (defun archive--write-pkg-file (pkg-dir name version desc requires &rest ignored)
298 (let ((pkg-file (expand-file-name (concat name "-pkg.el") pkg-dir))
302 (concat (format ";; Generated package description from %s.el\n"
305 (list 'define-package
310 ;; Turn version lists into string form.
314 (package-version-join (cadr elt))))
320 ;;; Make the HTML pages for online browsing.
322 (defun archive--html-header (title)
323 (format "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">
327 <meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\">
330 <h1 align=\"center\">%s</h1>"
333 (defun archive--html-bytes-format (bytes) ;Aka memory-usage-format.
334 (setq bytes (/ bytes 1024.0))
335 (let ((units '(;; "B"
336 "kB" "MB" "GB" "TB")))
337 (while (>= bytes 1024)
338 (setq bytes (/ bytes 1024.0))
339 (setq units (cdr units)))
341 ;; ((integerp bytes) (format "%4d%s" bytes (car units)))
342 ((>= bytes 100) (format "%4.0f%s" bytes (car units)))
343 ((>= bytes 10) (format "%4.1f%s" bytes (car units)))
344 (t (format "%4.2f%s" bytes (car units))))))
346 (defun archive--html-make-pkg (pkg files)
347 (let ((name (symbol-name (car pkg)))
348 (latest (package-version-join (aref (cdr pkg) 0)))
349 (desc (aref (cdr pkg) 2)))
350 ;; FIXME: Add maintainer info.
352 (insert (archive--html-header (format "GNU ELPA - %s" name)))
353 (insert (format "<p>Description: %s</p>\n" desc))
354 (let* ((file (cdr (assoc latest files)))
355 (attrs (file-attributes file)))
356 (insert (format "<p>Latest: <a href=%S>%s</a>, %s, %s</p>\n"
358 (format-time-string "%Y-%b-%d" (nth 5 attrs))
359 (archive--html-bytes-format (nth 7 attrs)))))
360 ;; FIXME: This URL is wrong for Org.
361 (let ((repurl (concat "http://bzr.sv.gnu.org/lh/emacs/elpa/files/head:/packages/" name)))
362 (insert (format "<p>Repository: <a href=%S>%s</a></p>" repurl repurl)))
363 (let ((readme (concat name "-readme.txt"))
364 (end (copy-marker (point) t)))
365 (when (file-readable-p readme)
366 (insert "<p>Full description:<pre>\n")
367 (insert-file-contents readme)
369 (insert "\n</pre></p>")))
370 (unless (< (length files) 2)
371 (insert (format "<p>Old versions:<table cellpadding=\"3\" border=\"1\">\n"))
373 (unless (equal (pop file) latest)
374 (let ((attrs (file-attributes file)))
375 (insert (format "<tr><td><a href=%S>%s</a></td><td>%s</td><td>%s</td>\n"
377 (format-time-string "%Y-%b-%d" (nth 5 attrs))
378 (archive--html-bytes-format (nth 7 attrs)))))))
379 (insert "</table></body>\n"))
380 (write-region (point-min) (point-max) (concat name ".html")))))
382 (defun archive--html-make-index (pkgs)
384 (insert (archive--html-header "GNU ELPA Packages"))
385 (insert "<table cellpadding=\"3\" border=\"1\">\n")
386 (insert "<tr><th>Package</th><th>Version</th><th>Description</th></tr>\n")
388 (insert (format "<tr><td><a href=\"%s.html\">%s</a></td><td>%s</td><td>%s</td></tr>\n"
390 (package-version-join (aref (cdr pkg) 0))
391 (aref (cdr pkg) 2))))
392 (insert "</table></body>\n")
393 (write-region (point-min) (point-max) "index.html")))
395 (defun batch-html-make-index ()
396 (let ((packages (make-hash-table :test #'equal))
399 (insert-file-contents "archive-contents")
400 (goto-char (point-min))
401 ;; Skip the first element which is a version number.
402 (cdr (read (current-buffer))))))
403 (dolist (file (directory-files default-directory nil))
405 ((member file '("." ".." "elpa.rss" "index.html" "archive-contents")))
406 ((string-match "\\.html\\'" file))
407 ((string-match "-readme\\.txt\\'" file)
408 (let ((name (substring file 0 (match-beginning 0))))
409 (puthash name (gethash name packages) packages)))
410 ((string-match "-\\([0-9][^-]*\\)\\.\\(tar\\|el\\)\\'" file)
411 (let ((name (substring file 0 (match-beginning 0)))
412 (version (match-string 1 file)))
413 (push (cons version file) (gethash name packages))))
414 (t (message "Unknown file %S" file))))
415 (dolist (pkg archive-contents)
416 (archive--html-make-pkg pkg (gethash (symbol-name (car pkg)) packages)))
417 ;; FIXME: Add (old?) packages that are in `packages' but not in
419 (archive--html-make-index archive-contents)))
423 ;; lexical-binding: t
426 (provide 'archive-contents)
427 ;;; archive-contents.el ends here