Mercurial > hg > xemacs-beta

comparison lisp/w3/url-news.el @ 173:8eaf7971accc r20-3b13

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b13
author cvs
date Mon, 13 Aug 2007 09:49:09 +0200
parents 441bb1e64a06
children
comparison
equal deleted inserted replaced
172:a38aed19690b 173:8eaf7971accc
1 ;;; url-news.el --- News Uniform Resource Locator retrieval code 1 ;;; url-news.el --- News Uniform Resource Locator retrieval code
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1997/02/18 23:35:11 3 ;; Created: 1997/07/05 22:54:24
4 ;; Version: 1.7 4 ;; Version: 1.8
5 ;; Keywords: comm, data, processes 5 ;; Keywords: comm, data, processes
6 6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu) 8 ;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu)
9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc. 9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
26 ;;; Boston, MA 02111-1307, USA. 26 ;;; Boston, MA 02111-1307, USA.
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28 (require 'url-vars) 28 (require 'url-vars)
29 (require 'url-parse) 29 (require 'url-parse)
30 30
31 (defgroup url-news nil
32 "News related options"
33 :group 'url)
34
35 (defcustom url-news-use-article-mode nil
36 "*Whether to use Gnus' article mode for displaying news articles."
37 :type 'boolean
38 :group 'url-news)
39
31 (defun url-format-news () 40 (defun url-format-news ()
32 (url-clear-tmp-buffer) 41 (url-clear-tmp-buffer)
33 (insert "HTTP/1.0 200 Retrieval OK\r\n" 42 (insert "HTTP/1.0 200 Retrieval OK\r\n"
34 (save-excursion 43 (save-excursion
35 (set-buffer nntp-server-buffer) 44 (set-buffer nntp-server-buffer)
41 (qsubj (if subj (url-insert-entities-in-string subj) nil)) 50 (qsubj (if subj (url-insert-entities-in-string subj) nil))
42 (org (cdr (assoc "organization" url-current-mime-headers))) 51 (org (cdr (assoc "organization" url-current-mime-headers)))
43 (qorg (if org (url-insert-entities-in-string org) nil)) 52 (qorg (if org (url-insert-entities-in-string org) nil))
44 (typ (or (cdr (assoc "content-type" url-current-mime-headers)) 53 (typ (or (cdr (assoc "content-type" url-current-mime-headers))
45 "text/plain")) 54 "text/plain"))
55 (inhibit-read-only t)
46 (qgrps (mapcar 'car 56 (qgrps (mapcar 'car
47 (url-split 57 (url-split
48 (url-insert-entities-in-string 58 (url-insert-entities-in-string
49 (or (cdr (assoc "newsgroups" 59 (or (cdr (assoc "newsgroups"
50 url-current-mime-headers)) 60 url-current-mime-headers))
61 "[ \t,\n<>]+"))))) 71 "[ \t,\n<>]+")))))
62 (date (cdr (assoc "date" url-current-mime-headers)))) 72 (date (cdr (assoc "date" url-current-mime-headers))))
63 (if (or (not (string-match "text/" typ)) 73 (if (or (not (string-match "text/" typ))
64 (string-match "text/html" typ)) 74 (string-match "text/html" typ))
65 nil ; Let natural content-type take over 75 nil ; Let natural content-type take over
66 (insert "<html>\n" 76 (if (and (fboundp 'gnus-article-mode)
67 " <head>\n" 77 url-news-use-article-mode)
68 " <title>" qsubj "</title>\n" 78 (progn
69 " <link rev=\"made\" href=\"mailto:" qfrom "\">\n" 79 (kill-buffer (current-buffer))
70 " </head>\n" 80 (set-buffer (get-buffer-create "Emacs/W3 News"))
71 " <body>\n" 81 (erase-buffer)
72 " <div>\n" 82 (insert
73 " <h1 align=center>" qsubj "</h1>\n" 83 (save-excursion
74 " <p role=\"headers\">\n" 84 (set-buffer nntp-server-buffer)
75 " <b>From</b>: " qfrom "<br>\n" 85 (save-restriction
76 " <b>Newsgroups</b>: " 86 (widen)
77 (mapconcat 87 (buffer-string))))
78 (function 88 (gnus-article-mode)
79 (lambda (grp) 89 (article-hide-headers 1)
80 (concat "<a href=\"" grp "\">" grp "</a>"))) qgrps ", ") 90 (goto-char (point-min))
81 "<br>\n" 91 (display-buffer (current-buffer)))
82 (if org 92 (insert "<html>\n"
83 (concat 93 " <head>\n"
84 " <b>Organization</b>: <i> " qorg "</i> <br>\n") 94 " <title>" qsubj "</title>\n"
85 "") 95 " <link rev=\"made\" href=\"mailto:" qfrom "\">\n"
86 " <b>Date</b>: <date> " date "</date> <br>\n" 96 " </head>\n"
87 " </p> <hr>\n" 97 " <body>\n"
88 (if (null qrefs) 98 " <div>\n"
89 "" 99 " <h1 align=center>" qsubj "</h1>\n"
90 (concat 100 " <p role=\"headers\">\n"
91 " <p>References\n" 101 " <b>From</b>: " qfrom "<br>\n"
92 " <ol>\n" 102 " <b>Newsgroups</b>: "
93 (mapconcat 103 (mapconcat
94 (function 104 (function
95 (lambda (ref) 105 (lambda (grp)
96 (concat " <li> <a href=\"" ref "\"> " 106 (concat "<a href=\"" grp "\">" grp "</a>"))) qgrps ", ")
97 ref "</a></li>\n"))) 107 "<br>\n"
98 qrefs "") 108 (if org
99 " </ol>\n" 109 (concat
100 " </p>\n" 110 " <b>Organization</b>: <i> " qorg "</i> <br>\n")
101 " <hr>\n")) 111 "")
102 " <ul plain>\n" 112 " <b>Date</b>: <date> " date "</date> <br>\n"
103 " <li><a href=\"newspost:disfunctional\"> " 113 " </p> <hr>\n"
104 "Post to this group </a></li>\n" 114 (if (null qrefs)
105 " <li><a href=\"mailto:" qfrom "\"> Reply to " qfrom 115 ""
106 "</a></li>\n" 116 (concat
107 " </ul>\n" 117 " <p>References\n"
108 " <hr>" 118 " <ol>\n"
109 " <pre>\n") 119 (mapconcat
110 (let ((s (buffer-substring (point) (point-max)))) 120 (function
111 (delete-region (point) (point-max)) 121 (lambda (ref)
112 (insert (url-insert-entities-in-string s))) 122 (concat " <li> <a href=\"" ref "\"> "
113 (goto-char (point-max)) 123 ref "</a></li>\n")))
114 (setq url-current-mime-type "text/html" 124 qrefs "")
115 url-current-mime-viewer (mm-mime-info url-current-mime-type nil 5)) 125 " </ol>\n"
116 (let ((x (assoc "content-type" url-current-mime-headers))) 126 " </p>\n"
117 (if x 127 " <hr>\n"))
118 (setcdr x "text/html") 128 " <ul plain>\n"
119 (setq url-current-mime-headers (cons (cons "content-type" 129 " <li><a href=\"newspost:disfunctional\"> "
120 "text/html") 130 "Post to this group </a></li>\n"
121 url-current-mime-headers)))) 131 " <li><a href=\"mailto:" qfrom "\"> Reply to " qfrom
122 (insert "\n" 132 "</a></li>\n"
123 " </pre>\n" 133 " </ul>\n"
124 " </div>\n" 134 " <hr>"
125 " </body>\n" 135 " <pre>\n")
126 "</html>\n" 136 (let ((s (buffer-substring (point) (point-max))))
127 "<!-- Automatically generated by URL/" url-version 137 (delete-region (point) (point-max))
128 "-->")))) 138 (insert (url-insert-entities-in-string s)))
139 (goto-char (point-max))
140 (setq url-current-mime-type "text/html"
141 url-current-mime-viewer (mm-mime-info url-current-mime-type nil 5))
142 (let ((x (assoc "content-type" url-current-mime-headers)))
143 (if x
144 (setcdr x "text/html")
145 (setq url-current-mime-headers (cons (cons "content-type"
146 "text/html")
147 url-current-mime-headers))))
148 (insert "\n"
149 " </pre>\n"
150 " </div>\n"
151 " </body>\n"
152 "</html>\n"
153 "<!-- Automatically generated by URL/" url-version
154 "-->")))))
129 155
130 (defun url-check-gnus-version () 156 (defun url-check-gnus-version ()
131 (require 'nntp) 157 (require 'nntp)
132 (condition-case () 158 (condition-case ()
133 (require 'gnus) 159 (require 'gnus)