Mercurial > hg > xemacs-beta

comparison lisp/url/url-news.el @ 2:ac2d302a0011 r19-15b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b2
author cvs
date Mon, 13 Aug 2007 08:46:35 +0200
parents 376386a54a3c
children
comparison
equal deleted inserted replaced
1:c0c6a60d29db 2:ac2d302a0011
31 (insert "HTTP/1.0 200 Retrieval OK\r\n" 31 (insert "HTTP/1.0 200 Retrieval OK\r\n"
32 (save-excursion 32 (save-excursion
33 (set-buffer nntp-server-buffer) 33 (set-buffer nntp-server-buffer)
34 (buffer-string))) 34 (buffer-string)))
35 (url-parse-mime-headers) 35 (url-parse-mime-headers)
36 (let ((from (cdr (assoc "from" url-current-mime-headers))) 36 (let* ((from (cdr (assoc "from" url-current-mime-headers)))
37 (subj (cdr (assoc "subject" url-current-mime-headers))) 37 (qfrom (if from (url-insert-entities-in-string from) nil))
38 (org (cdr (assoc "organization" url-current-mime-headers))) 38 (subj (cdr (assoc "subject" url-current-mime-headers)))
39 (typ (or (cdr (assoc "content-type" url-current-mime-headers)) 39 (qsubj (if subj (url-insert-entities-in-string subj) nil))
40 "text/plain")) 40 (org (cdr (assoc "organization" url-current-mime-headers)))
41 (grps (mapcar 'car 41 (qorg (if org (url-insert-entities-in-string org) nil))
42 (url-split 42 (typ (or (cdr (assoc "content-type" url-current-mime-headers))
43 (or (cdr (assoc "newsgroups" url-current-mime-headers)) 43 "text/plain"))
44 "") 44 (qgrps (mapcar 'car
45 "[ \t\n,]+"))) 45 (url-split
46 (refs (mapcar 'car 46 (url-insert-entities-in-string
47 (url-split 47 (or (cdr (assoc "newsgroups"
48 (or (cdr (assoc "references" url-current-mime-headers)) 48 url-current-mime-headers))
49 "") 49 ""))
50 "[ \t,\n<>]+"))) 50 "[ \t\n,]+")))
51 (date (cdr (assoc "date" url-current-mime-headers)))) 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))))
52 (setq url-current-file "" 61 (setq url-current-file ""
53 url-current-type "") 62 url-current-type "")
54 (if (or (not (string-match "text/" typ)) 63 (if (or (not (string-match "text/" typ))
55 (string-match "text/html" typ)) 64 (string-match "text/html" typ))
56 nil ; Let natural content-type take over 65 nil ; Let natural content-type take over
57 (insert "<html>\n" 66 (insert "<html>\n"
58 " <head>\n" 67 " <head>\n"
59 " <title>" subj "</title>\n" 68 " <title>" qsubj "</title>\n"
60 " <link rev=\"made\" href=\"mailto:" from "\">\n" 69 " <link rev=\"made\" href=\"mailto:" qfrom "\">\n"
61 " </head>\n" 70 " </head>\n"
62 " <body>\n" 71 " <body>\n"
63 " <div>\n" 72 " <div>\n"
64 " <h1 align=center>" subj "</h1>\n" 73 " <h1 align=center>" qsubj "</h1>\n"
65 " <p role=\"headers\">\n" 74 " <p role=\"headers\">\n"
66 " <b>From</b>: <address> " from "</address><br>\n" 75 " <b>From</b>: " qfrom "<br>\n"
67 " <b>Newsgroups</b>: " 76 " <b>Newsgroups</b>: "
68 (mapconcat 77 (mapconcat
69 (function 78 (function
70 (lambda (grp) 79 (lambda (grp)
71 (concat "<a href=\"" grp "\"> " grp "</a>"))) grps ", ") 80 (concat "<a href=\"" grp "\">" grp "</a>"))) qgrps ", ")
72 "<br>\n" 81 "<br>\n"
73 (if org 82 (if org
74 (concat 83 (concat
75 " <b>Organization</b>: <i> " org "</i> <br>\n") 84 " <b>Organization</b>: <i> " qorg "</i> <br>\n")
76 "") 85 "")
77 " <b>Date</b>: <date> " date "</date> <br>\n" 86 " <b>Date</b>: <date> " date "</date> <br>\n"
78 " </p> <hr>\n" 87 " </p> <hr>\n"
79 (if (null refs) 88 (if (null qrefs)
80 "" 89 ""
81 (concat 90 (concat
82 " <p>References\n" 91 " <p>References\n"
83 " <ol>\n" 92 " <ol>\n"
84 (mapconcat 93 (mapconcat
85 (function 94 (function
86 (lambda (ref) 95 (lambda (ref)
87 (concat " <li> <a href=\"" ref "\"> " 96 (concat " <li> <a href=\"" ref "\"> "
88 ref "</a></li>\n"))) 97 ref "</a></li>\n")))
89 refs "") 98 qrefs "")
90 " </ol>\n" 99 " </ol>\n"
91 " </p>\n" 100 " </p>\n"
92 " <hr>\n")) 101 " <hr>\n"))
93 " <ul plain>\n" 102 " <ul plain>\n"
94 " <li><a href=\"newspost:disfunctional\"> " 103 " <li><a href=\"newspost:disfunctional\"> "
95 "Post to this group </a></li>\n" 104 "Post to this group </a></li>\n"
96 " <li><a href=\"mailto:" from "\"> Reply to " from 105 " <li><a href=\"mailto:" qfrom "\"> Reply to " qfrom
97 "</a></li>\n" 106 "</a></li>\n"
98 " </ul>\n" 107 " </ul>\n"
99 " <hr>" 108 " <hr>"
100 " <xmp>\n") 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)))
101 (goto-char (point-max)) 113 (goto-char (point-max))
102 (setq url-current-mime-type "text/html" 114 (setq url-current-mime-type "text/html"
103 url-current-mime-viewer (mm-mime-info url-current-mime-type nil 5)) 115 url-current-mime-viewer (mm-mime-info url-current-mime-type nil 5))
104 (let ((x (assoc "content-type" url-current-mime-headers))) 116 (let ((x (assoc "content-type" url-current-mime-headers)))
105 (if x 117 (if x
106 (setcdr x "text/html") 118 (setcdr x "text/html")
107 (setq url-current-mime-headers (cons (cons "content-type" 119 (setq url-current-mime-headers (cons (cons "content-type"
108 "text/html") 120 "text/html")
109 url-current-mime-headers)))) 121 url-current-mime-headers))))
110 (insert "\n" 122 (insert "\n"
111 " </xmp>\n" 123 " </pre>\n"
112 " </div>\n" 124 " </div>\n"
113 " </body>\n" 125 " </body>\n"
114 "</html>\n" 126 "</html>\n"
115 "<!-- Automatically generated by URL/" url-version 127 "<!-- Automatically generated by URL/" url-version
116 "-->")))) 128 "-->"))))
152 " </p>\n" 164 " </p>\n"
153 " </body>\n" 165 " </body>\n"
154 "</html>\n")) 166 "</html>\n"))
155 167
156 (defun url-news-open-host (host port user pass) 168 (defun url-news-open-host (host port user pass)
169 (if (fboundp 'nnheader-init-server-buffer)
170 (nnheader-init-server-buffer))
157 (nntp-open-server host (list (string-to-int port))) 171 (nntp-open-server host (list (string-to-int port)))
158 (if (and user pass) 172 (if (and user pass)
159 (progn 173 (progn
160 (nntp-send-command "^.*\r?\n" "AUTHINFO USER" user) 174 (nntp-send-command "^.*\r?\n" "AUTHINFO USER" user)
161 (nntp-send-command "^.*\r?\n" "AUTHINFO PASS" pass) 175 (nntp-send-command "^.*\r?\n" "AUTHINFO PASS" pass)
230 (article-brackets nil) 244 (article-brackets nil)
231 (article (url-filename urlobj))) 245 (article (url-filename urlobj)))
232 (url-news-open-host host port (url-user urlobj) (url-password urlobj)) 246 (url-news-open-host host port (url-user urlobj) (url-password urlobj))
233 (cond 247 (cond
234 ((string-match "@" article) ; Its a specific article 248 ((string-match "@" article) ; Its a specific article
235 (url-news-fetch-message-id article)) 249 (url-news-fetch-message-id host port article))
236 ((string= article "") ; List all newsgroups 250 ((string= article "") ; List all newsgroups
237 (gnus) 251 (gnus)
238 (kill-buffer url-working-buffer)) 252 (kill-buffer url-working-buffer))
239 (t ; Whole newsgroup 253 (t ; Whole newsgroup
240 (url-news-fetch-newsgroup article))) 254 (url-news-fetch-newsgroup article)))
254 (article-brackets nil) 268 (article-brackets nil)
255 (article (url-filename urlobj))) 269 (article (url-filename urlobj)))
256 (url-news-open-host host port (url-user urlobj) (url-password urlobj)) 270 (url-news-open-host host port (url-user urlobj) (url-password urlobj))
257 (cond 271 (cond
258 ((string-match "@" article) ; Its a specific article 272 ((string-match "@" article) ; Its a specific article
259 (url-news-fetch-message-id article)) 273 (url-news-fetch-message-id host port article))
260 ((string-match "/\\([0-9]+\\)$" article) 274 ((string-match "/\\([0-9]+\\)$" article)
261 (url-news-fetch-article-number (substring article 0 275 (url-news-fetch-article-number (substring article 0
262 (match-beginning 0)) 276 (match-beginning 0))
263 (match-string 1 article))) 277 (match-string 1 article)))
264 278