Mercurial > emacs
comparison lisp/url/url-news.el @ 54695:3fb37923e567
Initial revision
| author | Stefan Monnier <monnier@iro.umontreal.ca> |
|---|---|
| date | Sun, 04 Apr 2004 01:21:46 +0000 |
| parents | |
| children | 7784ae10206d |
comparison
equal
deleted
inserted
replaced
| 54694:253149f265f2 | 54695:3fb37923e567 |
|---|---|
| 1 ;;; url-news.el --- News Uniform Resource Locator retrieval code | |
| 2 ;; Author: $Author: fx $ | |
| 3 ;; Created: $Date: 2001/05/22 16:13:00 $ | |
| 4 ;; Version: $Revision: 1.3 $ | |
| 5 ;; Keywords: comm, data, processes | |
| 6 | |
| 7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 8 ;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu> | |
| 9 ;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc. | |
| 10 ;;; | |
| 11 ;;; This file is part of GNU Emacs. | |
| 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-util) | |
| 30 (require 'url-parse) | |
| 31 (require 'nntp) | |
| 32 (autoload 'url-warn "url") | |
| 33 (autoload 'gnus-group-read-ephemeral-group "gnus-group") | |
| 34 (eval-when-compile (require 'cl)) | |
| 35 | |
| 36 (defgroup url-news nil | |
| 37 "News related options" | |
| 38 :group 'url) | |
| 39 | |
| 40 (defun url-news-open-host (host port user pass) | |
| 41 (if (fboundp 'nnheader-init-server-buffer) | |
| 42 (nnheader-init-server-buffer)) | |
| 43 (nntp-open-server host (list (string-to-int port))) | |
| 44 (if (and user pass) | |
| 45 (progn | |
| 46 (nntp-send-command "^.*\r?\n" "AUTHINFO USER" user) | |
| 47 (nntp-send-command "^.*\r?\n" "AUTHINFO PASS" pass) | |
| 48 (if (not (nntp-server-opened host)) | |
| 49 (url-warn 'url (format "NNTP authentication to `%s' as `%s' failed" | |
| 50 host user)))))) | |
| 51 | |
| 52 (defun url-news-fetch-message-id (host message-id) | |
| 53 (let ((buf (generate-new-buffer " *url-news*"))) | |
| 54 (if (eq ?> (aref message-id (1- (length message-id)))) | |
| 55 nil | |
| 56 (setq message-id (concat "<" message-id ">"))) | |
| 57 (if (cdr-safe (nntp-request-article message-id nil host buf)) | |
| 58 ;; Successfully retrieved the article | |
| 59 nil | |
| 60 (save-excursion | |
| 61 (set-buffer buf) | |
| 62 (insert "Content-type: text/html\n\n" | |
| 63 "<html>\n" | |
| 64 " <head>\n" | |
| 65 " <title>Error</title>\n" | |
| 66 " </head>\n" | |
| 67 " <body>\n" | |
| 68 " <div>\n" | |
| 69 " <h1>Error requesting article...</h1>\n" | |
| 70 " <p>\n" | |
| 71 " The status message returned by the NNTP server was:" | |
| 72 "<br><hr>\n" | |
| 73 " <xmp>\n" | |
| 74 (nntp-status-message) | |
| 75 " </xmp>\n" | |
| 76 " </p>\n" | |
| 77 " <p>\n" | |
| 78 " If you If you feel this is an error, <a href=\"" | |
| 79 "mailto:" url-bug-address "\">send me mail</a>\n" | |
| 80 " </p>\n" | |
| 81 " </div>\n" | |
| 82 " </body>\n" | |
| 83 "</html>\n" | |
| 84 "<!-- Automatically generated by URL v" url-version " -->\n" | |
| 85 ))) | |
| 86 buf)) | |
| 87 | |
| 88 (defun url-news-fetch-newsgroup (newsgroup host) | |
| 89 (declare (special gnus-group-buffer)) | |
| 90 (if (string-match "^/+" newsgroup) | |
| 91 (setq newsgroup (substring newsgroup (match-end 0)))) | |
| 92 (if (string-match "/+$" newsgroup) | |
| 93 (setq newsgroup (substring newsgroup 0 (match-beginning 0)))) | |
| 94 | |
| 95 ;; This saves us from checking new news if GNUS is already running | |
| 96 ;; FIXME - is it relatively safe to use gnus-alive-p here? FIXME | |
| 97 (if (or (not (get-buffer gnus-group-buffer)) | |
| 98 (save-excursion | |
| 99 (set-buffer gnus-group-buffer) | |
| 100 (not (eq major-mode 'gnus-group-mode)))) | |
| 101 (gnus)) | |
| 102 (set-buffer gnus-group-buffer) | |
| 103 (goto-char (point-min)) | |
| 104 (gnus-group-read-ephemeral-group newsgroup | |
| 105 (list 'nntp host | |
| 106 'nntp-open-connection-function | |
| 107 nntp-open-connection-function) | |
| 108 nil | |
| 109 (cons (current-buffer) 'browse))) | |
| 110 | |
| 111 ;;;###autoload | |
| 112 (defun url-news (url) | |
| 113 ;; Find a news reference | |
| 114 (let* ((host (or (url-host url) url-news-server)) | |
| 115 (port (url-port url)) | |
| 116 (article-brackets nil) | |
| 117 (buf nil) | |
| 118 (article (url-filename url))) | |
| 119 (url-news-open-host host port (url-user url) (url-password url)) | |
| 120 (setq article (url-unhex-string article)) | |
| 121 (cond | |
| 122 ((string-match "@" article) ; Its a specific article | |
| 123 (setq buf (url-news-fetch-message-id host article))) | |
| 124 ((string= article "") ; List all newsgroups | |
| 125 (gnus)) | |
| 126 (t ; Whole newsgroup | |
| 127 (url-news-fetch-newsgroup article host))) | |
| 128 buf)) | |
| 129 | |
| 130 ;;;###autoload | |
| 131 (defun url-snews (url) | |
| 132 (let ((nntp-open-connection-function 'nntp-open-ssl-stream)) | |
| 133 (url-news url))) | |
| 134 | |
| 135 (provide 'url-news) |