X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/11c2f112b0ef515a8e4e05cd07f4488470c4685c..fe623377defcfb3a80ce30b2b4c8f62d9999818f:/admin/archive-contents.el?ds=sidebyside diff --git a/admin/archive-contents.el b/admin/archive-contents.el index 21e5733d3..28a949d7a 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]+\\)*\\)") @@ -45,12 +47,16 @@ Otherwise return nil." str) (error nil)))) -(defun archive--delete-elc-files (dir) - "Recursively delete all .elc files in DIR." +(defun archive--delete-elc-files (dir &optional only-orphans) + "Recursively delete all .elc files in DIR. +Delete backup files also." (dolist (f (directory-files dir t archive-re-no-dot)) (cond ((file-directory-p f) (archive--delete-elc-files f)) - ((string-match "\\.elc\\'" f) + ((or (and (string-match "\\.elc\\'" f) + (not (and only-orphans + (file-readable-p (replace-match ".el" t t f))))) + (backup-file-name-p f)) (delete-file f))))) (defun batch-make-archive () @@ -59,7 +65,7 @@ Otherwise return nil." (dolist (dir (directory-files default-directory nil archive-re-no-dot)) (condition-case v (if (not (file-directory-p dir)) - (error "Skipping non-package file %s" dir) + (message "Skipping non-package file %s" dir) (let* ((pkg (file-name-nondirectory dir)) (autoloads-file (expand-file-name (concat pkg "-autoloads.el") dir)) simple-p) @@ -70,16 +76,50 @@ Otherwise return nil." ;; 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))) - ;; Error handler - (error (message "%s" (cadr v))))) + (error (error "Error in %s: %S" dir v)))) (with-temp-buffer (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) + (pushnew (match-string 1) pkgs :test #'equal)))) + (dolist (pkg pkgs) + (condition-case v + (if (file-directory-p pkg) + (archive--make-changelog pkg)) + (error (message "Error: %S" 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 @@ -89,27 +129,37 @@ requirements, and COMMENTARY is the package commentary. Otherwise, return nil." (let* ((pkg-file (expand-file-name (concat pkg "-pkg.el") dir)) (mainfile (expand-file-name (concat pkg ".el") dir)) + (files (directory-files dir nil archive-re-no-dot)) version description req commentary) - (when (and (or (not (file-exists-p pkg-file)) - (= (length (directory-files dir nil archive-re-no-dot)) 2)) - (file-exists-p mainfile)) + (dolist (file (prog1 files (setq files ()))) + (unless (string-match "\\.elc\\'" file) + (push file files))) + (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]*\\)?$") - (progn - (setq description (match-string 1)) - (setq version - (or (archive--strip-rcs-id (lm-header "package-version")) - (archive--strip-rcs-id (lm-header "version"))))) - (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. @@ -136,9 +186,44 @@ 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\n;;;; ChangeLog:\n\n") + (let* ((start (point)) + (end (copy-marker start t))) + (insert-file-contents cl) + (goto-char end) + (unless (bolp) (insert "\n")) + (while (progn (forward-line -1) (>= (point) start)) + (insert ";; "))) + (set (make-local-variable 'backup-inhibited) t) + (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)))) + (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. Rename DIR/ to PKG-VERS/, and write the package commentary to @@ -171,33 +256,43 @@ 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 - (if (not (file-directory-p dir)) - (error "Skipping non-package file %s" dir) - (let* ((pkg (file-name-nondirectory dir)) - (autoloads-file (expand-file-name (concat pkg "-autoloads.el") dir)) - simple-p version) - ;; Omit autoloads and .elc files from the package. - (if (file-exists-p autoloads-file) - (delete-file autoloads-file)) - (archive--delete-elc-files dir) - ;; Test whether this is a simple or multi-file package. - (setq simple-p (archive--simple-package-p dir pkg)) - (if simple-p - (progn - (apply 'archive--write-pkg-file dir pkg simple-p) - (setq version (car simple-p))) - (setq version - (nth 2 (archive--multi-file-package-def dir pkg)))) - (make-symbolic-link (expand-file-name dir package-dir) - (expand-file-name (concat pkg "-" version) - site-dir) - t) - (package-generate-autoloads pkg dir) - (let ((load-path (cons dir load-path))) - (byte-recompile-directory dir 0 t)))) - ;; Error handler - (error (message "%s" (cadr v)))))) + (if (not (file-directory-p dir)) + (message "Skipping non-package file %s" dir) + (let* ((pkg (file-name-nondirectory dir)) + (autoloads-file (expand-file-name + (concat pkg "-autoloads.el") dir)) + simple-p version) + ;; Omit autoloads and .elc files from the package. + (if (file-exists-p autoloads-file) + (delete-file autoloads-file)) + (archive--delete-elc-files dir 'only-orphans) + ;; Test whether this is a simple or multi-file package. + (setq simple-p (archive--simple-package-p dir pkg)) + (if simple-p + (progn + (apply 'archive--write-pkg-file dir pkg simple-p) + (setq version (car simple-p))) + (setq version + (nth 2 (archive--multi-file-package-def dir pkg)))) + (make-symbolic-link (expand-file-name dir package-dir) + (expand-file-name (concat pkg "-" version) + site-dir) + t) + (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 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)) @@ -222,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: