Commit | Line | Data |
---|---|---|
44198b6e CY |
1 | ;;; package-x.el --- Package extras |
2 | ||
acaf905b | 3 | ;; Copyright (C) 2007-2012 Free Software Foundation, Inc. |
44198b6e CY |
4 | |
5 | ;; Author: Tom Tromey <tromey@redhat.com> | |
6 | ;; Created: 10 Mar 2007 | |
7 | ;; Version: 0.9 | |
8 | ;; Keywords: tools | |
bd78fa1d | 9 | ;; Package: package |
44198b6e CY |
10 | |
11 | ;; This file is part of GNU Emacs. | |
12 | ||
267b82ff | 13 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
44198b6e | 14 | ;; it under the terms of the GNU General Public License as published by |
267b82ff GM |
15 | ;; the Free Software Foundation, either version 3 of the License, or |
16 | ;; (at your option) any later version. | |
44198b6e CY |
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 | |
267b82ff | 24 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
44198b6e CY |
25 | |
26 | ;;; Commentary: | |
27 | ||
5c69cb2c CY |
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'. | |
44198b6e CY |
43 | |
44 | ;;; Code: | |
45 | ||
cced7584 CY |
46 | (require 'package) |
47 | (defvar gnus-article-buffer) | |
48 | ||
5c69cb2c CY |
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") | |
44198b6e | 60 | |
7fe42546 | 61 | (defvar package-update-news-on-upload nil |
5c69cb2c | 62 | "Whether uploading a package should also update NEWS and RSS feeds.") |
7fe42546 | 63 | |
44198b6e CY |
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 "&". | |
67 | (let ((index)) | |
68 | (while (setq index (string-match "[&]" string index)) | |
69 | (setq string (replace-match "&" t nil string)) | |
70 | (setq index (1+ index)))) | |
71 | (while (string-match "[<]" string) | |
72 | (setq string (replace-match "<" t nil string))) | |
73 | (while (string-match "[>]" string) | |
74 | (setq string (replace-match ">" t nil string))) | |
75 | (while (string-match "[']" string) | |
76 | (setq string (replace-match "'" t nil string))) | |
77 | (while (string-match "[\"]" string) | |
78 | (setq string (replace-match """ t nil string))) | |
79 | string) | |
80 | ||
063e5294 | 81 | (defun package--make-rss-entry (title text archive-url) |
44198b6e CY |
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. | |
063e5294 | 86 | "<link>" archive-url "news.html</link>\n" |
44198b6e CY |
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 | ||
5c69cb2c CY |
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)) | |
44198b6e CY |
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)) | |
5c69cb2c | 107 | (search-forward tag) |
44198b6e CY |
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 | ||
7fe42546 J |
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 | ||
5c69cb2c CY |
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))))))))) | |
7fe42546 | 146 | |
063e5294 | 147 | (defun package-maint-add-news-item (title description archive-url) |
5c69cb2c | 148 | "Add a news item to the webpages associated with the package archive. |
44198b6e | 149 | TITLE is the title of the news item. |
5c69cb2c | 150 | DESCRIPTION is the text of the news item." |
44198b6e | 151 | (interactive "sTitle: \nsText: ") |
5c69cb2c | 152 | (package--update-file "elpa.rss" |
44198b6e | 153 | "<description>" |
063e5294 | 154 | (package--make-rss-entry title description archive-url)) |
5c69cb2c | 155 | (package--update-file "news.html" |
44198b6e CY |
156 | "New entries go here" |
157 | (package--make-html-entry title description))) | |
158 | ||
063e5294 | 159 | (defun package--update-news (package version description archive-url) |
44198b6e CY |
160 | "Update the ELPA web pages when a package is uploaded." |
161 | (package-maint-add-news-item (concat package " version " version) | |
063e5294 CY |
162 | description |
163 | archive-url)) | |
44198b6e | 164 | |
063e5294 | 165 | (defun package-upload-buffer-internal (pkg-info extension &optional archive-url) |
44198b6e CY |
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 | |
063e5294 CY |
169 | \"el\" or \"tar\". |
170 | ||
5c69cb2c CY |
171 | The upload destination is given by `package-archive-upload-base'. |
172 | If its value is invalid, prompt for a directory. | |
7fe42546 | 173 | |
063e5294 | 174 | Optional arg ARCHIVE-URL is the URL of the destination archive. |
7fe42546 J |
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." | |
5c69cb2c CY |
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)) | |
b511b994 MA |
186 | (equal package-archive-upload-base |
187 | (car-safe | |
188 | (get 'package-archive-upload-base 'standard-value)))) | |
5c69cb2c CY |
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)))))))) | |
44198b6e CY |
269 | |
270 | (defun package-upload-buffer () | |
7fe42546 | 271 | "Upload the current buffer as a single-file Emacs Lisp package. |
5c69cb2c CY |
272 | If `package-archive-upload-base' does not specify a valid upload |
273 | destination, prompt for one." | |
44198b6e CY |
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) | |
7fe42546 J |
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\". | |
5c69cb2c CY |
286 | If `package-archive-upload-base' does not specify a valid upload |
287 | destination, prompt for one." | |
44198b6e CY |
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 | ||
b511b994 | 307 | ;;; package-x.el ends here |