Mercurial > hg > xemacs-beta

comparison lisp/url/url-news.el @ 0:376386a54a3c r19-14

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