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 "\n" + file file + (format-time-string "%Y-%b-%d" (nth 5 attrs)) + (archive--html-bytes-format (nth 7 attrs))))))) + (insert "
%s%s%s
\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 "\n") + (dolist (pkg pkgs) + (insert (format "\n" + (car pkg) (car pkg) + (package-version-join (aref (cdr pkg) 0)) + (aref (cdr pkg) 2)))) + (insert "
PackageVersionDescription
%s%s%s
\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: