X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/ac23db25d69fdf9c6e432638354454bf17c94a2f..52f40a8375337c9122317190a2ef6bf8ba535487:/admin/archive-contents.el
diff --git a/admin/archive-contents.el b/admin/archive-contents.el
index 92c592ea8..152a56a44 100644
--- a/admin/archive-contents.el
+++ b/admin/archive-contents.el
@@ -1,6 +1,6 @@
;;; archive-contents.el --- Auto-generate an Emacs Lisp package archive.
-;; Copyright (C) 2011 Free Software Foundation, Inc
+;; Copyright (C) 2011, 2012 Free Software Foundation, Inc
;; Author: Stefan Monnier
@@ -21,7 +21,9 @@
;;; Code:
+(eval-when-compile (require 'cl))
(require 'lisp-mnt)
+(require 'package)
(defconst archive-contents-subdirectory-regexp
"\\([^.].*?\\)-\\([0-9]+\\(?:[.][0-9]+\\|\\(?:pre\\|beta\\|alpha\\)[0-9]+\\)*\\)")
@@ -74,7 +76,7 @@ Delete backup files also."
;; Test whether this is a simple or multi-file package.
(setq simple-p (archive--simple-package-p dir pkg))
(push (if simple-p
- (apply 'archive--process-simple-package
+ (apply #'archive--process-simple-package
dir pkg simple-p)
(archive--process-multi-file-package dir pkg))
packages)))
@@ -84,6 +86,41 @@ Delete backup files also."
(pp (nreverse packages) (current-buffer))
(write-region nil nil "archive-contents"))))
+(defun batch-prepare-packages ()
+ "Prepare the `packages' directory inside the Bzr checkout.
+Expects to be called from within the `packages' directory.
+\"Prepare\" here is for subsequent construction of the packages and archive,
+so it is meant to refresh any generated files we may need.
+Currently only refreshes the ChangeLog files."
+ (let* ((wit ".changelog-witness")
+ (prevno (or (with-temp-buffer
+ (ignore-errors (insert-file-contents wit))
+ (when (looking-at "[1-9][0-9]*\\'")
+ (string-to-number (match-string 0))))
+ 1))
+ (new-revno
+ (or (with-temp-buffer
+ (call-process "bzr" nil '(t) nil "revno")
+ (goto-char (point-min))
+ (when (looking-at "[1-9][0-9]*$")
+ (string-to-number (match-string 0))))
+ (error "bzr revno did not return a number as expected")))
+ (pkgs '()))
+ (unless (= prevno new-revno)
+ (with-temp-buffer
+ (unless (zerop (call-process "bzr" nil '(t) nil "log" "-v"
+ (format "-r%d.." (1+ prevno))))
+ (error "Error signaled by bzr log -v -r%d.." (1+ prevno)))
+ (goto-char (point-min))
+ (while (re-search-forward "^ packages/\\([-[:alnum:]]+\\)/" nil t)
+ (cl-pushnew (match-string 1) pkgs :test #'equal))))
+ (dolist (pkg pkgs)
+ (condition-case v
+ (if (file-directory-p pkg)
+ (archive--make-changelog pkg))
+ (error (message "%s" (cadr v)))))
+ (write-region (number-to-string new-revno) nil wit nil 'quiet)))
+
(defun archive--simple-package-p (dir pkg)
"Test whether DIR contains a simple package named PKG.
If so, return a list (VERSION DESCRIPTION REQ COMMENTARY), where
@@ -98,27 +135,32 @@ Otherwise, return nil."
(dolist (file (prog1 files (setq files ())))
(unless (string-match "\\.elc\\'" file)
(push file files)))
- (when (and (or (not (file-exists-p pkg-file))
- (= (length files) 2))
- (file-exists-p mainfile))
+ (setq files (delete (concat pkg "-pkg.el") files))
+ (setq files (delete (concat pkg "-autoloads.el") files))
+ (setq files (delete "ChangeLog" files))
+ (cond
+ ((and (or (not (file-exists-p pkg-file))
+ (= (length files) 1))
+ (file-exists-p mainfile))
(with-temp-buffer
(insert-file-contents mainfile)
(goto-char (point-min))
- (and (looking-at ";;;.*---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$")
- (progn
- (setq description (match-string 1))
- (setq version
- (or (archive--strip-rcs-id (lm-header "package-version"))
- (archive--strip-rcs-id (lm-header "version"))
- "0.0")))
- (progn
- ;; Grab the other fields, which are not mandatory.
- (let ((requires-str (lm-header "package-requires")))
- (if requires-str
- (setq req (mapcar 'archive--convert-require
- (car (read-from-string requires-str))))))
- (setq commentary (lm-commentary))
- (list version description req commentary)))))))
+ (if (not (looking-at ";;;.*---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$"))
+ (error "Can't parse first line of %s" mainfile)
+ (setq description (match-string 1))
+ (setq version
+ (or (archive--strip-rcs-id (lm-header "package-version"))
+ (archive--strip-rcs-id (lm-header "version"))
+ (error "Missing `version' header")))
+ ;; Grab the other fields, which are not mandatory.
+ (let ((requires-str (lm-header "package-requires")))
+ (if requires-str
+ (setq req (mapcar 'archive--convert-require
+ (car (read-from-string requires-str))))))
+ (setq commentary (lm-commentary))
+ (list version description req commentary))))
+ ((not (file-exists-p pkg-file))
+ (error "Can find single file nor package desc file in %s" dir)))))
(defun archive--process-simple-package (dir pkg vers desc req commentary)
"Deploy the contents of DIR into the archive as a simple package.
@@ -145,14 +187,39 @@ package commentary to PKG-readme.txt. Return the descriptor."
;; Write DIR/foo.el to foo-VERS.el and delete DIR
(rename-file (expand-file-name (concat pkg ".el") dir)
(concat pkg "-" vers ".el"))
+ ;; Add the content of the ChangeLog.
+ (let ((cl (expand-file-name "ChangeLog" dir)))
+ (with-current-buffer (find-file-noselect (concat pkg "-" vers ".el"))
+ (goto-char (point-max))
+ (re-search-backward "^;;;.*ends here")
+ (re-search-backward "^(provide")
+ (skip-chars-backward " \t\n")
+ (insert "\n")
+ (let ((start (point)))
+ (insert-file-contents cl)
+ (unless (bolp) (insert "\n"))
+ (comment-region start (point)))
+ (save-buffer)
+ (kill-buffer)))
(delete-directory dir t)
(cons (intern pkg) (vector (version-to-list vers) req desc 'single)))
(defun archive--make-changelog (dir)
"Export Bzr log info of DIR into a ChangeLog file."
+ (message "Refreshing ChangeLog in %S" dir)
(let ((default-directory (file-name-as-directory (expand-file-name dir))))
- (call-process "bzr" nil '(:file "ChangeLog") nil
- "log" "--gnu-changelog" ".")))
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (let ((coding-system-for-read 'binary)
+ (coding-system-for-write 'binary))
+ (if (file-readable-p "ChangeLog") (insert-file-contents "ChangeLog"))
+ (let ((old-md5 (md5 (current-buffer))))
+ (erase-buffer)
+ (call-process "bzr" nil (current-buffer) nil
+ "log" "--gnu-changelog" ".")
+ (if (equal old-md5 (md5 (current-buffer)))
+ (message "ChangeLog's md5 unchanged for %S" dir)
+ (write-region (point-min) (point-max) "ChangeLog" nil 'quiet)))))))
(defun archive--process-multi-file-package (dir pkg)
"Deploy the contents of DIR into the archive as a multi-file package.
@@ -162,7 +229,6 @@ PKG-readme.txt. Return the descriptor."
(vers (nth 2 exp))
(req (mapcar 'archive--convert-require (nth 4 exp)))
(readme (expand-file-name "README" dir)))
- (archive--make-changelog dir)
(unless (equal (nth 1 exp) pkg)
(error (format "Package name %s doesn't match file name %s"
(nth 1 exp) pkg)))
@@ -187,7 +253,7 @@ PKG-readme.txt. Return the descriptor."
(setq package-dir (expand-file-name package-dir default-directory))
(setq site-dir (expand-file-name site-dir default-directory))
(dolist (dir (directory-files package-dir t archive-re-no-dot))
- (condition-case v
+ (condition-case v
(if (not (file-directory-p dir))
(error "Skipping non-package file %s" dir)
(let* ((pkg (file-name-nondirectory dir))
@@ -218,6 +284,16 @@ PKG-readme.txt. Return the descriptor."
;; Error handler
(error (message "%s" (cadr v))))))
+(defun batch-make-site-package (sdir)
+ (let* ((dest (car (file-attributes sdir)))
+ (pkg (file-name-nondirectory (directory-file-name (or dest sdir))))
+ (dir (or dest sdir)))
+ (let ((make-backup-files nil))
+ (package-generate-autoloads pkg dir))
+ (let ((load-path (cons dir load-path)))
+ ;; FIXME: Don't compile the -pkg.el files!
+ (byte-recompile-directory dir 0))))
+
(defun archive--write-pkg-file (pkg-dir name version desc requires &rest ignored)
(let ((pkg-file (expand-file-name (concat name "-pkg.el") pkg-dir))
(print-level nil)
@@ -241,9 +317,109 @@ PKG-readme.txt. Return the descriptor."
nil
pkg-file)))
+;;; Make the HTML pages for online browsing.
+
+(defun archive--html-header (title)
+ (format "
+
+
+ %s
+
+
+
+%s
"
+ title title))
+
+(defun archive--html-bytes-format (bytes) ;Aka memory-usage-format.
+ (setq bytes (/ bytes 1024.0))
+ (let ((units '(;; "B"
+ "kB" "MB" "GB" "TB")))
+ (while (>= bytes 1024)
+ (setq bytes (/ bytes 1024.0))
+ (setq units (cdr units)))
+ (cond
+ ;; ((integerp bytes) (format "%4d%s" bytes (car units)))
+ ((>= bytes 100) (format "%4.0f%s" bytes (car units)))
+ ((>= bytes 10) (format "%4.1f%s" bytes (car units)))
+ (t (format "%4.2f%s" bytes (car units))))))
+
+(defun archive--html-make-pkg (pkg files)
+ (let ((name (symbol-name (car pkg)))
+ (latest (package-version-join (aref (cdr pkg) 0)))
+ (desc (aref (cdr pkg) 2)))
+ ;; FIXME: Add maintainer info.
+ (with-temp-buffer
+ (insert (archive--html-header (format "GNU ELPA - %s" name)))
+ (insert (format "Description: %s
\n" desc))
+ (let* ((file (cdr (assoc latest files)))
+ (attrs (file-attributes file)))
+ (insert (format "Latest: %s, %s, %s
\n"
+ file file
+ (format-time-string "%Y-%b-%d" (nth 5 attrs))
+ (archive--html-bytes-format (nth 7 attrs)))))
+ ;; FIXME: This URL is wrong for Org.
+ (let ((repurl (concat "http://bzr.sv.gnu.org/lh/emacs/elpa/files/head:/packages/" name)))
+ (insert (format "Repository: %s
" repurl repurl)))
+ (let ((readme (concat name "-readme.txt"))
+ (end (copy-marker (point) t)))
+ (when (file-readable-p readme)
+ (insert "Full description:
\n")
+ (insert-file-contents readme)
+ (goto-char end)
+ (insert "\n
")))
+ (unless (< (length files) 2)
+ (insert (format "Old versions:
\n"))
+ (dolist (file files)
+ (unless (equal (pop file) latest)
+ (let ((attrs (file-attributes file)))
+ (insert (format "%s | %s | %s | \n"
+ file file
+ (format-time-string "%Y-%b-%d" (nth 5 attrs))
+ (archive--html-bytes-format (nth 7 attrs)))))))
+ (insert "
\n"))
+ (write-region (point-min) (point-max) (concat name ".html")))))
+
+(defun archive--html-make-index (pkgs)
+ (with-temp-buffer
+ (insert (archive--html-header "GNU ELPA Packages"))
+ (insert "\n")
+ (insert "Package | Version | Description |
\n")
+ (dolist (pkg pkgs)
+ (insert (format "%s | %s | %s |
\n"
+ (car pkg) (car pkg)
+ (package-version-join (aref (cdr pkg) 0))
+ (aref (cdr pkg) 2))))
+ (insert "
\n")
+ (write-region (point-min) (point-max) "index.html")))
+
+(defun batch-html-make-index ()
+ (let ((packages (make-hash-table :test #'equal))
+ (archive-contents
+ (with-temp-buffer
+ (insert-file-contents "archive-contents")
+ (goto-char (point-min))
+ ;; Skip the first element which is a version number.
+ (cdr (read (current-buffer))))))
+ (dolist (file (directory-files default-directory nil))
+ (cond
+ ((member file '("." ".." "elpa.rss" "index.html" "archive-contents")))
+ ((string-match "\\.html\\'" file))
+ ((string-match "-readme\\.txt\\'" file)
+ (let ((name (substring file 0 (match-beginning 0))))
+ (puthash name (gethash name packages) packages)))
+ ((string-match "-\\([0-9][^-]*\\)\\.\\(tar\\|el\\)\\'" file)
+ (let ((name (substring file 0 (match-beginning 0)))
+ (version (match-string 1 file)))
+ (push (cons version file) (gethash name packages))))
+ (t (message "Unknown file %S" file))))
+ (dolist (pkg archive-contents)
+ (archive--html-make-pkg pkg (gethash (symbol-name (car pkg)) packages)))
+ ;; FIXME: Add (old?) packages that are in `packages' but not in
+ ;; archive-contents.
+ (archive--html-make-index archive-contents)))
+
;; Local Variables:
-;; no-byte-compile: t
;; lexical-binding: t
;; End: