Mercurial > emacs
diff 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 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-news.el Sun Apr 04 01:21:46 2004 +0000 @@ -0,0 +1,135 @@ +;;; url-news.el --- News Uniform Resource Locator retrieval code +;; Author: $Author: fx $ +;; Created: $Date: 2001/05/22 16:13:00 $ +;; Version: $Revision: 1.3 $ +;; Keywords: comm, data, processes + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu> +;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc. +;;; +;;; This file is part of GNU Emacs. +;;; +;;; GNU Emacs is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2, or (at your option) +;;; any later version. +;;; +;;; GNU Emacs is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Emacs; see the file COPYING. If not, write to the +;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;;; Boston, MA 02111-1307, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(require 'url-vars) +(require 'url-util) +(require 'url-parse) +(require 'nntp) +(autoload 'url-warn "url") +(autoload 'gnus-group-read-ephemeral-group "gnus-group") +(eval-when-compile (require 'cl)) + +(defgroup url-news nil + "News related options" + :group 'url) + +(defun url-news-open-host (host port user pass) + (if (fboundp 'nnheader-init-server-buffer) + (nnheader-init-server-buffer)) + (nntp-open-server host (list (string-to-int port))) + (if (and user pass) + (progn + (nntp-send-command "^.*\r?\n" "AUTHINFO USER" user) + (nntp-send-command "^.*\r?\n" "AUTHINFO PASS" pass) + (if (not (nntp-server-opened host)) + (url-warn 'url (format "NNTP authentication to `%s' as `%s' failed" + host user)))))) + +(defun url-news-fetch-message-id (host message-id) + (let ((buf (generate-new-buffer " *url-news*"))) + (if (eq ?> (aref message-id (1- (length message-id)))) + nil + (setq message-id (concat "<" message-id ">"))) + (if (cdr-safe (nntp-request-article message-id nil host buf)) + ;; Successfully retrieved the article + nil + (save-excursion + (set-buffer buf) + (insert "Content-type: text/html\n\n" + "<html>\n" + " <head>\n" + " <title>Error</title>\n" + " </head>\n" + " <body>\n" + " <div>\n" + " <h1>Error requesting article...</h1>\n" + " <p>\n" + " The status message returned by the NNTP server was:" + "<br><hr>\n" + " <xmp>\n" + (nntp-status-message) + " </xmp>\n" + " </p>\n" + " <p>\n" + " If you If you feel this is an error, <a href=\"" + "mailto:" url-bug-address "\">send me mail</a>\n" + " </p>\n" + " </div>\n" + " </body>\n" + "</html>\n" + "<!-- Automatically generated by URL v" url-version " -->\n" + ))) + buf)) + +(defun url-news-fetch-newsgroup (newsgroup host) + (declare (special gnus-group-buffer)) + (if (string-match "^/+" newsgroup) + (setq newsgroup (substring newsgroup (match-end 0)))) + (if (string-match "/+$" newsgroup) + (setq newsgroup (substring newsgroup 0 (match-beginning 0)))) + + ;; This saves us from checking new news if GNUS is already running + ;; FIXME - is it relatively safe to use gnus-alive-p here? FIXME + (if (or (not (get-buffer gnus-group-buffer)) + (save-excursion + (set-buffer gnus-group-buffer) + (not (eq major-mode 'gnus-group-mode)))) + (gnus)) + (set-buffer gnus-group-buffer) + (goto-char (point-min)) + (gnus-group-read-ephemeral-group newsgroup + (list 'nntp host + 'nntp-open-connection-function + nntp-open-connection-function) + nil + (cons (current-buffer) 'browse))) + +;;;###autoload +(defun url-news (url) + ;; Find a news reference + (let* ((host (or (url-host url) url-news-server)) + (port (url-port url)) + (article-brackets nil) + (buf nil) + (article (url-filename url))) + (url-news-open-host host port (url-user url) (url-password url)) + (setq article (url-unhex-string article)) + (cond + ((string-match "@" article) ; Its a specific article + (setq buf (url-news-fetch-message-id host article))) + ((string= article "") ; List all newsgroups + (gnus)) + (t ; Whole newsgroup + (url-news-fetch-newsgroup article host))) + buf)) + +;;;###autoload +(defun url-snews (url) + (let ((nntp-open-connection-function 'nntp-open-ssl-stream)) + (url-news url))) + +(provide 'url-news)