* admin/archive-contents.el: Keep both home page a repository links.

[gnu-emacs-elpa] / admin / archive-contents.el

diff --git a/admin/archive-contents.el b/admin/archive-contents.el
index 152a56a44157dadb8fdfb652ecbc052d6298219a..96ecb76717fd26c2df75af8a91bd028bfea37d01 100644 (file)
--- a/admin/archive-contents.el
+++ b/admin/archive-contents.el
@@ -1,6 +1,6 @@
-;;; archive-contents.el --- Auto-generate an Emacs Lisp package archive.
+;;; archive-contents.el --- Auto-generate an Emacs Lisp package archive.  -*- lexical-binding:t -*-

 
 

-;; Copyright (C) 2011, 2012  Free Software Foundation, Inc
+;; Copyright (C) 2011-2014  Free Software Foundation, Inc

 
 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
 
 
 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
 


@@ -24,6 +24,7 @@
 (eval-when-compile (require 'cl))
 (require 'lisp-mnt)
 (require 'package)
 (eval-when-compile (require 'cl))
 (require 'lisp-mnt)
 (require 'package)

+(require 'pcase)

 
 (defconst archive-contents-subdirectory-regexp
   "\\([^.].*?\\)-\\([0-9]+\\(?:[.][0-9]+\\|\\(?:pre\\|beta\\|alpha\\)[0-9]+\\)*\\)")
 
 (defconst archive-contents-subdirectory-regexp
   "\\([^.].*?\\)-\\([0-9]+\\(?:[.][0-9]+\\|\\(?:pre\\|beta\\|alpha\\)[0-9]+\\)*\\)")


@@ -31,9 +32,17 @@
 (defconst archive-re-no-dot "\\`\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*"
   "Regular expression matching all files except \".\" and \"..\".")
 
 (defconst archive-re-no-dot "\\`\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*"
   "Regular expression matching all files except \".\" and \"..\".")
 

+(defun archive--version-to-list (vers)
+  (when vers
+    (let ((l (version-to-list vers)))
+      ;; Signal an error for things like "1.02" which is parsed as "1.2".
+      (assert (equal vers (package-version-join l)) nil
+              "Unsupported version syntax %S" vers)
+      l)))
+

 (defun archive--convert-require (elt)
   (list (car elt)
 (defun archive--convert-require (elt)
   (list (car elt)

-       (version-to-list (car (cdr elt)))))
+       (archive--version-to-list (car (cdr elt)))))

 
 (defun archive--strip-rcs-id (str)
   "Strip RCS version ID from the version string STR.
 
 (defun archive--strip-rcs-id (str)
   "Strip RCS version ID from the version string STR.


@@ -43,9 +52,9 @@ Otherwise return nil."
     (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str)
       (setq str (substring str (match-end 0))))
     (condition-case nil
     (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str)
       (setq str (substring str (match-end 0))))
     (condition-case nil

-       (if (version-to-list str)
-           str)
-      (error nil))))
+        (if (archive--version-to-list str)
+            str)
+      (error str))))

 
 (defun archive--delete-elc-files (dir &optional only-orphans)
   "Recursively delete all .elc files in DIR.
 
 (defun archive--delete-elc-files (dir &optional only-orphans)
   "Recursively delete all .elc files in DIR.


@@ -65,125 +74,143 @@ Delete backup files also."
     (dolist (dir (directory-files default-directory nil archive-re-no-dot))
       (condition-case v
          (if (not (file-directory-p dir))
     (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))
            (let* ((pkg (file-name-nondirectory dir))

-                  (autoloads-file (expand-file-name (concat pkg "-autoloads.el") dir))
-                  simple-p)
+                  (autoloads-file (expand-file-name (concat pkg "-autoloads.el") dir)))

              ;; Omit autoloads and .elc files from the package.
              (if (file-exists-p autoloads-file)
                  (delete-file autoloads-file))
              (archive--delete-elc-files dir)
              ;; 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))
-             (push (if simple-p
-                       (apply #'archive--process-simple-package
-                              dir pkg simple-p)
-                     (archive--process-multi-file-package dir pkg))
-                   packages)))
-       ;; Error handler
-       (error (message "%s" (cadr v)))))
+             (let ((metadata (archive--metadata dir pkg)))
+                ;; (nth 1 metadata) is nil for "org" which is the only package
+                ;; still using the "org-pkg.el file to specify the metadata.
+                (if (and (nth 1 metadata)
+                         (< (string-to-number (nth 1 metadata)) 0))
+                    (progn ;; Negative version: don't publish this package yet!
+                      (message "Package %s not released yet!" dir)
+                      (delete-directory dir 'recursive))
+                  (push (if (car metadata)
+                            (apply #'archive--process-simple-package
+                                   dir pkg (cdr metadata))
+                          (if (nth 1 metadata)
+                              (apply #'archive--write-pkg-file
+                                     dir pkg (cdr metadata)))
+                          (archive--process-multi-file-package dir pkg))
+                        packages)))))
+       ((debug error) (error "Error in %s: %S" dir v))))

     (with-temp-buffer
       (pp (nreverse packages) (current-buffer))
       (write-region nil nil "archive-contents"))))
 
     (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.
+(defconst archive--revno-re "[0-9a-f]+")
+
+(defun archive-prepare-packages (srcdir)
+  "Prepare the `packages' directory inside the Git 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."
 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."

+  (setq srcdir (file-name-as-directory (expand-file-name srcdir)))

   (let* ((wit ".changelog-witness")
   (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))
+         (prevno (with-temp-buffer
+                   (insert-file-contents wit)
+                   (if (looking-at (concat archive--revno-re "$"))
+                       (match-string 0)
+                     (error "Can't find previous revision name"))))

          (new-revno
           (or (with-temp-buffer
          (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")))
+                (let ((default-directory srcdir))
+                  (call-process "git" nil '(t) nil "rev-parse" "HEAD")
+                  (goto-char (point-min))
+                  (when (looking-at (concat archive--revno-re "$"))
+                    (match-string 0))))
+              (error "Couldn't find the current revision's name")))

          (pkgs '()))
          (pkgs '()))

-    (unless (= prevno new-revno)
+    (unless (equal prevno new-revno)

       (with-temp-buffer
       (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)))
+        (let ((default-directory srcdir))
+          (unless (zerop (call-process "git" nil '(t) nil "diff"
+                                       "--dirstat=cumulative,0"
+                                       prevno))
+            (error "Error signaled by git diff --dirstat %d" prevno)))

         (goto-char (point-min))
         (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
-VERSION is the version string of the simple package, DESCRIPTION
-is the brief description of the package, REQ is a list of
-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)
-    (dolist (file (prog1 files (setq files ())))
-      (unless (string-match "\\.elc\\'" file)
-        (push file files)))
+        (while (re-search-forward "^[ \t.0-9%]* packages/\\([-[:alnum:]]+\\)/$"
+                                  nil t)
+          (push (match-string 1) pkgs))))
+    (let ((default-directory (expand-file-name "packages/")))
+      (dolist (pkg pkgs)
+        (condition-case v
+            (if (file-directory-p pkg)
+                (archive--make-changelog pkg (expand-file-name "packages/"
+                                                               srcdir)))
+          (error (message "Error: %S" v)))))
+    (write-region new-revno nil wit nil 'quiet)
+    ;; Also update the ChangeLog of external packages.
+    (let ((default-directory (expand-file-name "packages/")))
+      (dolist (dir (directory-files "."))
+        (and (not (member dir '("." "..")))
+             (file-directory-p dir)
+             (let ((index (expand-file-name
+                           (concat "packages/" dir "/.git/index")
+                           srcdir))
+                   (cl (expand-file-name "ChangeLog" dir)))
+               (and (file-exists-p index)
+                    (or (not (file-exists-p cl))
+                        (file-newer-than-file-p index cl))))
+             (archive--make-changelog
+              dir (expand-file-name "packages/" srcdir)))))
+    ))
+
+(defconst archive-default-url-format "http://elpa.gnu.org/packages/%s.html")
+(defconst archive-default-url-re (format archive-default-url-format ".*"))
+
+(defun archive--metadata (dir pkg)
+  "Return a list (SIMPLE VERSION DESCRIPTION REQ EXTRAS),
+where SIMPLE is non-nil if the package is simple;
+VERSION is the version string of the simple package;
+DESCRIPTION is the brief description of the package;
+REQ is a list of requirements;
+EXTRAS is an alist with additional metadata.
+
+PKG is the name of the package and DIR is the directory where it is."
+  (let* ((mainfile (expand-file-name (concat pkg ".el") dir))
+         (files (directory-files dir nil "\\.el\\'")))

     (setq files (delete (concat pkg "-pkg.el") files))
     (setq files (delete (concat pkg "-autoloads.el") files))
     (setq files (delete (concat pkg "-pkg.el") files))
     (setq files (delete (concat pkg "-autoloads.el") files))

-    (setq files (delete "ChangeLog" files))

     (cond
     (cond

-     ((and (or (not (file-exists-p pkg-file))
-               (= (length files) 1))
-           (file-exists-p mainfile))
+     ((file-exists-p mainfile)

       (with-temp-buffer
        (insert-file-contents mainfile)
        (goto-char (point-min))
        (if (not (looking-at ";;;.*---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$"))
             (error "Can't parse first line of %s" mainfile)
       (with-temp-buffer
        (insert-file-contents mainfile)
        (goto-char (point-min))
        (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.
           ;; 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)
+          (let* ((description (match-string 1))
+                 (version
+                  (or (archive--strip-rcs-id (lm-header "package-version"))
+                      (archive--strip-rcs-id (lm-header "version"))
+                      (unless (equal pkg "org")
+                        (error "Missing `version' header"))))
+                 (requires-str (lm-header "package-requires"))
+                 (pt (lm-header "package-type"))
+                 (simple (if pt (equal pt "simple") (= (length files) 1)))
+                 (keywords (lm-keywords-list))
+                 (url (or (lm-header "url")
+                          (format archive-default-url-format pkg)))
+                 (req
+                  (if requires-str
+                      (mapcar 'archive--convert-require
+                              (car (read-from-string requires-str))))))
+            (list simple version description req
+                  ;; extra parameters
+                  (list (cons :url url)
+                        (cons :keywords keywords)))))))
+     (t
+      (error "Can find main file %s file in %s" mainfile dir)))))
+
+(defun archive--process-simple-package (dir pkg vers desc req extras)

   "Deploy the contents of DIR into the archive as a simple package.
   "Deploy the contents of DIR into the archive as a simple package.

-Rename DIR/PKG.el to PKG-VERS.el, delete DIR, and write the
-package commentary to PKG-readme.txt.  Return the descriptor."
-  ;; Write the readme file.
-  (with-temp-buffer
-    (erase-buffer)
-    (emacs-lisp-mode)
-    (insert (or commentary
-               (prog1 "No description"
-                 (message "Missing commentary in package %s" pkg))))
-    (goto-char (point-min))
-    (while (looking-at ";*[ \t]*\\(commentary[: \t]*\\)?\n")
-      (delete-region (match-beginning 0)
-                    (match-end 0)))
-    (uncomment-region (point-min) (point-max))
-    (goto-char (point-max))
-    (while (progn (forward-line -1)
-                 (looking-at "[ \t]*\n"))
-      (delete-region (match-beginning 0)
-                    (match-end 0)))
-    (write-region nil nil (concat pkg "-readme.txt")))
+Rename DIR/PKG.el to PKG-VERS.el, delete DIR, and 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"))
   ;; Write DIR/foo.el to foo-VERS.el and delete DIR
   (rename-file (expand-file-name (concat pkg ".el") dir)
               (concat pkg "-" vers ".el"))


@@ -194,18 +221,25 @@ package commentary to PKG-readme.txt.  Return the descriptor."
       (re-search-backward "^;;;.*ends here")
       (re-search-backward "^(provide")
       (skip-chars-backward " \t\n")
       (re-search-backward "^;;;.*ends here")
       (re-search-backward "^(provide")
       (skip-chars-backward " \t\n")

-      (insert "\n")
-      (let ((start (point)))
-        (insert-file-contents cl)
+      (insert "\n\n;;;; ChangeLog:\n\n")
+      (let* ((start (point))
+             (end (copy-marker start t)))
+        (condition-case nil
+            (insert-file-contents cl)
+          (file-error (message "Can't find %S's ChangeLog file" pkg)))
+        (goto-char end)

         (unless (bolp) (insert "\n"))
         (unless (bolp) (insert "\n"))

-        (comment-region start (point)))
-      (save-buffer)
+        (while (progn (forward-line -1) (>= (point) start))
+          (insert ";; ")))
+      (set (make-local-variable 'backup-inhibited) t)
+      (basic-save-buffer)               ;Less chatty than save-buffer.

       (kill-buffer)))
   (delete-directory dir t)
       (kill-buffer)))
   (delete-directory dir t)

-  (cons (intern pkg) (vector (version-to-list vers) req desc 'single)))
+  (cons (intern pkg) (vector (archive--version-to-list vers)
+                             req desc 'single extras)))

 
 

-(defun archive--make-changelog (dir)
-  "Export Bzr log info of DIR into a ChangeLog file."
+(defun archive--make-changelog (dir srcdir)
+  "Export Git 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
   (message "Refreshing ChangeLog in %S" dir)
   (let ((default-directory (file-name-as-directory (expand-file-name dir))))
     (with-temp-buffer


@@ -215,31 +249,63 @@ package commentary to PKG-readme.txt.  Return the descriptor."
         (if (file-readable-p "ChangeLog") (insert-file-contents "ChangeLog"))
         (let ((old-md5 (md5 (current-buffer))))
           (erase-buffer)
         (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" ".")
+          (let ((default-directory
+                  (file-name-as-directory (expand-file-name dir srcdir))))
+            (call-process "git" nil (current-buffer) nil
+                          "log" "--date=short"
+                          "--format=%cd  %aN  <%ae>%n%n%w(80,8,8)%B%n"
+                          "."))
+          (tabify (point-min) (point-max))
+          (goto-char (point-min))
+          (while (re-search-forward "\n\n\n+" nil t)
+            (replace-match "\n\n"))

           (if (equal old-md5 (md5 (current-buffer)))
               (message "ChangeLog's md5 unchanged for %S" dir)
             (write-region (point-min) (point-max) "ChangeLog" nil 'quiet)))))))
 
           (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--alist-to-plist-args (alist)
+  (mapcar (lambda (x)
+            (if (and (not (consp x))
+                     (or (keywordp x)
+                         (not (symbolp x))
+                         (memq x '(nil t))))
+                x `',x))
+          (apply #'nconc
+                 (mapcar (lambda (pair) (list (car pair) (cdr pair))) alist))))
+
+(defun archive--plist-args-to-alist (plist)
+  (let (alist)
+    (while plist
+      (let ((value (cadr plist)))
+        (when value
+          (cl-assert (keywordp (car plist)))
+          (push (cons (car plist)
+                      (if (eq 'quote (car-safe value)) (cadr value) value))
+                alist)))
+      (setq plist (cddr plist)))
+    alist))
+

 (defun archive--process-multi-file-package (dir pkg)
   "Deploy the contents of DIR into the archive as a multi-file package.
 (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
-PKG-readme.txt.  Return the descriptor."
+Rename DIR/ to PKG-VERS/, and return the descriptor."

   (let* ((exp (archive--multi-file-package-def dir pkg))
         (vers (nth 2 exp))
   (let* ((exp (archive--multi-file-package-def dir pkg))
         (vers (nth 2 exp))

-        (req (mapcar 'archive--convert-require (nth 4 exp)))
-        (readme (expand-file-name "README" dir)))
+         (req-exp (nth 4 exp))
+        (req (mapcar 'archive--convert-require
+                      (if (eq 'quote (car-safe req-exp)) (nth 1 req-exp)
+                        (when req-exp
+                          (error "REQ should be a quoted constant: %S"
+                                 req-exp)))))
+         (extras (archive--plist-args-to-alist (nthcdr 5 exp))))

     (unless (equal (nth 1 exp) pkg)
       (error (format "Package name %s doesn't match file name %s"
                     (nth 1 exp) pkg)))
     (unless (equal (nth 1 exp) pkg)
       (error (format "Package name %s doesn't match file name %s"
                     (nth 1 exp) pkg)))

-    ;; Write the readme file.
-    (when (file-exists-p readme)
-      (copy-file readme (concat pkg "-readme.txt") 'ok-if-already-exists))

     (rename-file dir (concat pkg "-" vers))
     (rename-file dir (concat pkg "-" vers))

-    (cons (intern pkg) (vector (version-to-list vers) req (nth 3 exp) 'tar))))
+    (cons (intern pkg) (vector (archive--version-to-list vers)
+                               req (nth 3 exp) 'tar extras))))

 
 (defun archive--multi-file-package-def (dir pkg)
 
 (defun archive--multi-file-package-def (dir pkg)

-  "Reurn the `define-package' form in the file DIR/PKG-pkg.el."
+  "Return the `define-package' form in the file DIR/PKG-pkg.el."

   (let ((pkg-file (expand-file-name (concat pkg "-pkg.el") dir)))
     (with-temp-buffer
       (unless (file-exists-p pkg-file)
   (let ((pkg-file (expand-file-name (concat pkg "-pkg.el") dir)))
     (with-temp-buffer
       (unless (file-exists-p pkg-file)


@@ -248,71 +314,34 @@ PKG-readme.txt.  Return the descriptor."
       (goto-char (point-min))
       (read (current-buffer)))))
 
       (goto-char (point-min))
       (read (current-buffer)))))
 

-(defun batch-make-site-dir (package-dir site-dir)
-  (require 'package)
-  (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 '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))))
-     ;; 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)
+(defun archive--refresh-pkg-file ()
+  (let* ((dir (directory-file-name default-directory))
+         (pkg (file-name-nondirectory dir)))
+    (apply #'archive--write-pkg-file dir pkg
+           (cdr (archive--metadata dir pkg)))))
+
+(defun archive--write-pkg-file (pkg-dir name version desc requires extras)

   (let ((pkg-file (expand-file-name (concat name "-pkg.el") pkg-dir))
        (print-level nil)
   (let ((pkg-file (expand-file-name (concat name "-pkg.el") pkg-dir))
        (print-level nil)

+        (print-quoted t)

        (print-length nil))
     (write-region
      (concat (format ";; Generated package description from %s.el\n"
                     name)
             (prin1-to-string
        (print-length nil))
     (write-region
      (concat (format ";; Generated package description from %s.el\n"
                     name)
             (prin1-to-string

-             (list 'define-package
-                   name
-                   version
-                   desc
-                   (list 'quote
-                         ;; Turn version lists into string form.
-                         (mapcar
-                          (lambda (elt)
-                            (list (car elt)
-                                  (package-version-join (cadr elt))))
-                          requires))))
+              (nconc
+               (list 'define-package
+                     name
+                     version
+                     desc
+                     (list 'quote
+                           ;; Turn version lists into string form.
+                           (mapcar
+                            (lambda (elt)
+                              (list (car elt)
+                                    (package-version-join (cadr elt))))
+                            requires)))
+               (archive--alist-to-plist-args extras)))

             "\n")
      nil
      pkg-file)))
             "\n")
      nil
      pkg-file)))


@@ -327,7 +356,7 @@ PKG-readme.txt.  Return the descriptor."
   <meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\">
 </head>
 <body>
   <meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\">
 </head>
 <body>

-<h1 align=\"center\">%s</h1>"
+<h1 align=\"center\">%s</h1>\n"

           title title))
 
 (defun archive--html-bytes-format (bytes) ;Aka memory-usage-format.
           title title))
 
 (defun archive--html-bytes-format (bytes) ;Aka memory-usage-format.


@@ -343,40 +372,131 @@ PKG-readme.txt.  Return the descriptor."
      ((>= bytes 10) (format "%4.1f%s" bytes (car units)))
      (t (format "%4.2f%s" bytes (car units))))))
 
      ((>= bytes 10) (format "%4.1f%s" bytes (car units)))
      (t (format "%4.2f%s" bytes (car units))))))
 

+(defun archive--get-prop (prop name srcdir mainsrcfile)
+  (let ((kprop (intern (format ":%s" (downcase prop)))))
+    (or
+     (let ((pkgdescfile (expand-file-name (format "%s-pkg.el" name)
+                                          srcdir)))
+       (when (file-readable-p pkgdescfile)
+         (with-temp-buffer
+           (insert-file-contents pkgdescfile)
+           (let ((desc (read (current-buffer))))
+             (plist-get (cdr desc) kprop)))))
+     (when (file-readable-p mainsrcfile)
+       (with-temp-buffer
+         (insert-file-contents mainsrcfile)
+         (lm-header prop))))))
+
+(defun archive--get-section (hsection fsection srcdir mainsrcfile)
+  (when (consp fsection)
+    (while (cdr-safe fsection)
+      (setq fsection
+            (if (file-readable-p (expand-file-name (car fsection) srcdir))
+                (car fsection)
+              (cdr fsection))))
+    (when (consp fsection) (setq fsection (car fsection))))
+  (cond
+   ((file-readable-p (expand-file-name fsection srcdir))
+    (with-temp-buffer
+      (insert-file-contents (expand-file-name fsection srcdir))
+      (buffer-string)))
+   ((file-readable-p mainsrcfile)
+    (with-temp-buffer
+      (insert-file-contents mainsrcfile)
+      (let ((start (lm-section-start hsection)))
+        (when start
+          (insert
+           (prog1
+               (buffer-substring start (lm-section-end hsection))
+             (erase-buffer)))
+          (emacs-lisp-mode)
+          (goto-char (point-min))
+          (delete-region (point) (line-beginning-position 2))
+          (uncomment-region (point-min) (point-max))
+          (when (looking-at "^\\([ \t]*\n\\)+")
+            (replace-match ""))
+          (goto-char (point-max))
+          (skip-chars-backward " \t\n")
+          (delete-region (point) (point-max))
+          (buffer-string)))))))
+
+(defun archive--quote (txt)
+  (replace-regexp-in-string "<" "&lt;"
+                            (replace-regexp-in-string "&" "&amp;" txt)))
+
+(defun archive--insert-repolinks (name srcdir mainsrcfile url)
+  (when url
+    (insert (format "<p>Home page: <a href=%S>%s</a></p>\n"
+                    url (archive--quote url)))
+    (when (string-match archive-default-url-re url)
+      (setq url nil)))
+  (let* ((externals
+          (with-temp-buffer
+            (insert-file-contents
+             (expand-file-name "../../../elpa/externals-list" srcdir))
+            (read (current-buffer))))
+         (external (eq :external (nth 1 (assoc name externals))))
+         (git-sv "http://git.savannah.gnu.org/")
+         (urls (if external
+                   '("cgit/emacs/elpa.git/?h=externals/"
+                     "gitweb/?p=emacs/elpa.git;a=shortlog;h=refs/heads/externals/")
+                 '("cgit/emacs/elpa.git/tree/packages/"
+                   "gitweb/?p=emacs/elpa.git;a=tree;f=packages/"))))
+    (insert (format
+             (concat (format "<p>Browse %srepository: " (if url "ELPA's " ""))
+                     "<a href=%S>%s</a> or <a href=%S>%s</a></p>\n")
+             (concat git-sv (nth 0 urls) name)
+             'CGit
+             (concat git-sv (nth 1 urls) name)
+             'Gitweb))))
+

 (defun archive--html-make-pkg (pkg files)
 (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.
+  (let* ((name (symbol-name (car pkg)))
+         (latest (package-version-join (aref (cdr pkg) 0)))
+         (srcdir (expand-file-name name "../../build/packages"))
+         (mainsrcfile (expand-file-name (format "%s.el" name) srcdir))
+         (desc (aref (cdr pkg) 2)))

     (with-temp-buffer
       (insert (archive--html-header (format "GNU ELPA - %s" name)))
     (with-temp-buffer
       (insert (archive--html-header (format "GNU ELPA - %s" name)))

-      (insert (format "<p>Description: %s</p>\n" desc))
+      (insert (format "<p>Description: %s</p>\n" (archive--quote desc)))

       (let* ((file (cdr (assoc latest files)))
              (attrs (file-attributes file)))
         (insert (format "<p>Latest: <a href=%S>%s</a>, %s, %s</p>\n"
       (let* ((file (cdr (assoc latest files)))
              (attrs (file-attributes file)))
         (insert (format "<p>Latest: <a href=%S>%s</a>, %s, %s</p>\n"

-                        file file
+                        file (archive--quote file)

                         (format-time-string "%Y-%b-%d" (nth 5 attrs))
                         (archive--html-bytes-format (nth 7 attrs)))))
                         (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 "<p>Repository: <a href=%S>%s</a></p>" repurl repurl)))
-      (let ((readme (concat name "-readme.txt"))
-            (end (copy-marker (point) t)))
-        (when (file-readable-p readme)
-          (insert "<p>Full description:<pre>\n")
-          (insert-file-contents readme)
-          (goto-char end)
-          (insert "\n</pre></p>")))
+      (let ((maint (archive--get-prop "Maintainer" name srcdir mainsrcfile)))
+        (when maint
+          (insert (format "<p>Maintainer: %s</p>\n" (archive--quote maint)))))
+      (archive--insert-repolinks name srcdir mainsrcfile
+                                 (cdr (assoc :url (aref (cdr pkg) 4))))
+      (let ((rm (archive--get-section
+                 "Commentary" '("README" "README.rst"
+                                ;; Most README.md files seem to be currently
+                                ;; worse than the Commentary: section :-(
+                                ;; "README.md"
+                                "README.org")
+                 srcdir mainsrcfile)))
+        (when rm
+          (write-region rm nil (concat name "-readme.txt"))
+          (insert "<h2>Full description</h2><pre>\n" (archive--quote rm)
+                  "\n</pre>\n")))

       (unless (< (length files) 2)
       (unless (< (length files) 2)

-        (insert (format "<p>Old versions:<table cellpadding=\"3\" border=\"1\">\n"))
+        (insert (format "<h2>Old versions</h2><table cellpadding=\"3\" border=\"1\">\n"))

         (dolist (file files)
           (unless (equal (pop file) latest)
             (let ((attrs (file-attributes file)))
               (insert (format "<tr><td><a href=%S>%s</a></td><td>%s</td><td>%s</td>\n"
         (dolist (file files)
           (unless (equal (pop file) latest)
             (let ((attrs (file-attributes file)))
               (insert (format "<tr><td><a href=%S>%s</a></td><td>%s</td><td>%s</td>\n"

-                              file file
+                              file (archive--quote file)

                               (format-time-string "%Y-%b-%d" (nth 5 attrs))
                               (archive--html-bytes-format (nth 7 attrs)))))))
                               (format-time-string "%Y-%b-%d" (nth 5 attrs))
                               (archive--html-bytes-format (nth 7 attrs)))))))

-        (insert "</table></body>\n"))
+        (insert "</table>\n"))
+      (let ((news (archive--get-section
+                   "News" '("NEWS" "NEWS.rst" "NEWS.md" "NEWS.org")
+                   srcdir mainsrcfile)))
+        (when news
+          (insert "<h2>News</h2><pre>\n" (archive--quote news) "\n</pre>\n")))
+      (insert "</body>\n")

       (write-region (point-min) (point-max) (concat name ".html")))))
 
 (defun archive--html-make-index (pkgs)
       (write-region (point-min) (point-max) (concat name ".html")))))
 
 (defun archive--html-make-index (pkgs)


@@ -417,11 +537,57 @@ PKG-readme.txt.  Return the descriptor."
     ;; FIXME: Add (old?) packages that are in `packages' but not in
     ;; archive-contents.
     (archive--html-make-index archive-contents)))
     ;; FIXME: Add (old?) packages that are in `packages' but not in
     ;; archive-contents.
     (archive--html-make-index archive-contents)))

-        

 
 

-;; Local Variables:
-;; lexical-binding: t
-;; End:
+;;; Maintain external packages.
+
+(defconst archive--elpa-git-url "git://git.sv.gnu.org/emacs/elpa")
+
+(defun archive-add/remove/update-externals ()
+  (let ((exts (with-current-buffer (find-file-noselect "externals-list")
+                (goto-char (point-min))
+                (read (current-buffer)))))
+    (let ((default-directory (expand-file-name "packages/")))
+      ;; Remove "old/odd" externals.
+      (dolist (dir (directory-files "."))
+        (cond
+         ((member dir '("." "..")) nil)
+         ((assoc dir exts) nil)
+         ((file-directory-p (expand-file-name (format "%s/.git" dir)))
+          (let ((status
+                 (with-temp-buffer
+                   (let ((default-directory (file-name-as-directory
+                                             (expand-file-name dir))))
+                     (call-process "git" nil t nil "status" "--porcelain")
+                     (buffer-string)))))
+            (if (zerop (length status))
+                (progn (delete-directory dir 'recursive t)
+                       (message "Deleted all of %s" dir))
+              (message "Keeping leftover unclean %s:\n%s" dir status))))))
+      (pcase-dolist (`(,dir ,kind ,_url) exts)
+        (cond
+         ((eq kind :subtree) nil)       ;Nothing to do.
+         ((not (eq kind :external))
+          (message "Unknown external package kind `%S' for %s" kind dir))
+         ((not (file-exists-p dir))
+          (let* ((branch (concat "externals/" dir))
+                 (output
+                  (with-temp-buffer
+                    ;; FIXME: Use git-new-workdir!
+                    (call-process "git" nil t nil "clone"
+                                  "--reference" ".." "--branch" branch
+                                  archive--elpa-git-url dir)
+                    (buffer-string))))
+            (message "Cloning branch %s:\n%s" dir output)))
+         ((not (file-directory-p (concat dir "/.git")))
+          (message "%s is in the way of an external, please remove!" dir))
+         (t
+          (let ((default-directory (file-name-as-directory
+                                    (expand-file-name dir))))
+            (with-temp-buffer
+              (message "Running git pull in %S" default-directory)
+              (call-process "git" nil t nil "pull")
+              (message "Updated %s:%s" dir (buffer-string))))
+          ))))))

 
 (provide 'archive-contents)
 ;;; archive-contents.el ends here
 
 (provide 'archive-contents)
 ;;; archive-contents.el ends here