branch: elpa-admin commit 5f38238e08c54ce854227d5cfa41099785e5f5be Author: Leo Liu <sdl....@gmail.com> Commit: Leo Liu <sdl....@gmail.com>
Merge branch 'master' of https://github.com/leoliu/easy-kill --- admin/archive-contents.el | 588 ---------------------------------------------- 1 file changed, 588 deletions(-) diff --git a/admin/archive-contents.el b/admin/archive-contents.el deleted file mode 100644 index 241f1ad..0000000 --- a/admin/archive-contents.el +++ /dev/null @@ -1,588 +0,0 @@ -;;; archive-contents.el --- Auto-generate an Emacs Lisp package archive. -*- lexical-binding:t -*- - -;; Copyright (C) 2011-2014 Free Software Foundation, Inc - -;; Author: Stefan Monnier <monn...@iro.umontreal.ca> - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;;; Code: - -(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-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) - (archive--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 (archive--version-to-list str) - str) - (error str)))) - -(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)) - ((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 () - "Process package content directories and generate the archive-contents file." - (let ((packages '(1))) ; format-version. - (dolist (dir (directory-files default-directory nil archive-re-no-dot)) - (condition-case 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))) - ;; Omit autoloads and .elc files from the package. - (if (file-exists-p autoloads-file) - (delete-file autoloads-file)) - (archive--delete-elc-files dir) - (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")))) - -(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." - (setq srcdir (file-name-as-directory (expand-file-name srcdir))) - (let* ((wit ".changelog-witness") - (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 - (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 '())) - (unless (equal prevno new-revno) - (with-temp-buffer - (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)) - (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))))) - )) - -(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)) - (cond - ((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) - ;; Grab the other fields, which are not mandatory. - (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 "http://elpa.gnu.org/packages/%s.html" 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 - (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))) - (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)) - (insert ";; "))) - (set (make-local-variable 'backup-inhibited) t) - (basic-save-buffer) ;Less chatty than save-buffer. - (kill-buffer))) - (delete-directory dir t) - (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." - (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) - (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))))))) - -(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-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 (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." - (let ((pkg-file (expand-file-name (concat pkg "-pkg.el") dir))) - (with-temp-buffer - (unless (file-exists-p pkg-file) - (error "File not found: %s" pkg-file)) - (insert-file-contents pkg-file) - (goto-char (point-min)) - (read (current-buffer))))) - -(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) - (print-quoted t) - (print-length nil)) - (write-region - (concat (format ";; Generated package description from %s.el\n" - name) - (prin1-to-string - (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))) - -;;; Make the HTML pages for online browsing. - -(defun archive--html-header (title) - (format "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\"> -<html> -<head> - <title>%s</title> - <meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\"> -</head> -<body> -<h1 align=\"center\">%s</h1>\n" - 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--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 "<" "<" - (replace-regexp-in-string "&" "&" txt))) - -(defun archive--insert-repolinks (name srcdir mainsrcfile url) - (if url - (insert (format "<p>Origin: <a href=%S>%s</a></p>\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 "<p>Browse repository: <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) - (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))) - (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" - 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 "<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) - (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" - file (archive--quote file) - (format-time-string "%Y-%b-%d" (nth 5 attrs)) - (archive--html-bytes-format (nth 7 attrs))))))) - (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) - (with-temp-buffer - (insert (archive--html-header "GNU ELPA Packages")) - (insert "<table cellpadding=\"3\" border=\"1\">\n") - (insert "<tr><th>Package</th><th>Version</th><th>Description</th></tr>\n") - (dolist (pkg pkgs) - (insert (format "<tr><td><a href=\"%s.html\">%s</a></td><td>%s</td><td>%s</td></tr>\n" - (car pkg) (car pkg) - (package-version-join (aref (cdr pkg) 0)) - (aref (cdr pkg) 2)))) - (insert "</table></body>\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))) - -;;; 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