[nongnu] elpa-admin 55ff372 317/439: * admin/archive-contents.el: Improve package HTML headers

[Philip Kaludercic]

branch: elpa-admin
commit 55ff37224877085cf2a63f5b55dd907c61d9fab7
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    * admin/archive-contents.el: Improve package HTML headers
    
    Plus a few other tweaks.
    
    (archive-prepare-packages): Handle worktrees.
    (archive--metadata): Use package-buffer-info.
    (archive--refresh-pkg-file): Delete unused function.
    (archive--write-pkg-file): Mark the -pkg files are not to be compiled.
    (archive--html-header): Add optional `header` argument.
    (archive--html-make-pkg): Use it.
---
 admin/archive-contents.el | 92 +++++++++++++++++++++++++++--------------------
 1 file changed, 53 insertions(+), 39 deletions(-)

diff --git a/admin/archive-contents.el b/admin/archive-contents.el
index c4c2e5a..a252110 100644
--- a/admin/archive-contents.el
+++ b/admin/archive-contents.el
@@ -152,11 +152,29 @@ Currently only refreshes the ChangeLog files."
       (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)
+             (let* ((gitdir (expand-file-name
+                             (concat "packages/" dir "/.git")
+                             srcdir))
+                    (index (cond
+                            ((file-directory-p gitdir)
+                             (expand-file-name
+                              (concat "packages/" dir "/.git/index")
+                              srcdir))
+                            ((file-readable-p gitdir)
+                             (with-temp-buffer
+                               (insert-file-contents gitdir)
+                               (goto-char (point-min))
+                               (if (looking-at "gitdir:[ \t]*")
+                                   (progn
+                                     (delete-region (match-beginning 0)
+                                                    (match-end 0))
+                                     (expand-file-name "index" 
(buffer-string)))
+                                 (message "Can't find gitdir in %S" gitdir)
+                                 nil)))
+                            (t nil)))
+                    (cl (expand-file-name "ChangeLog" dir)))
+               (and index
+                    (file-exists-p index)
                     (or (not (file-exists-p cl))
                         (file-newer-than-file-p index cl))))
              (archive--make-changelog
@@ -184,30 +202,28 @@ PKG is the name of the package and DIR is the directory 
where it is."
       (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)
-          ;; Grab the other fields, which are not mandatory.
-          (let* ((description (match-string 1))
-                 (version
-                  (or (lm-header "package-version")
-                      (lm-header "version")
-                      (unless (equal pkg "org")
-                        (error "Missing `version' header"))))
-                 (_ (archive--version-to-list version)) ; Sanity check!
-                 (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
-                  (and 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)))))))
+        (let* ((pkg-desc (package-buffer-info))
+               (extras (package-desc-extras pkg-desc))
+               (version (package-desc-version pkg-desc))
+               (keywords (lm-keywords-list))
+               (_ (archive--version-to-list version)) ; Sanity check!
+               (pt (lm-header "package-type"))
+               (simple (if pt (equal pt "simple") (= (length files) 1)))
+               (found-url (plist-get extras :url))
+               (found-keywords (plist-get extras :keywords)))
+
+          (when (and keywords (not found-keywords))
+            ;; Using an old package-buffer-info which doesn't include
+            ;; keywords.  Fix it by hand.
+            (setq extras (plist-put extras :keywords keywords)))
+          (unless found-url
+            ;; Provide a good default URL.
+            (setq extras (plist-put extras :url
+                                    (format archive-default-url-format pkg))))
+
+          (list simple version (package-desc-summary pkg-desc)
+                (package-desc-reqs pkg-desc)
+                extras))))
      (t
       (error "Can't find main file %s file in %s" mainfile dir)))))
 
@@ -323,18 +339,14 @@ Rename DIR/ to PKG-VERS/, and return the descriptor."
       (error "File not found: %s" pkg-file))
     (archive--form-from-file-contents pkg-file)))
 
-(defun archive--refresh-pkg-file ()
-  (let* ((dir (directory-file-name default-directory))
-         (pkg (file-name-nondirectory dir)))
-    (archive--write-pkg-file dir pkg (archive--metadata dir pkg))))
-
 (defun archive--write-pkg-file (pkg-dir name metadata)
+  ;; FIXME: Use package-generate-description-file!
   (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"
+     (concat (format ";; Generated package description from %s.el  -*- 
no-byte-compile: t -*-\n"
                     name)
             (prin1-to-string
               (cl-destructuring-bind (version desc requires extras)
@@ -358,7 +370,7 @@ Rename DIR/ to PKG-VERS/, and return the descriptor."
 
 ;;; Make the HTML pages for online browsing.
 
-(defun archive--html-header (title)
+(defun archive--html-header (title &optional header)
   (format "<!DOCTYPE HTML PUBLIC>
 <html>
     <head>
@@ -383,7 +395,7 @@ Rename DIR/ to PKG-VERS/, and return the descriptor."
             </div>
 
             <div class=\"container\">\n"
-          title title title))
+          title (or header title)))
 
 (defun archive--html-bytes-format (bytes) ;Aka memory-usage-format.
   (setq bytes (/ bytes 1024.0))
@@ -495,7 +507,9 @@ Rename DIR/ to PKG-VERS/, and return the descriptor."
          (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)))
+      (insert (archive--html-header
+               (format "GNU ELPA - %s" name)
+               (format "<a href=\"index.html\">GNU ELPA</a> - %s" name)))
       (insert (format "<h2 class=\"package\">%s</h2>" name))
       (insert "<dl>")
       (insert (format "<dt>Description</dt><dd>%s</dd>\n" (archive--quote 
desc)))
@@ -675,7 +689,7 @@ Return non-nil if there's an \"emacs\" repository present."
     nil))
 
 (defun archive--cleanup-packages (externals-list with-core)
-  "Remove subdirectories of `packages/' that do not correspond to known 
packages.
+  "Remove unknown subdirectories of `packages/'.
 This is any subdirectory inside `packages/' that's not under
 version control nor listed in EXTERNALS-LIST.
 If WITH-CORE is non-nil, it means we manage :core packages as well."