;;; 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 <monnier@iro.umontreal.ca>
(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."
(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))
- (if simple-p
- (apply #'archive--write-pkg-file
- dir pkg (cdr simple-p)))
- (archive--process-multi-file-package dir pkg))
- packages)))
+ (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))
(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"))))
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 EXTRAS), 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;
EXTRAS is an alist with additional metadata.
-Otherwise, return nil."
- (let* ((pkg-file (expand-file-name (concat pkg "-pkg.el") dir))
- (mainfile (expand-file-name (concat pkg ".el") dir))
+
+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))
(error "Can't parse first line of %s" mainfile)
;; Grab the other fields, which are not mandatory.
(let* ((description (match-string 1))
+ (pv )
(version
- (or (archive--strip-rcs-id (lm-header "package-version"))
- (archive--strip-rcs-id (lm-header "version"))
- (error "Missing `version' header")))
+ (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 "http://elpa.gnu.org/packages/%s.html" pkg)))
+ (format archive-default-url-format pkg)))
(req
(if requires-str
(mapcar 'archive--convert-require
(list simple version description req
;; extra parameters
(list (cons :url url)
- (cons :keywords (list 'quote keywords))))))))
- ((not (file-exists-p pkg-file))
- (error "Can find single file nor package desc file in %s" dir)))))
+ (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.
(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))
(message "ChangeLog's md5 unchanged for %S" dir)
(write-region (point-min) (point-max) "ChangeLog" nil 'quiet)))))))
-(defun archive--alist-to-plist (alist)
- (apply #'nconc (mapcar (lambda (pair) (list (car pair) (cdr pair))) alist)))
-
-(defun archive--plist-to-alist (plist)
+(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
- (push (cons (car plist) 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))
(when req-exp
(error "REQ should be a quoted constant: %S"
req-exp)))))
- (extras (archive--plist-to-alist (nthcdr 5 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)))
(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)
- )))
+ (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))
(list (car elt)
(package-version-join (cadr elt))))
requires)))
- (archive--alist-to-plist extras)))
+ (archive--alist-to-plist-args extras)))
"\n")
nil
pkg-file)))
((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
(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)))))
+ (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)
(let* ((name (symbol-name (car pkg)))
(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)))))
+ (if (zerop (length latest))
+ (insert "<p>This package "
+ (if files "is not in GNU ELPA any more"
+ "has not been released yet")
+ ".</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 (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))))
+ (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
(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) (if (zerop (length latest)) 1 2))
(insert (format "<h2>Old versions</h2><table cellpadding=\"3\" border=\"1\">\n"))
(dolist (file files)
(unless (equal (pop file) latest)
(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")))
(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.
(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)))