lisp/emacs-lisp/package-x.el

   1 ;;; package-x.el --- Package extras
   2
   3 ;; Copyright (C) 2007-2013 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 of the License, or
  16 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
  25
  26 ;;; Commentary:
  27
  28 ;; This file currently contains parts of the package system that many
  29 ;; won't need, such as package uploading.
  30
  31 ;; To upload to an archive, first set `package-archive-upload-base' to
  32 ;; some desired directory.  For testing purposes, you can specify any
  33 ;; directory you want, but if you want the archive to be accessible to
  34 ;; others via http, this is typically a directory in the /var/www tree
  35 ;; (possibly one on a remote machine, accessed via Tramp).
  36
  37 ;; Then call M-x package-upload-file, which prompts for a file to
  38 ;; upload. Alternatively, M-x package-upload-buffer uploads the
  39 ;; current buffer, if it's visiting a package file.
  40
  41 ;; Once a package is uploaded, users can access it via the Package
  42 ;; Menu, by adding the archive to `package-archives'.
  43
  44 ;;; Code:
  45
  46 (require 'package)
  47 (defvar gnus-article-buffer)
  48
  49 (defcustom package-archive-upload-base "/path/to/archive"
  50   "The base location of the archive to which packages are uploaded.
  51 This should be an absolute directory name.  If the archive is on
  52 another machine, you may specify a remote name in the usual way,
  53 e.g. \"/ssh:foo@example.com:/var/www/packages/\".
  54 See Info node `(emacs)Remote Files'.
  55
  56 Unlike `package-archives', you can't specify a HTTP URL."
  57   :type 'directory
  58   :group 'package
  59   :version "24.1")
  60
  61 (defvar package-update-news-on-upload nil
  62   "Whether uploading a package should also update NEWS and RSS feeds.")
  63
  64 (defun package--encode (string)
  65   "Encode a string by replacing some characters with XML entities."
  66   ;; We need a special case for translating "&" to "&amp;".
  67   (let ((index))
  68     (while (setq index (string-match "[&]" string index))
  69       (setq string (replace-match "&amp;" t nil string))
  70       (setq index (1+ index))))
  71   (while (string-match "[<]" string)
  72     (setq string (replace-match "&lt;" t nil string)))
  73   (while (string-match "[>]" string)
  74     (setq string (replace-match "&gt;" t nil string)))
  75   (while (string-match "[']" string)
  76     (setq string (replace-match "&apos;" t nil string)))
  77   (while (string-match "[\"]" string)
  78     (setq string (replace-match "&quot;" t nil string)))
  79   string)
  80
  81 (defun package--make-rss-entry (title text archive-url)
  82   (let ((date-string (format-time-string "%a, %d %B %Y %T %z")))
  83     (concat "<item>\n"
  84             "<title>" (package--encode title) "</title>\n"
  85             ;; FIXME: should have a link in the web page.
  86             "<link>" archive-url "news.html</link>\n"
  87             "<description>" (package--encode text) "</description>\n"
  88             "<pubDate>" date-string "</pubDate>\n"
  89             "</item>\n")))
  90
  91 (defun package--make-html-entry (title text)
  92   (concat "<li> " (format-time-string "%B %e") " - "
  93           title " - " (package--encode text)
  94           " </li>\n"))
  95
  96 (defun package--update-file (file tag text)
  97   "Update the package archive file named FILE.
  98 FILE should be relative to `package-archive-upload-base'.
  99 TAG is a string that can be found within the file; TEXT is
 100 inserted after its first occurrence in the file."
 101   (setq file (expand-file-name file package-archive-upload-base))
 102   (save-excursion
 103     (let ((old-buffer (find-buffer-visiting file)))
 104       (with-current-buffer (let ((find-file-visit-truename t))
 105                              (or old-buffer (find-file-noselect file)))
 106         (goto-char (point-min))
 107         (search-forward tag)
 108         (forward-line)
 109         (insert text)
 110         (let ((file-precious-flag t))
 111           (save-buffer))
 112         (unless old-buffer
 113           (kill-buffer (current-buffer)))))))
 114
 115 (defun package--archive-contents-from-url (archive-url)
 116   "Parse archive-contents file at ARCHIVE-URL.
 117 Return the file contents, as a string, or nil if unsuccessful."
 118   (ignore-errors
 119     (when archive-url
 120       (let* ((buffer (url-retrieve-synchronously
 121                       (concat archive-url "archive-contents"))))
 122         (set-buffer buffer)
 123         (package-handle-response)
 124         (re-search-forward "^$" nil 'move)
 125         (forward-char)
 126         (delete-region (point-min) (point))
 127         (prog1 (package-read-from-string
 128                 (buffer-substring-no-properties (point-min) (point-max)))
 129           (kill-buffer buffer))))))
 130
 131 (defun package--archive-contents-from-file ()
 132   "Parse the archive-contents at `package-archive-upload-base'"
 133   (let ((file (expand-file-name "archive-contents"
 134                                 package-archive-upload-base)))
 135     (if (not (file-exists-p file))
 136         ;; No existing archive-contents means a new archive.
 137         (list package-archive-version)
 138       (let ((dont-kill (find-buffer-visiting file)))
 139         (with-current-buffer (let ((find-file-visit-truename t))
 140                                (find-file-noselect file))
 141           (prog1
 142               (package-read-from-string
 143                (buffer-substring-no-properties (point-min) (point-max)))
 144             (unless dont-kill
 145               (kill-buffer (current-buffer)))))))))
 146
 147 (defun package-maint-add-news-item (title description archive-url)
 148   "Add a news item to the webpages associated with the package archive.
 149 TITLE is the title of the news item.
 150 DESCRIPTION is the text of the news item."
 151   (interactive "sTitle: \nsText: ")
 152   (package--update-file "elpa.rss"
 153                         "<description>"
 154                         (package--make-rss-entry title description archive-url))
 155   (package--update-file "news.html"
 156                         "New entries go here"
 157                         (package--make-html-entry title description)))
 158
 159 (defun package--update-news (package version description archive-url)
 160   "Update the ELPA web pages when a package is uploaded."
 161   (package-maint-add-news-item (concat package " version " version)
 162                                description
 163                                archive-url))
 164
 165 (defun package-upload-buffer-internal (pkg-info extension &optional archive-url)
 166   "Upload a package whose contents are in the current buffer.
 167 PKG-INFO is the package info, see `package-buffer-info'.
 168 EXTENSION is the file extension, a string.  It can be either
 169 \"el\" or \"tar\".
 170
 171 The upload destination is given by `package-archive-upload-base'.
 172 If its value is invalid, prompt for a directory.
 173
 174 Optional arg ARCHIVE-URL is the URL of the destination archive.
 175 If it is non-nil, compute the new \"archive-contents\" file
 176 starting from the existing \"archive-contents\" at that URL.  In
 177 addition, if `package-update-news-on-upload' is non-nil, call
 178 `package--update-news' to add a news item at that URL.
 179
 180 If ARCHIVE-URL is nil, compute the new \"archive-contents\" file
 181 from the \"archive-contents\" at `package-archive-upload-base',
 182 if it exists."
 183   (let ((package-archive-upload-base package-archive-upload-base))
 184     ;; Check if `package-archive-upload-base' is valid.
 185     (when (or (not (stringp package-archive-upload-base))
 186               (equal package-archive-upload-base
 187                      (car-safe
 188                       (get 'package-archive-upload-base 'standard-value))))
 189       (setq package-archive-upload-base
 190             (read-directory-name
 191              "Base directory for package archive: ")))
 192     (unless (file-directory-p package-archive-upload-base)
 193       (if (y-or-n-p (format "%s does not exist; create it? "
 194                             package-archive-upload-base))
 195           (make-directory package-archive-upload-base t)
 196         (error "Aborted")))
 197     (save-excursion
 198       (save-restriction
 199         (let* ((file-type (cond
 200                            ((equal extension "el") 'single)
 201                            ((equal extension "tar") 'tar)
 202                            (t (error "Unknown extension `%s'" extension))))
 203                (file-name (aref pkg-info 0))
 204                (pkg-name (intern file-name))
 205                (requires (aref pkg-info 1))
 206                (desc (if (string= (aref pkg-info 2) "")
 207                          (read-string "Description of package: ")
 208                        (aref pkg-info 2)))
 209                (pkg-version (aref pkg-info 3))
 210                (commentary (aref pkg-info 4))
 211                (split-version (version-to-list pkg-version))
 212                (pkg-buffer (current-buffer)))
 213
 214           ;; Get archive-contents from ARCHIVE-URL if it's non-nil, or
 215           ;; from `package-archive-upload-base' otherwise.
 216           (let ((contents (or (package--archive-contents-from-url archive-url)
 217                               (package--archive-contents-from-file)))
 218                 (new-desc (vector split-version requires desc file-type)))
 219             (if (> (car contents) package-archive-version)
 220                 (error "Unrecognized archive version %d" (car contents)))
 221             (let ((elt (assq pkg-name (cdr contents))))
 222               (if elt
 223                   (if (version-list-<= split-version
 224                                        (package-desc-vers (cdr elt)))
 225                       (error "New package has smaller version: %s" pkg-version)
 226                     (setcdr elt new-desc))
 227                 (setq contents (cons (car contents)
 228                                      (cons (cons pkg-name new-desc)
 229                                            (cdr contents))))))
 230
 231             ;; Now CONTENTS is the updated archive contents.  Upload
 232             ;; this and the package itself.  For now we assume ELPA is
 233             ;; writable via file primitives.
 234             (let ((print-level nil)
 235                   (print-length nil))
 236               (write-region (concat (pp-to-string contents) "\n")
 237                             nil
 238                             (expand-file-name "archive-contents"
 239                                               package-archive-upload-base)))
 240
 241             ;; If there is a commentary section, write it.
 242             (when commentary
 243               (write-region commentary nil
 244                             (expand-file-name
 245                              (concat (symbol-name pkg-name) "-readme.txt")
 246                              package-archive-upload-base)))
 247
 248             (set-buffer pkg-buffer)
 249             (write-region (point-min) (point-max)
 250                           (expand-file-name
 251                            (concat file-name "-" pkg-version "." extension)
 252                            package-archive-upload-base)
 253                           nil nil nil 'excl)
 254
 255             ;; Write a news entry.
 256             (and package-update-news-on-upload
 257                  archive-url
 258                  (package--update-news (concat file-name "." extension)
 259                                        pkg-version desc archive-url))
 260
 261             ;; special-case "package": write a second copy so that the
 262             ;; installer can easily find the latest version.
 263             (if (string= file-name "package")
 264                 (write-region (point-min) (point-max)
 265                               (expand-file-name
 266                                (concat file-name "." extension)
 267                                package-archive-upload-base)
 268                               nil nil nil 'ask))))))))
 269
 270 (defun package-upload-buffer ()
 271   "Upload the current buffer as a single-file Emacs Lisp package.
 272 If `package-archive-upload-base' does not specify a valid upload
 273 destination, prompt for one."
 274   (interactive)
 275   (save-excursion
 276     (save-restriction
 277       ;; Find the package in this buffer.
 278       (let ((pkg-info (package-buffer-info)))
 279         (package-upload-buffer-internal pkg-info "el")))))
 280
 281 (defun package-upload-file (file)
 282   "Upload the Emacs Lisp package FILE to the package archive.
 283 Interactively, prompt for FILE.  The package is considered a
 284 single-file package if FILE ends in \".el\", and a multi-file
 285 package if FILE ends in \".tar\".
 286 If `package-archive-upload-base' does not specify a valid upload
 287 destination, prompt for one."
 288   (interactive "fPackage file name: ")
 289   (with-temp-buffer
 290     (insert-file-contents-literally file)
 291     (let ((info (cond
 292                  ((string-match "\\.tar$" file) (package-tar-file-info file))
 293                  ((string-match "\\.el$" file) (package-buffer-info))
 294                  (t (error "Unrecognized extension `%s'"
 295                            (file-name-extension file))))))
 296       (package-upload-buffer-internal info (file-name-extension file)))))
 297
 298 (defun package-gnus-summary-upload ()
 299   "Upload a package contained in the current *Article* buffer.
 300 This should be invoked from the gnus *Summary* buffer."
 301   (interactive)
 302   (with-current-buffer gnus-article-buffer
 303     (package-upload-buffer)))
 304
 305 (provide 'package-x)
 306
 307 ;;; package-x.el ends here