X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/de7288845c1310f3e6f79b8e5cff7415a894c748..8f5704b427ea314e4b95a242a3b717d9976d48f9:/admin/archive-contents.el diff --git a/admin/archive-contents.el b/admin/archive-contents.el index 072d03f08..598364660 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. -*- lexical-binding:t -*- -;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc +;; Copyright (C) 2011-2014 Free Software Foundation, Inc ;; Author: Stefan Monnier @@ -32,21 +32,17 @@ (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) - (version-to-list (car (cdr elt))))) - -(defun archive--strip-rcs-id (str) - "Strip RCS version ID from the version string STR. -If the result looks like a dotted numeric version, return it. -Otherwise return nil." - (when str - (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)))) + (archive--version-to-list (car (cdr elt))))) (defun archive--delete-elc-files (dir &optional only-orphans) "Recursively delete all .elc files in DIR. @@ -68,21 +64,33 @@ Delete backup files also." (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) + (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) - ;; Test whether this is a simple or multi-file package. - (setq simple-p (archive--simple-package-p dir pkg)) - (push (if (car simple-p) - (apply #'archive--process-simple-package - dir pkg (cdr simple-p)) - (apply 'archive--write-pkg-file dir pkg (cdr simple-p)) - (archive--process-multi-file-package dir pkg)) - packages))) - (error (error "Error in %s: %S" dir v)))) + (let ((metadata (or (with-demoted-errors + ;;(format "batch-make-archive %s: %%s" dir) + (archive--metadata dir pkg)) + '(nil "0")))) + ;; (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) + (or (equal (nth 1 metadata) "0") + ;; Old deprecated convention. + (< (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")))) @@ -98,7 +106,7 @@ Currently only refreshes the ChangeLog files." (setq srcdir (file-name-as-directory (expand-file-name srcdir))) (let* ((wit ".changelog-witness") (prevno (with-temp-buffer - (ignore-errors (insert-file-contents wit)) + (insert-file-contents wit) (if (looking-at (concat archive--revno-re "$")) (match-string 0) (error "Can't find previous revision name")))) @@ -146,43 +154,56 @@ Currently only refreshes the ChangeLog files." dir (expand-file-name "packages/" srcdir))))) )) -(defun archive--simple-package-p (dir pkg) - "Test whether DIR contains a simple package named PKG. -Return a list (SIMPLE VERSION DESCRIPTION REQ), where -SIMPLE is non-nil if the package is indeed simple; +(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. -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 "\\.el\\'")) - version description req) +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)) (cond - ((and (not (file-exists-p pkg-file)) - (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) - (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)))))) - (list (= (length files) 1) version description req)))) - ((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) + (let* ((description (match-string 1)) + (pv ) + (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 + (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. 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 @@ -198,7 +219,9 @@ Rename DIR/PKG.el to PKG-VERS.el, delete DIR, and return the descriptor." (insert "\n\n;;;; ChangeLog:\n\n") (let* ((start (point)) (end (copy-marker start t))) - (insert-file-contents cl) + (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")) (while (progn (forward-line -1) (>= (point) start)) @@ -207,7 +230,8 @@ Rename DIR/PKG.el to PKG-VERS.el, delete DIR, and return the descriptor." (basic-save-buffer) ;Less chatty than save-buffer. (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 srcdir) "Export Git log info of DIR into a ChangeLog file." @@ -234,17 +258,46 @@ Rename DIR/PKG.el to PKG-VERS.el, delete DIR, and return the descriptor." (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. Rename DIR/ to PKG-VERS/, and return the descriptor." (let* ((exp (archive--multi-file-package-def dir pkg)) (vers (nth 2 exp)) - (req (mapcar 'archive--convert-require (nth 4 exp)))) + (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))) (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) "Return the `define-package' form in the file DIR/PKG-pkg.el." @@ -258,16 +311,11 @@ Rename DIR/ to PKG-VERS/, and return the descriptor." (defun archive--refresh-pkg-file () (let* ((dir (directory-file-name default-directory)) - (pkg (file-name-nondirectory dir)) - (simple-p (archive--simple-package-p dir pkg))) - (if simple-p - (progn - ;; (message "Refreshing pkg description of %s" pkg) - (apply 'archive--write-pkg-file dir pkg (cdr simple-p))) - ;; (message "Not refreshing pkg description of %s" pkg) - ))) - -(defun archive--write-pkg-file (pkg-dir name version desc requires &rest ignored) + (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) (print-quoted t) @@ -276,17 +324,19 @@ Rename DIR/ to PKG-VERS/, and return the descriptor." (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))) @@ -348,6 +398,7 @@ Rename DIR/ to PKG-VERS/, and return the descriptor." ((file-readable-p mainsrcfile) (with-temp-buffer (insert-file-contents mainsrcfile) + (emacs-lisp-mode) ;lm-section-start needs the outline-mode setting. (let ((start (lm-section-start hsection))) (when start (insert @@ -369,30 +420,31 @@ Rename DIR/ to PKG-VERS/, and return the descriptor." (replace-regexp-in-string "<" "<" (replace-regexp-in-string "&" "&" txt))) -(defun archive--insert-repolinks (name srcdir mainsrcfile) - (let ((url (archive--get-prop "URL" name srcdir mainsrcfile))) - (if url - (insert (format "

Origin: %s

\n" - url (archive--quote url))) - (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 "

Browse repository: %s" - " or %s

\n") - (concat git-sv (nth 0 urls) name) - 'CGit - (concat git-sv (nth 1 urls) name) - 'Gitweb)))))) +(defun archive--insert-repolinks (name srcdir mainsrcfile url) + (when url + (insert (format "

Home page: %s

\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 "

Browse %srepository: " (if url "ELPA's " "")) + "%s or %s

\n") + (concat git-sv (nth 0 urls) name) + 'CGit + (concat git-sv (nth 1 urls) name) + 'Gitweb)))) (defun archive--html-make-pkg (pkg files) (let* ((name (symbol-name (car pkg))) @@ -403,25 +455,36 @@ Rename DIR/ to PKG-VERS/, and return the descriptor." (with-temp-buffer (insert (archive--html-header (format "GNU ELPA - %s" name))) (insert (format "

Description: %s

\n" (archive--quote desc))) - (let* ((file (cdr (assoc latest files))) - (attrs (file-attributes file))) - (insert (format "

Latest: %s, %s, %s

\n" - file (archive--quote file) - (format-time-string "%Y-%b-%d" (nth 5 attrs)) - (archive--html-bytes-format (nth 7 attrs))))) + (if (zerop (length latest)) + (insert "

This package " + (if files "is not in GNU ELPA any more" + "has not been released yet") + ".

\n") + (let* ((file (cdr (assoc latest files))) + (attrs (file-attributes file))) + (insert (format "

Latest: %s, %s, %s

\n" + file (archive--quote file) + (format-time-string "%Y-%b-%d" (nth 5 attrs)) + (archive--html-bytes-format (nth 7 attrs)))))) (let ((maint (archive--get-prop "Maintainer" name srcdir mainsrcfile))) (when maint (insert (format "

Maintainer: %s

\n" (archive--quote maint))))) - (archive--insert-repolinks name srcdir mainsrcfile) - (let ((readme (archive--get-section "Commentary" - '("README" "README.rst" "README.md" - "README.org") - srcdir mainsrcfile))) - (when readme - (write-region readme nil (concat name "-readme.txt")) - (insert "

Full description

\n" (archive--quote readme)
+      (archive--insert-repolinks
+       name srcdir mainsrcfile
+       (or (cdr (assoc :url (aref (cdr pkg) 4)))
+           (archive--get-prop "URL" name srcdir mainsrcfile)))
+      (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 "
Full description
\n" (archive--quote rm)
                   "\n
\n")))
-      (unless (< (length files) 2)
+      (unless (< (length files) (if (zerop (length latest)) 1 2))
         (insert (format "
Old versions
\n"))
         (dolist (file files)
           (unless (equal (pop file) latest)
@@ -431,7 +494,9 @@ Rename DIR/ to PKG-VERS/, and return the descriptor."
                               (format-time-string "%Y-%b-%d" (nth 5 attrs))
                               (archive--html-bytes-format (nth 7 attrs)))))))
         (insert "
\n"))
-      (let ((news (archive--get-section "News" "NEWS" srcdir mainsrcfile)))
+      (let ((news (archive--get-section
+                   "News" '("NEWS" "NEWS.rst" "NEWS.md" "NEWS.org")
+                   srcdir mainsrcfile)))
         (when news
           (insert "
News
\n" (archive--quote news) "\n
\n")))
       (insert "\n")
@@ -458,6 +523,10 @@ Rename DIR/ to PKG-VERS/, and return the descriptor."
            (goto-char (point-min))
            ;; Skip the first element which is a version number.
            (cdr (read (current-buffer))))))
+    (dolist (subdir (directory-files "../../build/packages" nil))
+      (cond
+       ((member subdir '("." ".." "elpa.rss" "index.html" "archive-contents")))
+       (t (puthash subdir nil packages))))
     (dolist (file (directory-files default-directory nil))
       (cond
        ((member file '("." ".." "elpa.rss" "index.html" "archive-contents")))
@@ -470,10 +539,20 @@ Rename DIR/ to PKG-VERS/, and return the descriptor."
               (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.
+    (maphash (lambda (pkg-name files)
+               (archive--html-make-pkg
+                (let ((pkg (intern pkg-name)))
+                  (or (assq pkg archive-contents)
+                      ;; Add entries for packages that are either not yet
+                      ;; released or not released any more.
+                      ;; FIXME: Get actual description!
+                      (let ((entry (cons pkg (vector nil nil "" nil nil))))
+                        (setq archive-contents
+                              ;; Add entry at the end.
+                              (nconc archive-contents (list entry)))
+                        entry)))
+                files))
+             packages)
     (archive--html-make-index archive-contents)))
 
 ;;; Maintain external packages.
@@ -512,7 +591,8 @@ Rename DIR/ to PKG-VERS/, and return the descriptor."
                   (with-temp-buffer
                     ;; FIXME: Use git-new-workdir!
                     (call-process "git" nil t nil "clone"
-                                  "--reference" ".." "--branch" branch
+                                  "--reference" ".." "--single-branch"
+                                  "--branch" branch
                                   archive--elpa-git-url dir)
                     (buffer-string))))
             (message "Cloning branch %s:\n%s" dir output)))