Commit | Line | Data |
---|---|---|
44198b6e CY |
1 | ;;; package-x.el --- Package extras |
2 | ||
ba318903 | 3 | ;; Copyright (C) 2007-2014 Free Software Foundation, Inc. |
44198b6e CY |
4 | |
5 | ;; Author: Tom Tromey <tromey@redhat.com> | |
6 | ;; Created: 10 Mar 2007 | |
44198b6e | 7 | ;; Keywords: tools |
bd78fa1d | 8 | ;; Package: package |
44198b6e CY |
9 | |
10 | ;; This file is part of GNU Emacs. | |
11 | ||
267b82ff | 12 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
44198b6e | 13 | ;; it under the terms of the GNU General Public License as published by |
267b82ff GM |
14 | ;; the Free Software Foundation, either version 3 of the License, or |
15 | ;; (at your option) any later version. | |
44198b6e CY |
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 | |
267b82ff | 23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
44198b6e CY |
24 | |
25 | ;;; Commentary: | |
26 | ||
5c69cb2c CY |
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'. | |
44198b6e CY |
42 | |
43 | ;;; Code: | |
44 | ||
cced7584 CY |
45 | (require 'package) |
46 | (defvar gnus-article-buffer) | |
47 | ||
5c69cb2c CY |
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") | |
44198b6e | 59 | |
7fe42546 | 60 | (defvar package-update-news-on-upload nil |
5c69cb2c | 61 | "Whether uploading a package should also update NEWS and RSS feeds.") |
7fe42546 | 62 | |
44198b6e CY |
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 "&". | |
66 | (let ((index)) | |
67 | (while (setq index (string-match "[&]" string index)) | |
68 | (setq string (replace-match "&" t nil string)) | |
69 | (setq index (1+ index)))) | |
70 | (while (string-match "[<]" string) | |
71 | (setq string (replace-match "<" t nil string))) | |
72 | (while (string-match "[>]" string) | |
73 | (setq string (replace-match ">" t nil string))) | |
74 | (while (string-match "[']" string) | |
75 | (setq string (replace-match "'" t nil string))) | |
76 | (while (string-match "[\"]" string) | |
77 | (setq string (replace-match """ t nil string))) | |
78 | string) | |
79 | ||
063e5294 | 80 | (defun package--make-rss-entry (title text archive-url) |
44198b6e CY |
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. | |
063e5294 | 85 | "<link>" archive-url "news.html</link>\n" |
44198b6e CY |
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 | ||
5c69cb2c CY |
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)) | |
44198b6e CY |
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)) | |
5c69cb2c | 106 | (search-forward tag) |
44198b6e CY |
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 | ||
7fe42546 J |
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." | |
b1c870c9 JB |
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))))))) | |
7fe42546 | 123 | |
5c69cb2c CY |
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))))))))) | |
7fe42546 | 139 | |
063e5294 | 140 | (defun package-maint-add-news-item (title description archive-url) |
5c69cb2c | 141 | "Add a news item to the webpages associated with the package archive. |
44198b6e | 142 | TITLE is the title of the news item. |
5c69cb2c | 143 | DESCRIPTION is the text of the news item." |
44198b6e | 144 | (interactive "sTitle: \nsText: ") |
5c69cb2c | 145 | (package--update-file "elpa.rss" |
44198b6e | 146 | "<description>" |
063e5294 | 147 | (package--make-rss-entry title description archive-url)) |
5c69cb2c | 148 | (package--update-file "news.html" |
44198b6e CY |
149 | "New entries go here" |
150 | (package--make-html-entry title description))) | |
151 | ||
063e5294 | 152 | (defun package--update-news (package version description archive-url) |
44198b6e CY |
153 | "Update the ELPA web pages when a package is uploaded." |
154 | (package-maint-add-news-item (concat package " version " version) | |
063e5294 CY |
155 | description |
156 | archive-url)) | |
44198b6e | 157 | |
f56be016 SM |
158 | (declare-function lm-commentary "lisp-mnt" (&optional file)) |
159 | ||
160 | (defun package-upload-buffer-internal (pkg-desc extension &optional archive-url) | |
44198b6e | 161 | "Upload a package whose contents are in the current buffer. |
f56be016 | 162 | PKG-DESC is the `package-desc'. |
44198b6e | 163 | EXTENSION is the file extension, a string. It can be either |
063e5294 CY |
164 | \"el\" or \"tar\". |
165 | ||
5c69cb2c CY |
166 | The upload destination is given by `package-archive-upload-base'. |
167 | If its value is invalid, prompt for a directory. | |
7fe42546 | 168 | |
063e5294 | 169 | Optional arg ARCHIVE-URL is the URL of the destination archive. |
7fe42546 J |
170 | If it is non-nil, compute the new \"archive-contents\" file |
171 | starting from the existing \"archive-contents\" at that URL. In | |
172 | addition, if `package-update-news-on-upload' is non-nil, call | |
173 | `package--update-news' to add a news item at that URL. | |
174 | ||
175 | If ARCHIVE-URL is nil, compute the new \"archive-contents\" file | |
176 | from the \"archive-contents\" at `package-archive-upload-base', | |
177 | if it exists." | |
5c69cb2c CY |
178 | (let ((package-archive-upload-base package-archive-upload-base)) |
179 | ;; Check if `package-archive-upload-base' is valid. | |
180 | (when (or (not (stringp package-archive-upload-base)) | |
b511b994 MA |
181 | (equal package-archive-upload-base |
182 | (car-safe | |
183 | (get 'package-archive-upload-base 'standard-value)))) | |
5c69cb2c CY |
184 | (setq package-archive-upload-base |
185 | (read-directory-name | |
186 | "Base directory for package archive: "))) | |
187 | (unless (file-directory-p package-archive-upload-base) | |
188 | (if (y-or-n-p (format "%s does not exist; create it? " | |
189 | package-archive-upload-base)) | |
190 | (make-directory package-archive-upload-base t) | |
191 | (error "Aborted"))) | |
192 | (save-excursion | |
193 | (save-restriction | |
f56be016 SM |
194 | (let* ((file-type (package-desc-kind pkg-desc)) |
195 | (pkg-name (package-desc-name pkg-desc)) | |
196 | (requires (package-desc-reqs pkg-desc)) | |
197 | (desc (if (eq (package-desc-summary pkg-desc) | |
198 | package--default-summary) | |
5c69cb2c | 199 | (read-string "Description of package: ") |
f56be016 | 200 | (package-desc-summary pkg-desc))) |
9ea5cf9f | 201 | (split-version (package-desc-version pkg-desc)) |
f56be016 SM |
202 | (commentary |
203 | (pcase file-type | |
204 | (`single (lm-commentary)) | |
205 | (`tar nil))) ;; FIXME: Get it from the README file. | |
056453c6 | 206 | (extras (package-desc-extras pkg-desc)) |
9ea5cf9f | 207 | (pkg-version (package-version-join split-version)) |
5c69cb2c CY |
208 | (pkg-buffer (current-buffer))) |
209 | ||
210 | ;; Get archive-contents from ARCHIVE-URL if it's non-nil, or | |
211 | ;; from `package-archive-upload-base' otherwise. | |
212 | (let ((contents (or (package--archive-contents-from-url archive-url) | |
213 | (package--archive-contents-from-file))) | |
f56be016 | 214 | (new-desc (package-make-ac-desc |
056453c6 | 215 | split-version requires desc file-type extras))) |
5c69cb2c CY |
216 | (if (> (car contents) package-archive-version) |
217 | (error "Unrecognized archive version %d" (car contents))) | |
218 | (let ((elt (assq pkg-name (cdr contents)))) | |
219 | (if elt | |
220 | (if (version-list-<= split-version | |
9ea5cf9f | 221 | (package--ac-desc-version (cdr elt))) |
5c69cb2c CY |
222 | (error "New package has smaller version: %s" pkg-version) |
223 | (setcdr elt new-desc)) | |
224 | (setq contents (cons (car contents) | |
225 | (cons (cons pkg-name new-desc) | |
226 | (cdr contents)))))) | |
227 | ||
228 | ;; Now CONTENTS is the updated archive contents. Upload | |
229 | ;; this and the package itself. For now we assume ELPA is | |
230 | ;; writable via file primitives. | |
231 | (let ((print-level nil) | |
f56be016 | 232 | (print-quoted t) |
5c69cb2c CY |
233 | (print-length nil)) |
234 | (write-region (concat (pp-to-string contents) "\n") | |
235 | nil | |
236 | (expand-file-name "archive-contents" | |
237 | package-archive-upload-base))) | |
238 | ||
239 | ;; If there is a commentary section, write it. | |
240 | (when commentary | |
241 | (write-region commentary nil | |
f56be016 SM |
242 | (expand-file-name |
243 | (concat (symbol-name pkg-name) "-readme.txt") | |
244 | package-archive-upload-base))) | |
5c69cb2c CY |
245 | |
246 | (set-buffer pkg-buffer) | |
247 | (write-region (point-min) (point-max) | |
248 | (expand-file-name | |
f56be016 | 249 | (format "%s-%s.%s" pkg-name pkg-version extension) |
5c69cb2c CY |
250 | package-archive-upload-base) |
251 | nil nil nil 'excl) | |
252 | ||
253 | ;; Write a news entry. | |
254 | (and package-update-news-on-upload | |
255 | archive-url | |
f56be016 | 256 | (package--update-news (format "%s.%s" pkg-name extension) |
5c69cb2c CY |
257 | pkg-version desc archive-url)) |
258 | ||
259 | ;; special-case "package": write a second copy so that the | |
260 | ;; installer can easily find the latest version. | |
f56be016 | 261 | (if (eq pkg-name 'package) |
5c69cb2c CY |
262 | (write-region (point-min) (point-max) |
263 | (expand-file-name | |
f56be016 | 264 | (format "%s.%s" pkg-name extension) |
5c69cb2c CY |
265 | package-archive-upload-base) |
266 | nil nil nil 'ask)))))))) | |
44198b6e CY |
267 | |
268 | (defun package-upload-buffer () | |
7fe42546 | 269 | "Upload the current buffer as a single-file Emacs Lisp package. |
5c69cb2c CY |
270 | If `package-archive-upload-base' does not specify a valid upload |
271 | destination, prompt for one." | |
44198b6e CY |
272 | (interactive) |
273 | (save-excursion | |
274 | (save-restriction | |
275 | ;; Find the package in this buffer. | |
f56be016 SM |
276 | (let ((pkg-desc (package-buffer-info))) |
277 | (package-upload-buffer-internal pkg-desc "el"))))) | |
44198b6e CY |
278 | |
279 | (defun package-upload-file (file) | |
7fe42546 J |
280 | "Upload the Emacs Lisp package FILE to the package archive. |
281 | Interactively, prompt for FILE. The package is considered a | |
282 | single-file package if FILE ends in \".el\", and a multi-file | |
283 | package if FILE ends in \".tar\". | |
5c69cb2c CY |
284 | If `package-archive-upload-base' does not specify a valid upload |
285 | destination, prompt for one." | |
44198b6e CY |
286 | (interactive "fPackage file name: ") |
287 | (with-temp-buffer | |
fd846ab4 | 288 | (insert-file-contents file) |
f56be016 SM |
289 | (let ((pkg-desc |
290 | (cond | |
fd846ab4 SM |
291 | ((string-match "\\.tar\\'" file) |
292 | (tar-mode) (package-tar-file-info)) | |
f56be016 SM |
293 | ((string-match "\\.el\\'" file) (package-buffer-info)) |
294 | (t (error "Unrecognized extension `%s'" | |
295 | (file-name-extension file)))))) | |
296 | (package-upload-buffer-internal pkg-desc (file-name-extension file))))) | |
44198b6e CY |
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 | ||
b511b994 | 307 | ;;; package-x.el ends here |