Mercurial > hg > xemacs-beta

comparison lisp/url/url-news.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents
children
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; url-news.el,v --- News Uniform Resource Locator retrieval code
2 ;; Author: wmperry
3 ;; Created: 1996/05/29 15:48:29
4 ;; Version: 1.9
5 ;; Keywords: comm, data, processes
6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com)
9 ;;;
10 ;;; This file is not part of GNU Emacs, but the same permissions apply.
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 2, or (at your option)
15 ;;; 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; see the file COPYING. If not, write to
24 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26 (require 'url-vars)
27 (require 'url-parse)
28
29 (defun url-format-news ()
30 (url-clear-tmp-buffer)
31 (insert "HTTP/1.0 200 Retrieval OK\r\n"
32 (save-excursion
33 (set-buffer nntp-server-buffer)
34 (buffer-string)))
35 (url-parse-mime-headers)
36 (let* ((from (cdr (assoc "from" url-current-mime-headers)))
37 (qfrom (if from (url-insert-entities-in-string from) nil))
38 (subj (cdr (assoc "subject" url-current-mime-headers)))
39 (qsubj (if subj (url-insert-entities-in-string subj) nil))
40 (org (cdr (assoc "organization" url-current-mime-headers)))
41 (qorg (if org (url-insert-entities-in-string org) nil))
42 (typ (or (cdr (assoc "content-type" url-current-mime-headers))
43 "text/plain"))
44 (qgrps (mapcar 'car
45 (url-split
46 (url-insert-entities-in-string
47 (or (cdr (assoc "newsgroups"
48 url-current-mime-headers))
49 ""))
50 "[ \t\n,]+")))
51 (qrefs (delete ""
52 (mapcar
53 'url-insert-entities-in-string
54 (mapcar 'car
55 (url-split
56 (or (cdr (assoc "references"
57 url-current-mime-headers))
58 "")
59 "[ \t,\n<>]+")))))
60 (date (cdr (assoc "date" url-current-mime-headers))))
61 (setq url-current-file ""
62 url-current-type "")
63 (if (or (not (string-match "text/" typ))
64 (string-match "text/html" typ))
65 nil ; Let natural content-type take over
66 (insert "<html>\n"
67 " <head>\n"
68 " <title>" qsubj "</title>\n"
69 " <link rev=\"made\" href=\"mailto:" qfrom "\">\n"
70 " </head>\n"
71 " <body>\n"
72 " <div>\n"
73 " <h1 align=center>" qsubj "</h1>\n"
74 " <p role=\"headers\">\n"
75 " <b>From</b>: " qfrom "<br>\n"
76 " <b>Newsgroups</b>: "
77 (mapconcat
78 (function
79 (lambda (grp)
80 (concat "<a href=\"" grp "\">" grp "</a>"))) qgrps ", ")
81 "<br>\n"
82 (if org
83 (concat
84 " <b>Organization</b>: <i> " qorg "</i> <br>\n")
85 "")
86 " <b>Date</b>: <date> " date "</date> <br>\n"
87 " </p> <hr>\n"
88 (if (null qrefs)
89 ""
90 (concat
91 " <p>References\n"
92 " <ol>\n"
93 (mapconcat
94 (function
95 (lambda (ref)
96 (concat " <li> <a href=\"" ref "\"> "
97 ref "</a></li>\n")))
98 qrefs "")
99 " </ol>\n"
100 " </p>\n"
101 " <hr>\n"))
102 " <ul plain>\n"
103 " <li><a href=\"newspost:disfunctional\"> "
104 "Post to this group </a></li>\n"
105 " <li><a href=\"mailto:" qfrom "\"> Reply to " qfrom
106 "</a></li>\n"
107 " </ul>\n"
108 " <hr>"
109 " <pre>\n")
110 (let ((s (buffer-substring (point) (point-max))))
111 (delete-region (point) (point-max))
112 (insert (url-insert-entities-in-string s)))
113 (goto-char (point-max))
114 (setq url-current-mime-type "text/html"
115 url-current-mime-viewer (mm-mime-info url-current-mime-type nil 5))
116 (let ((x (assoc "content-type" url-current-mime-headers)))
117 (if x
118 (setcdr x "text/html")
119 (setq url-current-mime-headers (cons (cons "content-type"
120 "text/html")
121 url-current-mime-headers))))
122 (insert "\n"
123 " </pre>\n"
124 " </div>\n"
125 " </body>\n"
126 "</html>\n"
127 "<!-- Automatically generated by URL/" url-version
128 "-->"))))
129
130 (defun url-check-gnus-version ()
131 (require 'nntp)
132 (condition-case ()
133 (require 'gnus)
134 (error (setq gnus-version "GNUS not found")))
135 (if (or (not (boundp 'gnus-version))
136 (string-match "v5.[.0-9]+$" gnus-version)
137 (string-match "September" gnus-version))
138 nil
139 (url-warn 'url (concat
140 "The version of GNUS found on this system is too old and does\n"
141 "not support the necessary functionality for the URL package.\n"
142 "Please upgrade to version 5.x of GNUS. This is bundled by\n"
143 "default with Emacs 19.30 and XEmacs 19.14 and later.\n\n"
144 "This version of GNUS is: " gnus-version "\n"))
145 (fset 'url-news 'url-news-version-too-old))
146 (fset 'url-check-gnus-version 'ignore))
147
148 (defun url-news-version-too-old (article)
149 (set-buffer (get-buffer-create url-working-buffer))
150 (setq url-current-mime-headers '(("content-type" . "text/html"))
151 url-current-mime-type "text/html")
152 (insert "<html>\n"
153 " <head>\n"
154 " <title>News Error</title>\n"
155 " </head>\n"
156 " <body>\n"
157 " <h1>News Error - too old</h1>\n"
158 " <p>\n"
159 " The version of GNUS found on this system is too old and does\n"
160 " not support the necessary functionality for the URL package.\n"
161 " Please upgrade to version 5.x of GNUS. This is bundled by\n"
162 " default with Emacs 19.30 and XEmacs 19.14 and later.\n\n"
163 " This version of GNUS is: " gnus-version "\n"
164 " </p>\n"
165 " </body>\n"
166 "</html>\n"))
167
168 (defun url-news-open-host (host port user pass)
169 (if (fboundp 'nnheader-init-server-buffer)
170 (nnheader-init-server-buffer))
171 (nntp-open-server host (list (string-to-int port)))
172 (if (and user pass)
173 (progn
174 (nntp-send-command "^.*\r?\n" "AUTHINFO USER" user)
175 (nntp-send-command "^.*\r?\n" "AUTHINFO PASS" pass)
176 (if (not (nntp-server-opened host))
177 (url-warn 'url (format "NNTP authentication to `%s' as `%s' failed"
178 host user))))))
179
180 (defun url-news-fetch-article-number (newsgroup article)
181 (nntp-request-group newsgroup)
182 (nntp-request-article article))
183
184 (defun url-news-fetch-message-id (host port message-id)
185 (if (eq ?> (aref article (1- (length article))))
186 nil
187 (setq message-id (concat "<" message-id ">")))
188 (if (nntp-request-article message-id)
189 (url-format-news)
190 (set-buffer (get-buffer-create url-working-buffer))
191 (setq url-current-can-be-cached nil)
192 (insert "<html>\n"
193 " <head>\n"
194 " <title>Error</title>\n"
195 " </head>\n"
196 " <body>\n"
197 " <div>\n"
198 " <h1>Error requesting article...</h1>\n"
199 " <p>\n"
200 " The status message returned by the NNTP server was:"
201 "<br><hr>\n"
202 " <xmp>\n"
203 (nntp-status-message)
204 " </xmp>\n"
205 " </p>\n"
206 " <p>\n"
207 " If you If you feel this is an error, <a href=\""
208 "mailto:" url-bug-address "\">send me mail</a>\n"
209 " </p>\n"
210 " </div>\n"
211 " </body>\n"
212 "</html>\n"
213 "<!-- Automatically generated by URL v" url-version " -->\n"
214 )))
215
216 (defun url-news-fetch-newsgroup (newsgroup)
217 (if (string-match "^/+" newsgroup)
218 (setq newsgroup (substring newsgroup (match-end 0))))
219 (if (string-match "/+$" newsgroup)
220 (setq newsgroup (substring newsgroup 0 (match-beginning 0))))
221
222 ;; This saves a bogus 'Untitled' buffer by Emacs-W3
223 (kill-buffer url-working-buffer)
224
225 ;; This saves us from checking new news if GNUS is already running
226 (if (or (not (get-buffer gnus-group-buffer))
227 (save-excursion
228 (set-buffer gnus-group-buffer)
229 (not (eq major-mode 'gnus-group-mode))))
230 (gnus))
231 (set-buffer gnus-group-buffer)
232 (goto-char (point-min))
233 (gnus-group-read-ephemeral-group newsgroup (list 'nntp host)
234 nil
235 (cons (current-buffer) 'browse)))
236
237 (defun url-news (article)
238 ;; Find a news reference
239 (url-check-gnus-version)
240 (let* ((urlobj (url-generic-parse-url article))
241 (host (or (url-host urlobj) url-news-server))
242 (port (or (url-port urlobj)
243 (cdr-safe (assoc "news" url-default-ports))))
244 (article-brackets nil)
245 (article (url-filename urlobj)))
246 (url-news-open-host host port (url-user urlobj) (url-password urlobj))
247 (cond
248 ((string-match "@" article) ; Its a specific article
249 (url-news-fetch-message-id host port article))
250 ((string= article "") ; List all newsgroups
251 (gnus)
252 (kill-buffer url-working-buffer))
253 (t ; Whole newsgroup
254 (url-news-fetch-newsgroup article)))
255 (setq url-current-type "news"
256 url-current-server host
257 url-current-user (url-user urlobj)
258 url-current-port port
259 url-current-file article)))
260
261 (defun url-nntp (url)
262 ;; Find a news reference
263 (url-check-gnus-version)
264 (let* ((urlobj (url-generic-parse-url url))
265 (host (or (url-host urlobj) url-news-server))
266 (port (or (url-port urlobj)
267 (cdr-safe (assoc "nntp" url-default-ports))))
268 (article-brackets nil)
269 (article (url-filename urlobj)))
270 (url-news-open-host host port (url-user urlobj) (url-password urlobj))
271 (cond
272 ((string-match "@" article) ; Its a specific article
273 (url-news-fetch-message-id host port article))
274 ((string-match "/\\([0-9]+\\)$" article)
275 (url-news-fetch-article-number (substring article 0
276 (match-beginning 0))
277 (match-string 1 article)))
278
279 ((string= article "") ; List all newsgroups
280 (gnus)
281 (kill-buffer url-working-buffer))
282 (t ; Whole newsgroup
283 (url-news-fetch-newsgroup article)))
284 (setq url-current-type "news"
285 url-current-server host
286 url-current-user (url-user urlobj)
287 url-current-port port
288 url-current-file article)))
289
290 (provide 'url-news)