Commit | Line | Data |
---|---|---|
44198b6e CY |
1 | ;;; package-x.el --- Package extras |
2 | ||
73b0cd50 | 3 | ;; Copyright (C) 2007-2011 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 | ||
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 | ||
cced7584 CY |
35 | (require 'package) |
36 | (defvar gnus-article-buffer) | |
37 | ||
44198b6e CY |
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 "&". | |
46 | (let ((index)) | |
47 | (while (setq index (string-match "[&]" string index)) | |
48 | (setq string (replace-match "&" t nil string)) | |
49 | (setq index (1+ index)))) | |
50 | (while (string-match "[<]" string) | |
51 | (setq string (replace-match "<" t nil string))) | |
52 | (while (string-match "[>]" string) | |
53 | (setq string (replace-match ">" t nil string))) | |
54 | (while (string-match "[']" string) | |
55 | (setq string (replace-match "'" t nil string))) | |
56 | (while (string-match "[\"]" string) | |
57 | (setq string (replace-match """ t nil string))) | |
58 | string) | |
59 | ||
063e5294 | 60 | (defun package--make-rss-entry (title text archive-url) |
44198b6e CY |
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. | |
063e5294 | 65 | "<link>" archive-url "news.html</link>\n" |
44198b6e CY |
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 | ||
063e5294 | 89 | (defun package-maint-add-news-item (title description archive-url) |
44198b6e CY |
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>" | |
063e5294 | 97 | (package--make-rss-entry title description archive-url)) |
44198b6e CY |
98 | (package--update-file (concat package-archive-upload-base "news.html") |
99 | "New entries go here" | |
100 | (package--make-html-entry title description))) | |
101 | ||
063e5294 | 102 | (defun package--update-news (package version description archive-url) |
44198b6e CY |
103 | "Update the ELPA web pages when a package is uploaded." |
104 | (package-maint-add-news-item (concat package " version " version) | |
063e5294 CY |
105 | description |
106 | archive-url)) | |
44198b6e | 107 | |
063e5294 | 108 | (defun package-upload-buffer-internal (pkg-info extension &optional archive-url) |
44198b6e CY |
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 | |
063e5294 CY |
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"))) | |
44198b6e CY |
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)) | |
148cef8e | 133 | (split-version (version-to-list pkg-version)) |
44198b6e CY |
134 | (pkg-buffer (current-buffer)) |
135 | ||
136 | ;; Download latest archive-contents. | |
137 | (buffer (url-retrieve-synchronously | |
063e5294 | 138 | (concat archive-url "archive-contents")))) |
44198b6e CY |
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 | |
148cef8e CY |
154 | (if (version-list-<= split-version |
155 | (package-desc-vers (cdr elt))) | |
44198b6e CY |
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) | |
063e5294 | 188 | pkg-version desc archive-url) |
44198b6e CY |
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 |