lisp/emacs-lisp/package-x.el

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