Mercurial > hg > xemacs-beta

comparison lisp/w3/url-news.el @ 80:1ce6082ce73f r20-0b90

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