code.delx.au - gnu-emacs/blob - lisp/emacs-lisp/package-x.el

   1 ;;; package-x.el --- Package extras
   2
   3 ;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
   4
   5 ;; Author: Tom Tromey <tromey@redhat.com>
   6 ;; Created: 10 Mar 2007
   7 ;; Version: 0.9
   8 ;; Keywords: tools
   9 ;; Package: package
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 3, or (at your option)
  16 ;; any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  26 ;; Boston, MA 02110-1301, USA.
  27
  28 ;;; Commentary:
  29
  30 ;; This file currently contains parts of the package system most
  31 ;; people won't need, such as package uploading.
  32
  33 ;;; Code:
  34
  35 (require 'package)
  36 (defvar gnus-article-buffer)
  37
  38 ;; Note that this only works if you have the password, which you
  39 ;; probably don't :-).
  40 (defvar package-archive-upload-base nil
  41   "Base location for uploading to package archive.")
  42
  43 (defvar package-update-news-on-upload nil
  44   "Whether package upload should also update NEWS and RSS feeds.")
  45
  46 (defun package--encode (string)
  47   "Encode a string by replacing some characters with XML entities."
  48   ;; We need a special case for translating "&" to "&amp;".
  49   (let ((index))
  50     (while (setq index (string-match "[&]" string index))
  51       (setq string (replace-match "&amp;" t nil string))
  52       (setq index (1+ index))))
  53   (while (string-match "[<]" string)
  54     (setq string (replace-match "&lt;" t nil string)))
  55   (while (string-match "[>]" string)
  56     (setq string (replace-match "&gt;" t nil string)))
  57   (while (string-match "[']" string)
  58     (setq string (replace-match "&apos;" t nil string)))
  59   (while (string-match "[\"]" string)
  60     (setq string (replace-match "&quot;" t nil string)))
  61   string)
  62
  63 (defun package--make-rss-entry (title text archive-url)
  64   (let ((date-string (format-time-string "%a, %d %B %Y %T %z")))
  65     (concat "<item>\n"
  66             "<title>" (package--encode title) "</title>\n"
  67             ;; FIXME: should have a link in the web page.
  68             "<link>" archive-url "news.html</link>\n"
  69             "<description>" (package--encode text) "</description>\n"
  70             "<pubDate>" date-string "</pubDate>\n"
  71             "</item>\n")))
  72
  73 (defun package--make-html-entry (title text)
  74   (concat "<li> " (format-time-string "%B %e") " - "
  75           title " - " (package--encode text)
  76           " </li>\n"))
  77
  78 (defun package--update-file (file location text)
  79   (save-excursion
  80     (let ((old-buffer (find-buffer-visiting file)))
  81       (with-current-buffer (let ((find-file-visit-truename t))
  82                              (or old-buffer (find-file-noselect file)))
  83         (goto-char (point-min))
  84         (search-forward location)
  85         (forward-line)
  86         (insert text)
  87         (let ((file-precious-flag t))
  88           (save-buffer))
  89         (unless old-buffer
  90           (kill-buffer (current-buffer)))))))
  91
  92 (defun package--archive-contents-from-url (archive-url)
  93   "Parse archive-contents file at ARCHIVE-URL.
  94 Return the file contents, as a string, or nil if unsuccessful."
  95   (ignore-errors
  96     (when archive-url
  97       (let* ((buffer (url-retrieve-synchronously
  98                       (concat archive-url "archive-contents"))))
  99         (set-buffer buffer)
 100         (package-handle-response)
 101         (re-search-forward "^$" nil 'move)
 102         (forward-char)
 103         (delete-region (point-min) (point))
 104         (prog1 (package-read-from-string
 105                 (buffer-substring-no-properties (point-min) (point-max)))
 106           (kill-buffer buffer))))))
 107
 108 (defun package--archive-contents-from-file (file)
 109   "Parse the given archive-contents file."
 110   (if (not (file-exists-p file))
 111       ;; no existing archive-contents, possibly a new ELPA repo.
 112       (list package-archive-version)
 113     (let ((dont-kill (find-buffer-visiting file)))
 114       (with-current-buffer (let ((find-file-visit-truename t))
 115                              (find-file-noselect file))
 116         (prog1
 117             (package-read-from-string
 118              (buffer-substring-no-properties (point-min) (point-max)))
 119           (unless dont-kill
 120             (kill-buffer (current-buffer))))))))
 121
 122 (defun package-maint-add-news-item (title description archive-url)
 123   "Add a news item to the ELPA web pages.
 124 TITLE is the title of the news item.
 125 DESCRIPTION is the text of the news item.
 126 You need administrative access to ELPA to use this."
 127   (interactive "sTitle: \nsText: ")
 128   (package--update-file (concat package-archive-upload-base "elpa.rss")
 129                         "<description>"
 130                         (package--make-rss-entry title description archive-url))
 131   (package--update-file (concat package-archive-upload-base "news.html")
 132                         "New entries go here"
 133                         (package--make-html-entry title description)))
 134
 135 (defun package--update-news (package version description archive-url)
 136   "Update the ELPA web pages when a package is uploaded."
 137   (package-maint-add-news-item (concat package " version " version)
 138                                description
 139                                archive-url))
 140
 141 (defun package-upload-buffer-internal (pkg-info extension &optional archive-url)
 142   "Upload a package whose contents are in the current buffer.
 143 PKG-INFO is the package info, see `package-buffer-info'.
 144 EXTENSION is the file extension, a string.  It can be either
 145 \"el\" or \"tar\".
 146
 147 The variable `package-archive-upload-base' specifies the upload
 148 destination.  If this is nil, signal an error.
 149
 150 Optional arg ARCHIVE-URL is the URL of the destination archive.
 151 If it is non-nil, compute the new \"archive-contents\" file
 152 starting from the existing \"archive-contents\" at that URL.  In
 153 addition, if `package-update-news-on-upload' is non-nil, call
 154 `package--update-news' to add a news item at that URL.
 155
 156 If ARCHIVE-URL is nil, compute the new \"archive-contents\" file
 157 from the \"archive-contents\" at `package-archive-upload-base',
 158 if it exists."
 159   (unless package-archive-upload-base
 160     (error "No destination specified in `package-archive-upload-base'"))
 161   (save-excursion
 162     (save-restriction
 163       (let* ((file-type (cond
 164                          ((equal extension "el") 'single)
 165                          ((equal extension "tar") 'tar)
 166                          (t (error "Unknown extension `%s'" extension))))
 167              (file-name (aref pkg-info 0))
 168              (pkg-name (intern file-name))
 169              (requires (aref pkg-info 1))
 170              (desc (if (string= (aref pkg-info 2) "")
 171                        (read-string "Description of package: ")
 172                      (aref pkg-info 2)))
 173              (pkg-version (aref pkg-info 3))
 174              (commentary (aref pkg-info 4))
 175              (split-version (version-to-list pkg-version))
 176              (pkg-buffer (current-buffer)))
 177
 178         ;; Get archive-contents from ARCHIVE-URL if it's non-nil, or
 179         ;; from `package-archive-upload-base' otherwise.
 180         (let ((contents (or (package--archive-contents-from-url archive-url)
 181                             (package--archive-contents-from-file
 182                              (concat package-archive-upload-base
 183                                      "archive-contents"))))
 184               (new-desc (vector split-version requires desc file-type)))
 185           (if (> (car contents) package-archive-version)
 186               (error "Unrecognized archive version %d" (car contents)))
 187           (let ((elt (assq pkg-name (cdr contents))))
 188             (if elt
 189                 (if (version-list-<= split-version
 190                                      (package-desc-vers (cdr elt)))
 191                     (error "New package has smaller version: %s" pkg-version)
 192                   (setcdr elt new-desc))
 193               (setq contents (cons (car contents)
 194                                    (cons (cons pkg-name new-desc)
 195                                          (cdr contents))))))
 196
 197           ;; Now CONTENTS is the updated archive contents.  Upload
 198           ;; this and the package itself.  For now we assume ELPA is
 199           ;; writable via file primitives.
 200           (let ((print-level nil)
 201                 (print-length nil))
 202             (write-region (concat (pp-to-string contents) "\n")
 203                           nil
 204                           (concat package-archive-upload-base
 205                                   "archive-contents")))
 206
 207           ;; If there is a commentary section, write it.
 208           (when commentary
 209             (write-region commentary nil
 210                           (concat package-archive-upload-base
 211                                   (symbol-name pkg-name) "-readme.txt")))
 212
 213           (set-buffer pkg-buffer)
 214           (write-region (point-min) (point-max)
 215                         (concat package-archive-upload-base
 216                                 file-name "-" pkg-version
 217                                 "." extension)
 218                         nil nil nil 'excl)
 219
 220           ;; Write a news entry.
 221           (and package-update-news-on-upload
 222                archive-url
 223                (package--update-news (concat file-name "." extension)
 224                                      pkg-version desc archive-url))
 225
 226           ;; special-case "package": write a second copy so that the
 227           ;; installer can easily find the latest version.
 228           (if (string= file-name "package")
 229               (write-region (point-min) (point-max)
 230                             (concat package-archive-upload-base
 231                                     file-name "." extension)
 232                             nil nil nil 'ask)))))))
 233
 234 (defun package-upload-buffer ()
 235   "Upload the current buffer as a single-file Emacs Lisp package.
 236 The variable `package-archive-upload-base' specifies the upload
 237 destination."
 238   (interactive)
 239   (save-excursion
 240     (save-restriction
 241       ;; Find the package in this buffer.
 242       (let ((pkg-info (package-buffer-info)))
 243         (package-upload-buffer-internal pkg-info "el")))))
 244
 245 (defun package-upload-file (file)
 246   "Upload the Emacs Lisp package FILE to the package archive.
 247 Interactively, prompt for FILE.  The package is considered a
 248 single-file package if FILE ends in \".el\", and a multi-file
 249 package if FILE ends in \".tar\".
 250
 251 The variable `package-archive-upload-base' specifies the upload
 252 destination."
 253   (interactive "fPackage file name: ")
 254   (with-temp-buffer
 255     (insert-file-contents-literally file)
 256     (let ((info (cond
 257                  ((string-match "\\.tar$" file) (package-tar-file-info file))
 258                  ((string-match "\\.el$" file) (package-buffer-info))
 259                  (t (error "Unrecognized extension `%s'"
 260                            (file-name-extension file))))))
 261       (package-upload-buffer-internal info (file-name-extension file)))))
 262
 263 (defun package-gnus-summary-upload ()
 264   "Upload a package contained in the current *Article* buffer.
 265 This should be invoked from the gnus *Summary* buffer."
 266   (interactive)
 267   (with-current-buffer gnus-article-buffer
 268     (package-upload-buffer)))
 269
 270 (provide 'package-x)
 271
 272 ;;; package.el ends here