lisp/emacs-lisp/package-x.el

   1 ;;; package-x.el --- Package extras
   2
   3 ;; Copyright (C) 2007, 2008, 2009, 2010 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 (defun package--encode (string)
  44   "Encode a string by replacing some characters with XML entities."
  45   ;; We need a special case for translating "&" to "&amp;".
  46   (let ((index))
  47     (while (setq index (string-match "[&]" string index))
  48       (setq string (replace-match "&amp;" t nil string))
  49       (setq index (1+ index))))
  50   (while (string-match "[<]" string)
  51     (setq string (replace-match "&lt;" t nil string)))
  52   (while (string-match "[>]" string)
  53     (setq string (replace-match "&gt;" t nil string)))
  54   (while (string-match "[']" string)
  55     (setq string (replace-match "&apos;" t nil string)))
  56   (while (string-match "[\"]" string)
  57     (setq string (replace-match "&quot;" t nil string)))
  58   string)
  59
  60 (defun package--make-rss-entry (title text archive-url)
  61   (let ((date-string (format-time-string "%a, %d %B %Y %T %z")))
  62     (concat "<item>\n"
  63             "<title>" (package--encode title) "</title>\n"
  64             ;; FIXME: should have a link in the web page.
  65             "<link>" archive-url "news.html</link>\n"
  66             "<description>" (package--encode text) "</description>\n"
  67             "<pubDate>" date-string "</pubDate>\n"
  68             "</item>\n")))
  69
  70 (defun package--make-html-entry (title text)
  71   (concat "<li> " (format-time-string "%B %e") " - "
  72           title " - " (package--encode text)
  73           " </li>\n"))
  74
  75 (defun package--update-file (file location text)
  76   (save-excursion
  77     (let ((old-buffer (find-buffer-visiting file)))
  78       (with-current-buffer (let ((find-file-visit-truename t))
  79                              (or old-buffer (find-file-noselect file)))
  80         (goto-char (point-min))
  81         (search-forward location)
  82         (forward-line)
  83         (insert text)
  84         (let ((file-precious-flag t))
  85           (save-buffer))
  86         (unless old-buffer
  87           (kill-buffer (current-buffer)))))))
  88
  89 (defun package-maint-add-news-item (title description archive-url)
  90   "Add a news item to the ELPA web pages.
  91 TITLE is the title of the news item.
  92 DESCRIPTION is the text of the news item.
  93 You need administrative access to ELPA to use this."
  94   (interactive "sTitle: \nsText: ")
  95   (package--update-file (concat package-archive-upload-base "elpa.rss")
  96                         "<description>"
  97                         (package--make-rss-entry title description archive-url))
  98   (package--update-file (concat package-archive-upload-base "news.html")
  99                         "New entries go here"
 100                         (package--make-html-entry title description)))
 101
 102 (defun package--update-news (package version description archive-url)
 103   "Update the ELPA web pages when a package is uploaded."
 104   (package-maint-add-news-item (concat package " version " version)
 105                                description
 106                                archive-url))
 107
 108 (defun package-upload-buffer-internal (pkg-info extension &optional archive-url)
 109   "Upload a package whose contents are in the current buffer.
 110 PKG-INFO is the package info, see `package-buffer-info'.
 111 EXTENSION is the file extension, a string.  It can be either
 112 \"el\" or \"tar\".
 113
 114 Optional arg ARCHIVE-URL is the URL of the destination archive.
 115 If nil, the \"gnu\" archive is used."
 116   (unless archive-url
 117     (or (setq archive-url (cdr (assoc "gnu" package-archives)))
 118         (error "No destination URL")))
 119   (save-excursion
 120     (save-restriction
 121       (let* ((file-type (cond
 122                          ((equal extension "el") 'single)
 123                          ((equal extension "tar") 'tar)
 124                          (t (error "Unknown extension `%s'" extension))))
 125              (file-name (aref pkg-info 0))
 126              (pkg-name (intern file-name))
 127              (requires (aref pkg-info 1))
 128              (desc (if (string= (aref pkg-info 2) "")
 129                        (read-string "Description of package: ")
 130                      (aref pkg-info 2)))
 131              (pkg-version (aref pkg-info 3))
 132              (commentary (aref pkg-info 4))
 133              (split-version (version-to-list pkg-version))
 134              (pkg-buffer (current-buffer))
 135
 136              ;; Download latest archive-contents.
 137              (buffer (url-retrieve-synchronously
 138                       (concat archive-url "archive-contents"))))
 139
 140         ;; Parse archive-contents.
 141         (set-buffer buffer)
 142         (package-handle-response)
 143         (re-search-forward "^$" nil 'move)
 144         (forward-char)
 145         (delete-region (point-min) (point))
 146         (let ((contents (package-read-from-string
 147                          (buffer-substring-no-properties (point-min)
 148                                                          (point-max))))
 149               (new-desc (vector split-version requires desc file-type)))
 150           (if (> (car contents) package-archive-version)
 151               (error "Unrecognized archive version %d" (car contents)))
 152           (let ((elt (assq pkg-name (cdr contents))))
 153             (if elt
 154                 (if (version-list-<= split-version
 155                                      (package-desc-vers (cdr elt)))
 156                     (error "New package has smaller version: %s" pkg-version)
 157                   (setcdr elt new-desc))
 158               (setq contents (cons (car contents)
 159                                    (cons (cons pkg-name new-desc)
 160                                          (cdr contents))))))
 161
 162           ;; Now CONTENTS is the updated archive contents.  Upload
 163           ;; this and the package itself.  For now we assume ELPA is
 164           ;; writable via file primitives.
 165           (let ((print-level nil)
 166                 (print-length nil))
 167             (write-region (concat (pp-to-string contents) "\n")
 168                           nil
 169                           (concat package-archive-upload-base
 170                                   "archive-contents")))
 171
 172           ;; If there is a commentary section, write it.
 173           (when commentary
 174             (write-region commentary nil
 175                           (concat package-archive-upload-base
 176                                   (symbol-name pkg-name) "-readme.txt")))
 177
 178           (set-buffer pkg-buffer)
 179           (kill-buffer buffer)
 180           (write-region (point-min) (point-max)
 181                         (concat package-archive-upload-base
 182                                 file-name "-" pkg-version
 183                                 "." extension)
 184                         nil nil nil 'excl)
 185
 186           ;; Write a news entry.
 187           (package--update-news (concat file-name "." extension)
 188                                 pkg-version desc archive-url)
 189
 190           ;; special-case "package": write a second copy so that the
 191           ;; installer can easily find the latest version.
 192           (if (string= file-name "package")
 193               (write-region (point-min) (point-max)
 194                             (concat package-archive-upload-base
 195                                     file-name "." extension)
 196                             nil nil nil 'ask)))))))
 197
 198 (defun package-upload-buffer ()
 199   "Upload a single .el file to ELPA from the current buffer."
 200   (interactive)
 201   (save-excursion
 202     (save-restriction
 203       ;; Find the package in this buffer.
 204       (let ((pkg-info (package-buffer-info)))
 205         (package-upload-buffer-internal pkg-info "el")))))
 206
 207 (defun package-upload-file (file)
 208   (interactive "fPackage file name: ")
 209   (with-temp-buffer
 210     (insert-file-contents-literally file)
 211     (let ((info (cond
 212                  ((string-match "\\.tar$" file) (package-tar-file-info file))
 213                  ((string-match "\\.el$" file) (package-buffer-info))
 214                  (t (error "Unrecognized extension `%s'"
 215                            (file-name-extension file))))))
 216       (package-upload-buffer-internal info (file-name-extension file)))))
 217
 218 (defun package-gnus-summary-upload ()
 219   "Upload a package contained in the current *Article* buffer.
 220 This should be invoked from the gnus *Summary* buffer."
 221   (interactive)
 222   (with-current-buffer gnus-article-buffer
 223     (package-upload-buffer)))
 224
 225 (provide 'package-x)
 226
 227 ;;; package.el ends here