1 ;;; archive-contents.el --- Auto-generate an Emacs Lisp package archive. -*- lexical-binding:t -*-
3 ;; Copyright (C) 2011-2014 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))
29 (defconst archive-contents-subdirectory-regexp
30 "\\([^.].*?\\)-\\([0-9]+\\(?:[.][0-9]+\\|\\(?:pre\\|beta\\|alpha\\)[0-9]+\\)*\\)")
32 (defconst archive-re-no-dot "\\`\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*"
33 "Regular expression matching all files except \".\" and \"..\".")
35 (defun archive--version-to-list (vers)
37 (let ((l (version-to-list vers)))
38 ;; Signal an error for things like "1.02" which is parsed as "1.2".
39 (assert (equal vers (package-version-join l)) nil
40 "Unsupported version syntax %S" vers)
43 (defun archive--convert-require (elt)
45 (archive--version-to-list (car (cdr elt)))))
47 (defun archive--strip-rcs-id (str)
48 "Strip RCS version ID from the version string STR.
49 If the result looks like a dotted numeric version, return it.
50 Otherwise return nil."
52 (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str)
53 (setq str (substring str (match-end 0))))
55 (if (archive--version-to-list str)
59 (defun archive--delete-elc-files (dir &optional only-orphans)
60 "Recursively delete all .elc files in DIR.
61 Delete backup files also."
62 (dolist (f (directory-files dir t archive-re-no-dot))
63 (cond ((file-directory-p f)
64 (archive--delete-elc-files f))
65 ((or (and (string-match "\\.elc\\'" f)
66 (not (and only-orphans
67 (file-readable-p (replace-match ".el" t t f)))))
68 (backup-file-name-p f))
71 (defun batch-make-archive ()
72 "Process package content directories and generate the archive-contents file."
73 (let ((packages '(1))) ; format-version.
74 (dolist (dir (directory-files default-directory nil archive-re-no-dot))
76 (if (not (file-directory-p dir))
77 (message "Skipping non-package file %s" dir)
78 (let* ((pkg (file-name-nondirectory dir))
79 (autoloads-file (expand-file-name (concat pkg "-autoloads.el") dir)))
80 ;; Omit autoloads and .elc files from the package.
81 (if (file-exists-p autoloads-file)
82 (delete-file autoloads-file))
83 (archive--delete-elc-files dir)
84 (let ((metadata (archive--metadata dir pkg)))
85 ;; (nth 1 metadata) is nil for "org" which is the only package
86 ;; still using the "org-pkg.el file to specify the metadata.
87 (if (and (nth 1 metadata)
88 (< (string-to-number (nth 1 metadata)) 0))
89 (progn ;; Negative version: don't publish this package yet!
90 (message "Package %s not released yet!" dir)
91 (delete-directory dir 'recursive))
92 (push (if (car metadata)
93 (apply #'archive--process-simple-package
94 dir pkg (cdr metadata))
96 (apply #'archive--write-pkg-file
97 dir pkg (cdr metadata)))
98 (archive--process-multi-file-package dir pkg))
100 ((debug error) (error "Error in %s: %S" dir v))))
102 (pp (nreverse packages) (current-buffer))
103 (write-region nil nil "archive-contents"))))
105 (defconst archive--revno-re "[0-9a-f]+")
107 (defun archive-prepare-packages (srcdir)
108 "Prepare the `packages' directory inside the Git checkout.
109 Expects to be called from within the `packages' directory.
110 \"Prepare\" here is for subsequent construction of the packages and archive,
111 so it is meant to refresh any generated files we may need.
112 Currently only refreshes the ChangeLog files."
113 (setq srcdir (file-name-as-directory (expand-file-name srcdir)))
114 (let* ((wit ".changelog-witness")
115 (prevno (with-temp-buffer
116 (insert-file-contents wit)
117 (if (looking-at (concat archive--revno-re "$"))
119 (error "Can't find previous revision name"))))
121 (or (with-temp-buffer
122 (let ((default-directory srcdir))
123 (call-process "git" nil '(t) nil "rev-parse" "HEAD")
124 (goto-char (point-min))
125 (when (looking-at (concat archive--revno-re "$"))
127 (error "Couldn't find the current revision's name")))
129 (unless (equal prevno new-revno)
131 (let ((default-directory srcdir))
132 (unless (zerop (call-process "git" nil '(t) nil "diff"
133 "--dirstat=cumulative,0"
135 (error "Error signaled by git diff --dirstat %d" prevno)))
136 (goto-char (point-min))
137 (while (re-search-forward "^[ \t.0-9%]* packages/\\([-[:alnum:]]+\\)/$"
139 (push (match-string 1) pkgs))))
140 (let ((default-directory (expand-file-name "packages/")))
143 (if (file-directory-p pkg)
144 (archive--make-changelog pkg (expand-file-name "packages/"
146 (error (message "Error: %S" v)))))
147 (write-region new-revno nil wit nil 'quiet)
148 ;; Also update the ChangeLog of external packages.
149 (let ((default-directory (expand-file-name "packages/")))
150 (dolist (dir (directory-files "."))
151 (and (not (member dir '("." "..")))
152 (file-directory-p dir)
153 (let ((index (expand-file-name
154 (concat "packages/" dir "/.git/index")
156 (cl (expand-file-name "ChangeLog" dir)))
157 (and (file-exists-p index)
158 (or (not (file-exists-p cl))
159 (file-newer-than-file-p index cl))))
160 (archive--make-changelog
161 dir (expand-file-name "packages/" srcdir)))))
164 (defun archive--metadata (dir pkg)
165 "Return a list (SIMPLE VERSION DESCRIPTION REQ EXTRAS),
166 where SIMPLE is non-nil if the package is simple;
167 VERSION is the version string of the simple package;
168 DESCRIPTION is the brief description of the package;
169 REQ is a list of requirements;
170 EXTRAS is an alist with additional metadata.
172 PKG is the name of the package and DIR is the directory where it is."
173 (let* ((mainfile (expand-file-name (concat pkg ".el") dir))
174 (files (directory-files dir nil "\\.el\\'")))
175 (setq files (delete (concat pkg "-pkg.el") files))
176 (setq files (delete (concat pkg "-autoloads.el") files))
178 ((file-exists-p mainfile)
180 (insert-file-contents mainfile)
181 (goto-char (point-min))
182 (if (not (looking-at ";;;.*---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$"))
183 (error "Can't parse first line of %s" mainfile)
184 ;; Grab the other fields, which are not mandatory.
185 (let* ((description (match-string 1))
187 (or (archive--strip-rcs-id (lm-header "package-version"))
188 (archive--strip-rcs-id (lm-header "version"))
189 (unless (equal pkg "org")
190 (error "Missing `version' header"))))
191 (requires-str (lm-header "package-requires"))
192 (pt (lm-header "package-type"))
193 (simple (if pt (equal pt "simple") (= (length files) 1)))
194 (keywords (lm-keywords-list))
195 (url (or (lm-header "url")
196 (format "http://elpa.gnu.org/packages/%s.html" pkg)))
199 (mapcar 'archive--convert-require
200 (car (read-from-string requires-str))))))
201 (list simple version description req
203 (list (cons :url url)
204 (cons :keywords keywords)))))))
206 (error "Can find main file %s file in %s" mainfile dir)))))
208 (defun archive--process-simple-package (dir pkg vers desc req extras)
209 "Deploy the contents of DIR into the archive as a simple package.
210 Rename DIR/PKG.el to PKG-VERS.el, delete DIR, and return the descriptor."
211 ;; Write DIR/foo.el to foo-VERS.el and delete DIR
212 (rename-file (expand-file-name (concat pkg ".el") dir)
213 (concat pkg "-" vers ".el"))
214 ;; Add the content of the ChangeLog.
215 (let ((cl (expand-file-name "ChangeLog" dir)))
216 (with-current-buffer (find-file-noselect (concat pkg "-" vers ".el"))
217 (goto-char (point-max))
218 (re-search-backward "^;;;.*ends here")
219 (re-search-backward "^(provide")
220 (skip-chars-backward " \t\n")
221 (insert "\n\n;;;; ChangeLog:\n\n")
222 (let* ((start (point))
223 (end (copy-marker start t)))
225 (insert-file-contents cl)
226 (file-error (message "Can't find %S's ChangeLog file" pkg)))
228 (unless (bolp) (insert "\n"))
229 (while (progn (forward-line -1) (>= (point) start))
231 (set (make-local-variable 'backup-inhibited) t)
232 (basic-save-buffer) ;Less chatty than save-buffer.
234 (delete-directory dir t)
235 (cons (intern pkg) (vector (archive--version-to-list vers)
236 req desc 'single extras)))
238 (defun archive--make-changelog (dir srcdir)
239 "Export Git log info of DIR into a ChangeLog file."
240 (message "Refreshing ChangeLog in %S" dir)
241 (let ((default-directory (file-name-as-directory (expand-file-name dir))))
243 (set-buffer-multibyte nil)
244 (let ((coding-system-for-read 'binary)
245 (coding-system-for-write 'binary))
246 (if (file-readable-p "ChangeLog") (insert-file-contents "ChangeLog"))
247 (let ((old-md5 (md5 (current-buffer))))
249 (let ((default-directory
250 (file-name-as-directory (expand-file-name dir srcdir))))
251 (call-process "git" nil (current-buffer) nil
253 "--format=%cd %aN <%ae>%n%n%w(80,8,8)%B%n"
255 (tabify (point-min) (point-max))
256 (goto-char (point-min))
257 (while (re-search-forward "\n\n\n+" nil t)
258 (replace-match "\n\n"))
259 (if (equal old-md5 (md5 (current-buffer)))
260 (message "ChangeLog's md5 unchanged for %S" dir)
261 (write-region (point-min) (point-max) "ChangeLog" nil 'quiet)))))))
263 (defun archive--alist-to-plist-args (alist)
265 (if (and (not (consp x))
271 (mapcar (lambda (pair) (list (car pair) (cdr pair))) alist))))
273 (defun archive--plist-args-to-alist (plist)
276 (let ((value (cadr plist)))
278 (cl-assert (keywordp (car plist)))
279 (push (cons (car plist)
280 (if (eq 'quote (car-safe value)) (cadr value) value))
282 (setq plist (cddr plist)))
285 (defun archive--process-multi-file-package (dir pkg)
286 "Deploy the contents of DIR into the archive as a multi-file package.
287 Rename DIR/ to PKG-VERS/, and return the descriptor."
288 (let* ((exp (archive--multi-file-package-def dir pkg))
290 (req-exp (nth 4 exp))
291 (req (mapcar 'archive--convert-require
292 (if (eq 'quote (car-safe req-exp)) (nth 1 req-exp)
294 (error "REQ should be a quoted constant: %S"
296 (extras (archive--plist-args-to-alist (nthcdr 5 exp))))
297 (unless (equal (nth 1 exp) pkg)
298 (error (format "Package name %s doesn't match file name %s"
300 (rename-file dir (concat pkg "-" vers))
301 (cons (intern pkg) (vector (archive--version-to-list vers)
302 req (nth 3 exp) 'tar extras))))
304 (defun archive--multi-file-package-def (dir pkg)
305 "Return the `define-package' form in the file DIR/PKG-pkg.el."
306 (let ((pkg-file (expand-file-name (concat pkg "-pkg.el") dir)))
308 (unless (file-exists-p pkg-file)
309 (error "File not found: %s" pkg-file))
310 (insert-file-contents pkg-file)
311 (goto-char (point-min))
312 (read (current-buffer)))))
314 (defun archive--refresh-pkg-file ()
315 (let* ((dir (directory-file-name default-directory))
316 (pkg (file-name-nondirectory dir)))
317 (apply #'archive--write-pkg-file dir pkg
318 (cdr (archive--metadata dir pkg)))))
320 (defun archive--write-pkg-file (pkg-dir name version desc requires extras)
321 (let ((pkg-file (expand-file-name (concat name "-pkg.el") pkg-dir))
326 (concat (format ";; Generated package description from %s.el\n"
330 (list 'define-package
335 ;; Turn version lists into string form.
339 (package-version-join (cadr elt))))
341 (archive--alist-to-plist-args extras)))
346 ;;; Make the HTML pages for online browsing.
348 (defun archive--html-header (title)
349 (format "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">
353 <meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\">
356 <h1 align=\"center\">%s</h1>\n"
359 (defun archive--html-bytes-format (bytes) ;Aka memory-usage-format.
360 (setq bytes (/ bytes 1024.0))
361 (let ((units '(;; "B"
362 "kB" "MB" "GB" "TB")))
363 (while (>= bytes 1024)
364 (setq bytes (/ bytes 1024.0))
365 (setq units (cdr units)))
367 ;; ((integerp bytes) (format "%4d%s" bytes (car units)))
368 ((>= bytes 100) (format "%4.0f%s" bytes (car units)))
369 ((>= bytes 10) (format "%4.1f%s" bytes (car units)))
370 (t (format "%4.2f%s" bytes (car units))))))
372 (defun archive--get-prop (prop name srcdir mainsrcfile)
373 (let ((kprop (intern (format ":%s" (downcase prop)))))
375 (let ((pkgdescfile (expand-file-name (format "%s-pkg.el" name)
377 (when (file-readable-p pkgdescfile)
379 (insert-file-contents pkgdescfile)
380 (let ((desc (read (current-buffer))))
381 (plist-get (cdr desc) kprop)))))
382 (when (file-readable-p mainsrcfile)
384 (insert-file-contents mainsrcfile)
385 (lm-header prop))))))
387 (defun archive--get-section (hsection fsection srcdir mainsrcfile)
388 (when (consp fsection)
389 (while (cdr-safe fsection)
391 (if (file-readable-p (expand-file-name (car fsection) srcdir))
394 (when (consp fsection) (setq fsection (car fsection))))
396 ((file-readable-p (expand-file-name fsection srcdir))
398 (insert-file-contents (expand-file-name fsection srcdir))
400 ((file-readable-p mainsrcfile)
402 (insert-file-contents mainsrcfile)
403 (let ((start (lm-section-start hsection)))
407 (buffer-substring start (lm-section-end hsection))
410 (goto-char (point-min))
411 (delete-region (point) (line-beginning-position 2))
412 (uncomment-region (point-min) (point-max))
413 (when (looking-at "^\\([ \t]*\n\\)+")
415 (goto-char (point-max))
416 (skip-chars-backward " \t\n")
417 (delete-region (point) (point-max))
418 (buffer-string)))))))
420 (defun archive--quote (txt)
421 (replace-regexp-in-string "<" "<"
422 (replace-regexp-in-string "&" "&" txt)))
424 (defun archive--insert-repolinks (name srcdir mainsrcfile url)
426 (insert (format "<p>Origin: <a href=%S>%s</a></p>\n"
427 url (archive--quote url)))
430 (insert-file-contents
431 (expand-file-name "../../../elpa/externals-list" srcdir))
432 (read (current-buffer))))
433 (external (eq :external (nth 1 (assoc name externals))))
434 (git-sv "http://git.savannah.gnu.org/")
436 '("cgit/emacs/elpa.git/?h=externals/"
437 "gitweb/?p=emacs/elpa.git;a=shortlog;h=refs/heads/externals/")
438 '("cgit/emacs/elpa.git/tree/packages/"
439 "gitweb/?p=emacs/elpa.git;a=tree;f=packages/"))))
441 (concat "<p>Browse repository: <a href=%S>%s</a>"
442 " or <a href=%S>%s</a></p>\n")
443 (concat git-sv (nth 0 urls) name)
445 (concat git-sv (nth 1 urls) name)
448 (defun archive--html-make-pkg (pkg files)
449 (let* ((name (symbol-name (car pkg)))
450 (latest (package-version-join (aref (cdr pkg) 0)))
451 (srcdir (expand-file-name name "../../build/packages"))
452 (mainsrcfile (expand-file-name (format "%s.el" name) srcdir))
453 (desc (aref (cdr pkg) 2)))
455 (insert (archive--html-header (format "GNU ELPA - %s" name)))
456 (insert (format "<p>Description: %s</p>\n" (archive--quote desc)))
457 (let* ((file (cdr (assoc latest files)))
458 (attrs (file-attributes file)))
459 (insert (format "<p>Latest: <a href=%S>%s</a>, %s, %s</p>\n"
460 file (archive--quote file)
461 (format-time-string "%Y-%b-%d" (nth 5 attrs))
462 (archive--html-bytes-format (nth 7 attrs)))))
463 (let ((maint (archive--get-prop "Maintainer" name srcdir mainsrcfile)))
465 (insert (format "<p>Maintainer: %s</p>\n" (archive--quote maint)))))
466 (archive--insert-repolinks name srcdir mainsrcfile
467 (cdr (assoc :url (aref (cdr pkg) 4))))
468 (let ((rm (archive--get-section
469 "Commentary" '("README" "README.rst"
470 ;; Most README.md files seem to be currently
471 ;; worse than the Commentary: section :-(
474 srcdir mainsrcfile)))
476 (write-region rm nil (concat name "-readme.txt"))
477 (insert "<h2>Full description</h2><pre>\n" (archive--quote rm)
479 (unless (< (length files) 2)
480 (insert (format "<h2>Old versions</h2><table cellpadding=\"3\" border=\"1\">\n"))
482 (unless (equal (pop file) latest)
483 (let ((attrs (file-attributes file)))
484 (insert (format "<tr><td><a href=%S>%s</a></td><td>%s</td><td>%s</td>\n"
485 file (archive--quote file)
486 (format-time-string "%Y-%b-%d" (nth 5 attrs))
487 (archive--html-bytes-format (nth 7 attrs)))))))
488 (insert "</table>\n"))
489 (let ((news (archive--get-section
490 "News" '("NEWS" "NEWS.rst" "NEWS.md" "NEWS.org")
491 srcdir mainsrcfile)))
493 (insert "<h2>News</h2><pre>\n" (archive--quote news) "\n</pre>\n")))
495 (write-region (point-min) (point-max) (concat name ".html")))))
497 (defun archive--html-make-index (pkgs)
499 (insert (archive--html-header "GNU ELPA Packages"))
500 (insert "<table cellpadding=\"3\" border=\"1\">\n")
501 (insert "<tr><th>Package</th><th>Version</th><th>Description</th></tr>\n")
503 (insert (format "<tr><td><a href=\"%s.html\">%s</a></td><td>%s</td><td>%s</td></tr>\n"
505 (package-version-join (aref (cdr pkg) 0))
506 (aref (cdr pkg) 2))))
507 (insert "</table></body>\n")
508 (write-region (point-min) (point-max) "index.html")))
510 (defun batch-html-make-index ()
511 (let ((packages (make-hash-table :test #'equal))
514 (insert-file-contents "archive-contents")
515 (goto-char (point-min))
516 ;; Skip the first element which is a version number.
517 (cdr (read (current-buffer))))))
518 (dolist (file (directory-files default-directory nil))
520 ((member file '("." ".." "elpa.rss" "index.html" "archive-contents")))
521 ((string-match "\\.html\\'" file))
522 ((string-match "-readme\\.txt\\'" file)
523 (let ((name (substring file 0 (match-beginning 0))))
524 (puthash name (gethash name packages) packages)))
525 ((string-match "-\\([0-9][^-]*\\)\\.\\(tar\\|el\\)\\'" file)
526 (let ((name (substring file 0 (match-beginning 0)))
527 (version (match-string 1 file)))
528 (push (cons version file) (gethash name packages))))
529 (t (message "Unknown file %S" file))))
530 (dolist (pkg archive-contents)
531 (archive--html-make-pkg pkg (gethash (symbol-name (car pkg)) packages)))
532 ;; FIXME: Add (old?) packages that are in `packages' but not in
534 (archive--html-make-index archive-contents)))
536 ;;; Maintain external packages.
538 (defconst archive--elpa-git-url "git://git.sv.gnu.org/emacs/elpa")
540 (defun archive-add/remove/update-externals ()
541 (let ((exts (with-current-buffer (find-file-noselect "externals-list")
542 (goto-char (point-min))
543 (read (current-buffer)))))
544 (let ((default-directory (expand-file-name "packages/")))
545 ;; Remove "old/odd" externals.
546 (dolist (dir (directory-files "."))
548 ((member dir '("." "..")) nil)
549 ((assoc dir exts) nil)
550 ((file-directory-p (expand-file-name (format "%s/.git" dir)))
553 (let ((default-directory (file-name-as-directory
554 (expand-file-name dir))))
555 (call-process "git" nil t nil "status" "--porcelain")
557 (if (zerop (length status))
558 (progn (delete-directory dir 'recursive t)
559 (message "Deleted all of %s" dir))
560 (message "Keeping leftover unclean %s:\n%s" dir status))))))
561 (pcase-dolist (`(,dir ,kind ,_url) exts)
563 ((eq kind :subtree) nil) ;Nothing to do.
564 ((not (eq kind :external))
565 (message "Unknown external package kind `%S' for %s" kind dir))
566 ((not (file-exists-p dir))
567 (let* ((branch (concat "externals/" dir))
570 ;; FIXME: Use git-new-workdir!
571 (call-process "git" nil t nil "clone"
572 "--reference" ".." "--branch" branch
573 archive--elpa-git-url dir)
575 (message "Cloning branch %s:\n%s" dir output)))
576 ((not (file-directory-p (concat dir "/.git")))
577 (message "%s is in the way of an external, please remove!" dir))
579 (let ((default-directory (file-name-as-directory
580 (expand-file-name dir))))
582 (message "Running git pull in %S" default-directory)
583 (call-process "git" nil t nil "pull")
584 (message "Updated %s:%s" dir (buffer-string))))
587 (provide 'archive-contents)
588 ;;; archive-contents.el ends here