From 44198b6ee97bcb0ac88a5cadd1bf9b62048d0156 Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Wed, 16 Jun 2010 22:08:10 -0400 Subject: Merge package.el, written by Tom Tromey . Changes relative to version 0.9 of package.el are listed below: * emacs-lisp/package-x.el: New file. Package uploading functionality split out from package.el. * emacs-lisp/package.el (package-archive-base): Point to elpa.gnu.org. (package-enable, package-load-list): New defcustoms. (package-user-dir, package-directory-list): Turn into defcustoms. Don't include package-user-dir in package-directory-list. (package--builtins-base): Don't include Emacs as a "package". (package-subdirectory-regexp): New var. (package-load-all-descriptors, package-compute-transaction) (package-download-transaction): Obey package-load-list. (package-activate-1): Rename from package-do-activate. (package-list-packages-internal): Check package-load-list. (package-load-descriptor, package-generate-autoloads) (package-unpack, package-unpack-single) (package--read-archive-file, package-delete): Use expand-file-name. * startup.el (command-line): Load packages after reading init file. --- lisp/emacs-lisp/package-x.el | 217 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 217 insertions(+) create mode 100644 lisp/emacs-lisp/package-x.el (limited to 'lisp/emacs-lisp/package-x.el') diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el new file mode 100644 index 00000000000..c2d85aa574a --- /dev/null +++ b/lisp/emacs-lisp/package-x.el @@ -0,0 +1,217 @@ +;;; package-x.el --- Package extras + +;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc. + +;; Author: Tom Tromey +;; Created: 10 Mar 2007 +;; Version: 0.9 +;; Keywords: tools + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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, or (at your option) +;; any later version. + +;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This file currently contains parts of the package system most +;; people won't need, such as package uploading. + +;;; Code: + +;; 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.") + +(defun package--encode (string) + "Encode a string by replacing some characters with XML entities." + ;; We need a special case for translating "&" to "&". + (let ((index)) + (while (setq index (string-match "[&]" string index)) + (setq string (replace-match "&" t nil string)) + (setq index (1+ index)))) + (while (string-match "[<]" string) + (setq string (replace-match "<" t nil string))) + (while (string-match "[>]" string) + (setq string (replace-match ">" t nil string))) + (while (string-match "[']" string) + (setq string (replace-match "'" t nil string))) + (while (string-match "[\"]" string) + (setq string (replace-match """ t nil string))) + string) + +(defun package--make-rss-entry (title text) + (let ((date-string (format-time-string "%a, %d %B %Y %T %z"))) + (concat "\n" + "" (package--encode title) "\n" + ;; FIXME: should have a link in the web page. + "" package-archive-base "news.html\n" + "" (package--encode text) "\n" + "" date-string "\n" + "\n"))) + +(defun package--make-html-entry (title text) + (concat "
  • " (format-time-string "%B %e") " - " + title " - " (package--encode text) + "
    • \n")) + +(defun package--update-file (file location text) + (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) + (forward-line) + (insert text) + (let ((file-precious-flag t)) + (save-buffer)) + (unless old-buffer + (kill-buffer (current-buffer))))))) + +(defun package-maint-add-news-item (title description) + "Add a news item to the ELPA web pages. +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." + (interactive "sTitle: \nsText: ") + (package--update-file (concat package-archive-upload-base "elpa.rss") + "" + (package--make-rss-entry title description)) + (package--update-file (concat package-archive-upload-base "news.html") + "New entries go here" + (package--make-html-entry title description))) + +(defun package--update-news (package version description) + "Update the ELPA web pages when a package is uploaded." + (package-maint-add-news-item (concat package " version " version) + description)) + +(defun package-upload-buffer-internal (pkg-info extension) + "Upload a package whose contents are in the current buffer. +PKG-INFO is the package info, see `package-buffer-info'. +EXTENSION is the file extension, a string. It can be either +\"el\" or \"tar\"." + (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 (package-version-split pkg-version)) + (pkg-buffer (current-buffer)) + + ;; Download latest archive-contents. + (buffer (url-retrieve-synchronously + (concat package-archive-base "archive-contents")))) + + ;; 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 (package-version-compare 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) + + ;; 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))))))) + +(defun package-upload-buffer () + "Upload a single .el file to ELPA from the current buffer." + (interactive) + (save-excursion + (save-restriction + ;; Find the package in this buffer. + (let ((pkg-info (package-buffer-info))) + (package-upload-buffer-internal pkg-info "el"))))) + +(defun package-upload-file (file) + (interactive "fPackage file name: ") + (with-temp-buffer + (insert-file-contents-literally file) + (let ((info (cond + ((string-match "\\.tar$" file) (package-tar-file-info file)) + ((string-match "\\.el$" file) (package-buffer-info)) + (t (error "Unrecognized extension `%s'" + (file-name-extension file)))))) + (package-upload-buffer-internal info (file-name-extension file))))) + +(defun package-gnus-summary-upload () + "Upload a package contained in the current *Article* buffer. +This should be invoked from the gnus *Summary* buffer." + (interactive) + (with-current-buffer gnus-article-buffer + (package-upload-buffer))) + +(provide 'package-x) + +;;; package.el ends here -- cgit v1.2.1