X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/266a86bd7fedf743225c2497956b73ecb2245196..91af3942e9ab5540b3ab4dde6733bc883dc2abdd:/lisp/emacs-lisp/package-x.el diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el index 38c4d5bbe3..cd4b5ee231 100644 --- a/lisp/emacs-lisp/package-x.el +++ b/lisp/emacs-lisp/package-x.el @@ -1,6 +1,6 @@ ;;; package-x.el --- Package extras -;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 2007-2011 Free Software Foundation, Inc. ;; Author: Tom Tromey ;; Created: 10 Mar 2007 @@ -27,18 +27,41 @@ ;;; Commentary: -;; This file currently contains parts of the package system most -;; people won't need, such as package uploading. +;; This file currently contains parts of the package system that many +;; won't need, such as package uploading. + +;; To upload to an archive, first set `package-archive-upload-base' to +;; some desired directory. For testing purposes, you can specify any +;; directory you want, but if you want the archive to be accessible to +;; others via http, this is typically a directory in the /var/www tree +;; (possibly one on a remote machine, accessed via Tramp). + +;; Then call M-x package-upload-file, which prompts for a file to +;; upload. Alternatively, M-x package-upload-buffer uploads the +;; current buffer, if it's visiting a package file. + +;; Once a package is uploaded, users can access it via the Package +;; Menu, by adding the archive to `package-archives'. ;;; Code: (require 'package) (defvar gnus-article-buffer) -;; Note that this only works if you have the password, which you -;; probably don't :-). -(defvar package-archive-upload-base nil - "Base location for uploading to package archive.") +(defcustom package-archive-upload-base "/path/to/archive" + "The base location of the archive to which packages are uploaded. +This should be an absolute directory name. If the archive is on +another machine, you may specify a remote name in the usual way, +e.g. \"/ssh:foo@example.com:/var/www/packages/\". +See Info node `(emacs)Remote Files'. + +Unlike `package-archives', you can't specify a HTTP URL." + :type 'directory + :group 'package + :version "24.1") + +(defvar package-update-news-on-upload nil + "Whether uploading a package should also update NEWS and RSS feeds.") (defun package--encode (string) "Encode a string by replacing some characters with XML entities." @@ -72,13 +95,18 @@ title " - " (package--encode text) " \n")) -(defun package--update-file (file location text) +(defun package--update-file (file tag text) + "Update the package archive file named FILE. +FILE should be relative to `package-archive-upload-base'. +TAG is a string that can be found within the file; TEXT is +inserted after its first occurrence in the file." + (setq file (expand-file-name file package-archive-upload-base)) (save-excursion (let ((old-buffer (find-buffer-visiting file))) (with-current-buffer (let ((find-file-visit-truename t)) (or old-buffer (find-file-noselect file))) (goto-char (point-min)) - (search-forward location) + (search-forward tag) (forward-line) (insert text) (let ((file-precious-flag t)) @@ -86,16 +114,47 @@ (unless old-buffer (kill-buffer (current-buffer))))))) +(defun package--archive-contents-from-url (archive-url) + "Parse archive-contents file at ARCHIVE-URL. +Return the file contents, as a string, or nil if unsuccessful." + (ignore-errors + (when archive-url + (let* ((buffer (url-retrieve-synchronously + (concat archive-url "archive-contents")))) + (set-buffer buffer) + (package-handle-response) + (re-search-forward "^$" nil 'move) + (forward-char) + (delete-region (point-min) (point)) + (prog1 (package-read-from-string + (buffer-substring-no-properties (point-min) (point-max))) + (kill-buffer buffer)))))) + +(defun package--archive-contents-from-file () + "Parse the archive-contents at `package-archive-upload-base'" + (let ((file (expand-file-name "archive-contents" + package-archive-upload-base))) + (if (not (file-exists-p file)) + ;; No existing archive-contents means a new archive. + (list package-archive-version) + (let ((dont-kill (find-buffer-visiting file))) + (with-current-buffer (let ((find-file-visit-truename t)) + (find-file-noselect file)) + (prog1 + (package-read-from-string + (buffer-substring-no-properties (point-min) (point-max))) + (unless dont-kill + (kill-buffer (current-buffer))))))))) + (defun package-maint-add-news-item (title description archive-url) - "Add a news item to the ELPA web pages. + "Add a news item to the webpages associated with the package archive. TITLE is the title of the news item. -DESCRIPTION is the text of the news item. -You need administrative access to ELPA to use this." +DESCRIPTION is the text of the news item." (interactive "sTitle: \nsText: ") - (package--update-file (concat package-archive-upload-base "elpa.rss") + (package--update-file "elpa.rss" "" (package--make-rss-entry title description archive-url)) - (package--update-file (concat package-archive-upload-base "news.html") + (package--update-file "news.html" "New entries go here" (package--make-html-entry title description))) @@ -111,92 +170,109 @@ PKG-INFO is the package info, see `package-buffer-info'. EXTENSION is the file extension, a string. It can be either \"el\" or \"tar\". +The upload destination is given by `package-archive-upload-base'. +If its value is invalid, prompt for a directory. + Optional arg ARCHIVE-URL is the URL of the destination archive. -If nil, the \"gnu\" archive is used." - (unless archive-url - (or (setq archive-url (cdr (assoc "gnu" package-archives))) - (error "No destination URL"))) - (save-excursion - (save-restriction - (let* ((file-type (cond - ((equal extension "el") 'single) - ((equal extension "tar") 'tar) - (t (error "Unknown extension `%s'" extension)))) - (file-name (aref pkg-info 0)) - (pkg-name (intern file-name)) - (requires (aref pkg-info 1)) - (desc (if (string= (aref pkg-info 2) "") - (read-string "Description of package: ") - (aref pkg-info 2))) - (pkg-version (aref pkg-info 3)) - (commentary (aref pkg-info 4)) - (split-version (version-to-list pkg-version)) - (pkg-buffer (current-buffer)) - - ;; Download latest archive-contents. - (buffer (url-retrieve-synchronously - (concat archive-url "archive-contents")))) +If it is non-nil, compute the new \"archive-contents\" file +starting from the existing \"archive-contents\" at that URL. In +addition, if `package-update-news-on-upload' is non-nil, call +`package--update-news' to add a news item at that URL. - ;; Parse archive-contents. - (set-buffer buffer) - (package-handle-response) - (re-search-forward "^$" nil 'move) - (forward-char) - (delete-region (point-min) (point)) - (let ((contents (package-read-from-string - (buffer-substring-no-properties (point-min) - (point-max)))) - (new-desc (vector split-version requires desc file-type))) - (if (> (car contents) package-archive-version) - (error "Unrecognized archive version %d" (car contents))) - (let ((elt (assq pkg-name (cdr contents)))) - (if elt - (if (version-list-<= split-version - (package-desc-vers (cdr elt))) - (error "New package has smaller version: %s" pkg-version) - (setcdr elt new-desc)) - (setq contents (cons (car contents) - (cons (cons pkg-name new-desc) - (cdr contents)))))) - - ;; Now CONTENTS is the updated archive contents. Upload - ;; this and the package itself. For now we assume ELPA is - ;; writable via file primitives. - (let ((print-level nil) - (print-length nil)) - (write-region (concat (pp-to-string contents) "\n") - nil - (concat package-archive-upload-base - "archive-contents"))) - - ;; If there is a commentary section, write it. - (when commentary - (write-region commentary nil - (concat package-archive-upload-base - (symbol-name pkg-name) "-readme.txt"))) - - (set-buffer pkg-buffer) - (kill-buffer buffer) - (write-region (point-min) (point-max) - (concat package-archive-upload-base - file-name "-" pkg-version - "." extension) - nil nil nil 'excl) - - ;; Write a news entry. - (package--update-news (concat file-name "." extension) - pkg-version desc archive-url) - - ;; special-case "package": write a second copy so that the - ;; installer can easily find the latest version. - (if (string= file-name "package") - (write-region (point-min) (point-max) - (concat package-archive-upload-base - file-name "." extension) - nil nil nil 'ask))))))) +If ARCHIVE-URL is nil, compute the new \"archive-contents\" file +from the \"archive-contents\" at `package-archive-upload-base', +if it exists." + (let ((package-archive-upload-base package-archive-upload-base)) + ;; Check if `package-archive-upload-base' is valid. + (when (or (not (stringp package-archive-upload-base)) + (equal package-archive-upload-base + (car-safe + (get 'package-archive-upload-base 'standard-value)))) + (setq package-archive-upload-base + (read-directory-name + "Base directory for package archive: "))) + (unless (file-directory-p package-archive-upload-base) + (if (y-or-n-p (format "%s does not exist; create it? " + package-archive-upload-base)) + (make-directory package-archive-upload-base t) + (error "Aborted"))) + (save-excursion + (save-restriction + (let* ((file-type (cond + ((equal extension "el") 'single) + ((equal extension "tar") 'tar) + (t (error "Unknown extension `%s'" extension)))) + (file-name (aref pkg-info 0)) + (pkg-name (intern file-name)) + (requires (aref pkg-info 1)) + (desc (if (string= (aref pkg-info 2) "") + (read-string "Description of package: ") + (aref pkg-info 2))) + (pkg-version (aref pkg-info 3)) + (commentary (aref pkg-info 4)) + (split-version (version-to-list pkg-version)) + (pkg-buffer (current-buffer))) + + ;; Get archive-contents from ARCHIVE-URL if it's non-nil, or + ;; from `package-archive-upload-base' otherwise. + (let ((contents (or (package--archive-contents-from-url archive-url) + (package--archive-contents-from-file))) + (new-desc (vector split-version requires desc file-type))) + (if (> (car contents) package-archive-version) + (error "Unrecognized archive version %d" (car contents))) + (let ((elt (assq pkg-name (cdr contents)))) + (if elt + (if (version-list-<= split-version + (package-desc-vers (cdr elt))) + (error "New package has smaller version: %s" pkg-version) + (setcdr elt new-desc)) + (setq contents (cons (car contents) + (cons (cons pkg-name new-desc) + (cdr contents)))))) + + ;; Now CONTENTS is the updated archive contents. Upload + ;; this and the package itself. For now we assume ELPA is + ;; writable via file primitives. + (let ((print-level nil) + (print-length nil)) + (write-region (concat (pp-to-string contents) "\n") + nil + (expand-file-name "archive-contents" + package-archive-upload-base))) + + ;; If there is a commentary section, write it. + (when commentary + (write-region commentary nil + (expand-file-name + (concat (symbol-name pkg-name) "-readme.txt") + package-archive-upload-base))) + + (set-buffer pkg-buffer) + (write-region (point-min) (point-max) + (expand-file-name + (concat file-name "-" pkg-version "." extension) + package-archive-upload-base) + nil nil nil 'excl) + + ;; Write a news entry. + (and package-update-news-on-upload + archive-url + (package--update-news (concat file-name "." extension) + pkg-version desc archive-url)) + + ;; special-case "package": write a second copy so that the + ;; installer can easily find the latest version. + (if (string= file-name "package") + (write-region (point-min) (point-max) + (expand-file-name + (concat file-name "." extension) + package-archive-upload-base) + nil nil nil 'ask)))))))) (defun package-upload-buffer () - "Upload a single .el file to ELPA from the current buffer." + "Upload the current buffer as a single-file Emacs Lisp package. +If `package-archive-upload-base' does not specify a valid upload +destination, prompt for one." (interactive) (save-excursion (save-restriction @@ -205,6 +281,12 @@ If nil, the \"gnu\" archive is used." (package-upload-buffer-internal pkg-info "el"))))) (defun package-upload-file (file) + "Upload the Emacs Lisp package FILE to the package archive. +Interactively, prompt for FILE. The package is considered a +single-file package if FILE ends in \".el\", and a multi-file +package if FILE ends in \".tar\". +If `package-archive-upload-base' does not specify a valid upload +destination, prompt for one." (interactive "fPackage file name: ") (with-temp-buffer (insert-file-contents-literally file) @@ -224,4 +306,4 @@ This should be invoked from the gnus *Summary* buffer." (provide 'package-x) -;;; package.el ends here +;;; package-x.el ends here