From 9002f2b871a0fe034d5f38f28e589a40f2f2262c Mon Sep 17 00:00:00 2001 From: tsuchiya Date: Mon, 28 May 2001 02:27:35 +0000 Subject: [PATCH] * lisp/nnshimbun.el: Reconstructed to use `shimbun'. * lisp/gnus-group.el (gnus-group-make-shimbun-group): Reconstructed to use `shimbun'. --- ChangeLog | 5 + lisp/gnus-group.el | 45 +- lisp/nnshimbun.el | 1323 ++++++---------------------------------------------- 3 files changed, 184 insertions(+), 1189 deletions(-) diff --git a/ChangeLog b/ChangeLog index 9722d15..2c6167f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,10 @@ 2001-05-28 TSUCHIYA Masatoshi + * lisp/nnshimbun.el: Reconstructed to use `shimbun'. + + * lisp/gnus-group.el (gnus-group-make-shimbun-group): + Reconstructed to use `shimbun'. + * lisp/dgnushack.el (toplevel): Add paths if and only if APEL and FLIM can't be found. diff --git a/lisp/gnus-group.el b/lisp/gnus-group.el index c9eb427..ff81bf7 100644 --- a/lisp/gnus-group.el +++ b/lisp/gnus-group.el @@ -2426,29 +2426,42 @@ If SOLID (the prefix), create a solid group." (nnwarchive-login ,login)))) (gnus-group-make-group group method))) -(defvar nnshimbun-type-definition) (defvar gnus-group-shimbun-server-history nil) (defun gnus-group-make-shimbun-group () "Create a nnshimbun group." (interactive) (require 'nnshimbun) - (let* ((minibuffer-setup-hook (append minibuffer-setup-hook - '(beginning-of-line))) - (server (completing-read "Shimbun address: " - nnshimbun-type-definition nil t - (or (car gnus-group-shimbun-server-history) - (caar nnshimbun-type-definition)) - 'gnus-group-shimbun-server-history)) - (group (completing-read - "Group name: " + (let* ((minibuffer-setup-hook + (append minibuffer-setup-hook '(beginning-of-line))) + (alist + (apply 'nconc (mapcar - 'list - (cdr (assq 'groups - (cdr (assoc server nnshimbun-type-definition))))) - nil t nil)) - (nnshimbun-pre-fetch-article nil)) - (gnus-group-make-group group (list 'nnshimbun server)))) + (lambda (d) + (and (stringp d) + (file-directory-p d) + (delq nil + (mapcar + (lambda (f) + (and (string-match "^sb-\\(.*\\)\\.el$" f) + (list (match-string 1 f)))) + (directory-files d))))) + load-path))) + (server (completing-read + "Shimbun address: " + alist nil t + (or (car gnus-group-shimbun-server-history) + (caar alist)) + 'gnus-group-shimbun-server-history)) + (groups) + (nnshimbun-pre-fetch-article)) + (require (intern (concat "sb-" server))) + (when (setq groups (intern-soft (concat "shimbun-" server "-groups"))) + (gnus-group-make-group + (completing-read "Group name: " + (mapcar 'list (symbol-value groups)) + nil t nil) + (list 'nnshimbun server))))) (defun gnus-group-make-archive-group (&optional all) "Create the (ding) Gnus archive group of the most recent articles. diff --git a/lisp/nnshimbun.el b/lisp/nnshimbun.el index f661ccc..bcd2a78 100644 --- a/lisp/nnshimbun.el +++ b/lisp/nnshimbun.el @@ -1,7 +1,9 @@ ;;; nnshimbun.el --- interfacing with web newspapers -*- coding: junet; -*- -;; Authors: TSUCHIYA Masatoshi -;; Akihiro Arisawa +;; Authors: TSUCHIYA Masatoshi , +;; Akihiro Arisawa , +;; Katsumi Yamaoka , +;; Yuuichi Teranishi ;; Keywords: news ;;; Copyright: @@ -27,163 +29,22 @@ ;; Gnus backend to read newspapers on WEB. - -;;; Defintinos: +;;; Definitions: (gnus-declare-backend "nnshimbun" 'address) (eval-when-compile (require 'cl)) (eval-when-compile (require 'gnus-clfns)) -(eval-when-compile (require 'static)) (require 'nnheader) (require 'nnmail) (require 'nnoo) (require 'gnus-bcklg) -(eval-when-compile (ignore-errors (require 'nnweb))) -;; Report failure to find w3 at load time if appropriate. -(eval '(require 'nnweb)) -(require 'mcharset) +(require 'shimbun) (nnoo-declare nnshimbun) -(defvar nnshimbun-check-interval 300) - -(defconst nnshimbun-mew-groups - '(("meadow-develop" "meadow-develop" nil t) - ("meadow-users-jp" "meadow-users-jp") - ("mule-win32" "mule-win32") - ("mew-win32" "mew-win32") - ("mew-dist" "mew-dist/3300" t) - ("mgp-users-jp" "mgp-users-jp/A" t t))) - -(defvar nnshimbun-type-definition - `(("asahi" - (url . "http://spin.asahi.com/") - (groups "national" "business" "politics" "international" "sports") - (coding-system . ,(static-if (boundp 'MULE) '*sjis* 'shift_jis)) - (generate-nov . nnshimbun-generate-nov-for-each-group) - (get-headers . nnshimbun-asahi-get-headers) - (index-url . (format "%s%s/update/list.html" nnshimbun-url nnshimbun-current-group)) - (from-address . "webmaster@www.asahi.com") - (make-contents . nnshimbun-make-text-or-html-contents) - (contents-start . "\n\n") - (contents-end . "\n\n")) - ("sponichi" - (url . "http://www.sponichi.co.jp/") - (groups "baseball" "soccer" "usa" "others" "society" "entertainment" "horseracing") - (coding-system . ,(static-if (boundp 'MULE) '*sjis* 'shift_jis)) - (generate-nov . nnshimbun-generate-nov-for-each-group) - (get-headers . nnshimbun-sponichi-get-headers) - (index-url . (format "%s%s/index.html" nnshimbun-url nnshimbun-current-group)) - (from-address . "webmaster@www.sponichi.co.jp") - (make-contents . nnshimbun-make-text-or-html-contents) - (contents-start . "\n　") - (contents-end . "\n")) - ("cnet" - (url . "http://cnet.sphere.ne.jp/") - (groups "comp") - (coding-system . ,(static-if (boundp 'MULE) '*sjis* 'shift_jis)) - (generate-nov . nnshimbun-generate-nov-for-each-group) - (get-headers . nnshimbun-cnet-get-headers) - (index-url . (format "%s/News/Oneweek/" nnshimbun-url)) - (from-address . "cnet@sphere.ad.jp") - (make-contents . nnshimbun-make-html-contents) - (contents-start . "\n\n") - (contents-end . "\n\n")) - ("wired" - (url . "http://www.hotwired.co.jp/") - (groups "business" "culture" "technology") - (coding-system . ,(static-if (boundp 'MULE) '*euc-japan* 'euc-jp)) - (generate-nov . nnshimbun-generate-nov-for-all-groups) - (get-headers . nnshimbun-wired-get-all-headers) - (index-url) - (from-address . "webmaster@www.hotwired.co.jp") - (make-contents . nnshimbun-make-html-contents) - (contents-start . "\n\n") - (contents-end . "\n\n")) - ("yomiuri" - (url . "http://www.yomiuri.co.jp/") - (groups "shakai" "sports" "seiji" "keizai" "kokusai" "fuho") - (coding-system . ,(static-if (boundp 'MULE) '*sjis* 'shift_jis)) - (generate-nov . nnshimbun-generate-nov-for-all-groups) - (get-headers . nnshimbun-yomiuri-get-all-headers) - (index-url . (concat nnshimbun-url "main.htm")) - (from-address . "webmaster@www.yomiuri.co.jp") - (make-contents . nnshimbun-make-text-or-html-contents) - (contents-start . "\n\n") - (contents-end . "\n\n")) - ("zdnet" - (url . "http://www.zdnet.co.jp/news/") - (groups "comp") - (coding-system . ,(static-if (boundp 'MULE) '*sjis* 'shift_jis)) - (generate-nov . nnshimbun-generate-nov-for-each-group) - (get-headers . nnshimbun-zdnet-get-headers) - (index-url . nnshimbun-url) - (from-address . "zdnn@softbank.co.jp") - (make-contents . nnshimbun-make-html-contents) - (contents-start . "\\(\\|\\)") - (contents-end . "\\(\\|\\)")) - ("mew" - (url . "http://www.mew.org/archive/") - (groups ,@(mapcar #'car nnshimbun-mew-groups)) - (coding-system . ,(static-if (boundp 'MULE) '*iso-2022-jp* 'iso-2022-jp)) - (generate-nov . nnshimbun-generate-nov-for-each-group) - (get-headers . nnshimbun-mew-get-headers) - (index-url . (nnshimbun-mew-concat-url "index.html")) - (make-contents . nnshimbun-make-mhonarc-contents)) - ("xemacs" - (url . "http://list-archives.xemacs.org/") - (groups "xemacs-announce" "xemacs-beta-ja" "xemacs-beta" - "xemacs-build-reports" "xemacs-cvs" "xemacs-mule" - "xemacs-nt" "xemacs-patches" "xemacs-users-ja" "xemacs") - (coding-system . ,(static-if (boundp 'MULE) '*euc-japan* 'euc-jp)) - (generate-nov . nnshimbun-generate-nov-for-each-group) - (get-headers . nnshimbun-xemacs-get-headers) - (index-url . (nnshimbun-xemacs-concat-url nil)) - (make-contents . nnshimbun-make-mhonarc-contents)) - ("netbsd" - (url . "http://www.jp.netbsd.org/ja/JP/ml/") - (groups "announce-ja" "junk-ja" "tech-misc-ja" "tech-pkg-ja" - "port-arm32-ja" "port-hpcmips-ja" "port-mac68k-ja" - "port-mips-ja" "port-powerpc-ja" "hpcmips-changes-ja" - "members-ja" "admin-ja" "www-changes-ja") - (coding-system . ,(static-if (boundp 'MULE) '*iso-2022-jp* 'iso-2022-jp)) - (generate-nov . nnshimbun-generate-nov-for-each-group) - (get-headers . nnshimbun-netbsd-get-headers) - (index-url . (format "%s%s/index.html" nnshimbun-url nnshimbun-current-group)) - (make-contents . nnshimbun-make-mhonarc-contents)) - ("bbdb-ml" - (url . "http://www.rc.tutrp.tut.ac.jp/bbdb-ml/") - (groups "bbdb-ml") - (coding-system . ,(static-if (boundp 'MULE) '*iso-2022-jp* 'iso-2022-jp)) - (generate-nov . nnshimbun-generate-nov-for-each-group) - (get-headers . nnshimbun-fml-get-headers) - (index-url . nnshimbun-url) - (make-contents . nnshimbun-make-fml-contents)) - )) - -(defvar nnshimbun-x-face-alist - '(("default" . - (("default" . - "X-Face: Ygq$6P.,%Xt$U)DS)cRY@k$VkW!7(X'X'?U{{osjjFG\"E]hND;SPJ-J?O?R|a?L - g2$0rVng=O3Lt}?~IId8Jj&vP^3*o=LKUyk(`t%0c!;t6REk=JbpsEn9MrN7gZ%")))) - "Alist of server vs. alist of group vs. X-Face field. It looks like: - -\((\"asahi\" . ((\"national\" . \"X-face: ***\") - (\"business\" . \"X-Face: ***\") - ;; - ;; - (\"default\" . \"X-face: ***\"))) - (\"sponichi\" . ((\"baseball\" . \"X-face: ***\") - (\"soccer\" . \"X-Face: ***\") - ;; - ;; - (\"default\" . \"X-face: ***\"))) - ;; - (\"default\" . ((\"default\" . \"X-face: ***\")))") - (defvoo nnshimbun-directory (nnheader-concat gnus-directory "shimbun/") "Where nnshimbun will save its files.") @@ -195,22 +56,16 @@ (defvoo nnshimbun-pre-fetch-article nil "*Non nil means that nnshimbun fetch unread articles when scanning groups.") +(defvoo nnshimbun-use-entire-index t + "*Nil means that nnshimbun check the last index of articles.") + ;; set by nnshimbun-possibly-change-group (defvoo nnshimbun-buffer nil) (defvoo nnshimbun-current-directory nil) (defvoo nnshimbun-current-group nil) ;; set by nnshimbun-open-server -(defvoo nnshimbun-url nil) -(defvoo nnshimbun-coding-system nil) -(defvoo nnshimbun-groups nil) -(defvoo nnshimbun-generate-nov nil) -(defvoo nnshimbun-get-headers nil) -(defvoo nnshimbun-index-url nil) -(defvoo nnshimbun-from-address nil) -(defvoo nnshimbun-make-contents nil) -(defvoo nnshimbun-contents-start nil) -(defvoo nnshimbun-contents-end nil) +(defvoo nnshimbun-shimbun nil) (defvoo nnshimbun-server-directory nil) (defvoo nnshimbun-status-string "") @@ -222,24 +77,6 @@ (defvoo nnshimbun-backlog-articles nil) (defvoo nnshimbun-backlog-hashtb nil) -(defconst nnshimbun-meta-content-type-charset-regexp - (eval-when-compile - (concat "")) - "Regexp used in parsing ` -for a charset indication") - -(defconst nnshimbun-meta-charset-content-type-regexp - (eval-when-compile - (concat "")) - "Regexp used in parsing ` -for a charset indication") - - - ;;; backlog (defmacro nnshimbun-backlog (&rest form) `(let ((gnus-keep-backlog nnshimbun-keep-backlog) @@ -254,16 +91,15 @@ for a charset indication") (put 'nnshimbun-backlog 'edebug-form-spec '(form body)) - ;;; Interface Functions (nnoo-define-basics nnshimbun) (deffoo nnshimbun-open-server (server &optional defs) - ;; Set default values. - (dolist (default (cdr (assoc server nnshimbun-type-definition))) - (let ((symbol (intern (concat "nnshimbun-" (symbol-name (car default)))))) - (unless (assq symbol defs) - (push (list symbol (cdr default)) defs)))) + (push (list 'nnshimbun-shimbun + (condition-case err + (shimbun-open server (luna-make-entity 'shimbun-gnus-mua)) + (error (nnheader-report 'nnshimbun "%s" (error-message-string err))))) + defs) ;; Set directory for server working files. (push (list 'nnshimbun-server-directory (file-name-as-directory @@ -297,6 +133,7 @@ for a charset indication") t))))) (deffoo nnshimbun-close-server (&optional server) + (shimbun-close nnshimbun-shimbun) (and (nnshimbun-server-opened server) (gnus-buffer-live-p nnshimbun-buffer) (kill-buffer nnshimbun-buffer)) @@ -305,147 +142,100 @@ for a charset indication") (nnoo-close-server 'nnshimbun server) t) -(static-when (boundp 'MULE) - (unless (coding-system-p 'euc-japan) - (copy-coding-system '*euc-japan* 'euc-japan)) - (unless (coding-system-p 'shift_jis) - (copy-coding-system '*sjis* 'shift_jis)) - (eval-and-compile - (defalias-maybe 'coding-system-category 'get-code-mnemonic))) - -(eval-when-compile - (defvar w3m-work-buffer-name) - (autoload 'w3m-retrieve "w3m")) -(eval-and-compile - (if (and (ignore-errors (require 'w3m)) - (fboundp 'w3m-retrieve)) -;; When w3m.el is available. -(defun nnshimbun-retrieve-url (url &optional no-cache) - "Rertrieve URL contents and insert to current buffer." - (when (w3m-retrieve url nil no-cache) - (insert-buffer w3m-work-buffer-name))) -;; Otherwise. -(defun nnshimbun-retrieve-url (url &optional no-cache) - "Rertrieve URL contents and insert to current buffer." - (let ((buf (current-buffer)) - (url-working-buffer url-working-buffer)) - (let ((old-asynch (default-value 'url-be-asynchronous)) - (old-caching (default-value 'url-automatic-caching)) - (old-mode (default-value 'url-standalone-mode))) - (setq-default url-be-asynchronous nil) - (when no-cache - (setq-default url-automatic-caching nil) - (setq-default url-standalone-mode nil)) - (unwind-protect - (let ((coding-system-for-read 'binary) - (coding-system-for-write 'binary) - (input-coding-system 'binary) - (output-coding-system 'binary) - (default-enable-multibyte-characters nil)) - (set-buffer - (setq url-working-buffer - (cdr (url-retrieve url no-cache)))) - (url-uncompress)) - (setq-default url-be-asynchronous old-asynch) - (setq-default url-automatic-caching old-caching) - (setq-default url-standalone-mode old-mode))) - (let ((charset - (or (and (boundp 'url-current-mime-charset) - (symbol-value 'url-current-mime-charset)) - (let ((case-fold-search t)) - (goto-char (point-min)) - (if (or (re-search-forward - nnshimbun-meta-content-type-charset-regexp nil t) - (re-search-forward - nnshimbun-meta-charset-content-type-regexp nil t)) - (buffer-substring-no-properties (match-beginning 2) - (match-end 2))))))) - (decode-coding-region - (point-min) (point-max) - (if charset - (let ((mime-charset-coding-system-alist - (append '((euc-jp . euc-japan) - (shift-jis . shift_jis) - (shift_jis . shift_jis) - (sjis . shift_jis) - (x-euc-jp . euc-japan) - (x-shift-jis . shift_jis) - (x-shift_jis . shift_jis) - (x-sjis . shift_jis)) - mime-charset-coding-system-alist))) - (mime-charset-to-coding-system charset)) - (let ((default (condition-case nil - (coding-system-category nnshimbun-coding-system) - (error nil))) - (candidate (detect-coding-region (point-min) (point-max)))) - (unless (listp candidate) - (setq candidate (list candidate))) - (catch 'coding - (dolist (coding candidate) - (if (eq default (coding-system-category coding)) - (throw 'coding coding))) - (if (eq (coding-system-category 'binary) - (coding-system-category (car candidate))) - nnshimbun-coding-system - (car candidate))))))) - (set-buffer-multibyte t) - (set-buffer buf) - (insert-buffer url-working-buffer) - (kill-buffer url-working-buffer))) -)) - -(deffoo nnshimbun-request-article (article &optional group server to-buffer) - (when (nnshimbun-possibly-change-group group server) - (if (stringp article) - (setq article (nnshimbun-search-id group article))) - (if (integerp article) - (nnshimbun-request-article-1 article group server to-buffer) - (nnheader-report 'nnml "Couldn't retrieve article: %s" (prin1-to-string article)) - nil))) - (defsubst nnshimbun-header-xref (x) (if (and (setq x (mail-header-xref x)) (string-match "^Xref: " x)) (substring x 6) x)) +(eval-and-compile + (if (fboundp 'mime-entity-fetch-field) + ;; For Semi-Gnus. + (defun nnshimbun-make-shimbun-header (header) + (shimbun-make-header + (mail-header-number header) + (mime-entity-fetch-field header 'Subject) + (mime-entity-fetch-field header 'From) + (mail-header-date header) + (or (cdr (assq 'X-Nnshimbun-Id (mail-header-extra header))) + (mail-header-id header)) + (mail-header-references header) + (mail-header-chars header) + (mail-header-lines header) + (nnshimbun-header-xref header))) + ;; For pure Gnus. + (defun nnshimbun-make-shimbun-header (header) + (shimbun-make-header + (mail-header-number header) + (mail-header-subject header) + (mail-header-from header) + (mail-header-date header) + (or (cdr (assq 'X-Nnshimbun-Id (mail-header-extra header))) + (mail-header-id header)) + (mail-header-references header) + (mail-header-chars header) + (mail-header-lines header) + (nnshimbun-header-xref header))))) + +(defsubst nnshimbun-check-header (group header) + (let (flag) + ;; Check message-id. + (let ((id (std11-field-body "message-id"))) + (when (and id (not (string= id (mail-header-id header)))) + (let ((extra (mail-header-extra header))) + (unless (assq 'X-Nnshimbun-Id extra) + (push (cons 'X-Nnshimbun-Id (mail-header-id header)) extra) + (mail-header-set-extra header extra))) + (mail-header-set-id header id) + (setq flag t))) + ;; Check references. + (when (string= "" (mail-header-references header)) + (let ((refs (std11-field-body "references"))) + (when refs + (mail-header-set-references header (std11-unfold-string refs)))) + (setq flag t)) + (when flag + ;; Replace header. + (with-current-buffer (nnshimbun-open-nov group) + (when (nnheader-find-nov-line (mail-header-number header)) + (mail-header-set-xref header (nnshimbun-header-xref header)) + (delete-region (point) (progn (forward-line 1) (point))) + (nnheader-insert-nov header)))))) + (defun nnshimbun-request-article-1 (article &optional group server to-buffer) (if (nnshimbun-backlog (gnus-backlog-request-article group article (or to-buffer nntp-server-buffer))) (cons group article) - (let (header contents) - (when (setq header (save-excursion - (set-buffer (nnshimbun-open-nov group)) - (and (nnheader-find-nov-line article) - (nnheader-parse-nov)))) - (let* ((xref (nnshimbun-header-xref header)) - (x-faces (cdr (or (assoc (or server - (nnoo-current-server 'nnshimbun)) - nnshimbun-x-face-alist) - (assoc "default" nnshimbun-x-face-alist)))) - (x-face (cdr (or (assoc group x-faces) - (assoc "default" x-faces))))) - (save-excursion - (set-buffer nnshimbun-buffer) - (erase-buffer) - (nnshimbun-retrieve-url xref) - (nnheader-message 6 "nnshimbun: Make contents...") - (goto-char (point-min)) - (setq contents (funcall nnshimbun-make-contents header x-face)) - (nnheader-message 6 "nnshimbun: Make contents...done")))) - (when contents - (save-excursion - (set-buffer (or to-buffer nntp-server-buffer)) - (erase-buffer) - (insert contents) - (nnshimbun-backlog - (gnus-backlog-enter-article group article (current-buffer))) - (nnheader-report 'nnshimbun "Article %s retrieved" (mail-header-id header)) - (cons group (mail-header-number header))))))) + (let ((header (with-current-buffer (nnshimbun-open-nov group) + (and (nnheader-find-nov-line article) + (nnheader-parse-nov))))) + (when header + (with-current-buffer (or to-buffer nntp-server-buffer) + (delete-region (point-min) (point-max)) + (shimbun-article nnshimbun-shimbun + (nnshimbun-make-shimbun-header header)) + (when (> (buffer-size) 0) + (nnshimbun-check-header group header) + (nnshimbun-backlog + (gnus-backlog-enter-article group article (current-buffer))) + (nnheader-report 'nnshimbun "Article %s retrieved" + (mail-header-id header)) + (cons group (mail-header-number header)))))))) + +(deffoo nnshimbun-request-article (article &optional group server to-buffer) + (when (nnshimbun-possibly-change-group group server) + (when (stringp article) + (setq article (nnshimbun-search-id group article))) + (if (integerp article) + (nnshimbun-request-article-1 article group server to-buffer) + (nnheader-report 'nnshimbun "Couldn't retrieve article: %s" + (prin1-to-string article)) + nil))) (deffoo nnshimbun-request-group (group &optional server dont-check) - (let ((pathname-coding-system 'binary)) + (let ((file-name-coding-system nnmail-pathname-coding-system) + (pathname-coding-system nnmail-pathname-coding-system)) (cond ((not (nnshimbun-possibly-change-group group server)) (nnheader-report 'nnshimbun "Invalid group (no such directory)")) @@ -480,14 +270,12 @@ for a charset indication") t) (deffoo nnshimbun-request-list (&optional server) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (dolist (group nnshimbun-groups) + (with-current-buffer nntp-server-buffer + (delete-region (point-min) (point-max)) + (dolist (group (shimbun-groups nnshimbun-shimbun)) (when (nnshimbun-possibly-change-group group server) (let (beg end) - (save-excursion - (set-buffer (nnshimbun-open-nov group)) + (with-current-buffer (nnshimbun-open-nov group) (goto-char (point-min)) (setq beg (ignore-errors (read (current-buffer)))) (goto-char (point-max)) @@ -496,45 +284,25 @@ for a charset indication") (insert (format "%s %d %d n\n" group (or end 0) (or beg 0))))))) t) ; return value -(eval-and-compile - (if (fboundp 'mime-entity-fetch-field) - ;; For Semi-Gnus. - (defun nnshimbun-insert-header (header) - (insert "Subject: " (or (mime-entity-fetch-field header 'Subject) "(none)") "\n" - "From: " (or (mime-entity-fetch-field header 'From) "(nobody)") "\n" - "Date: " (or (mail-header-date header) "") "\n" - "Message-ID: " (or (mail-header-id header) (nnmail-message-id)) "\n") - (let ((refs (mail-header-references header))) - (and refs - (string< "" refs) - (insert "References: " refs "\n"))) - (insert "Lines: " (number-to-string (or (mail-header-lines header) 0)) "\n" - "Xref: " (nnshimbun-header-xref header) "\n")) - ;; For pure Gnus. - (defun nnshimbun-insert-header (header) - (nnheader-insert-header header) - (delete-char -1) - (insert "Xref: " (nnshimbun-header-xref header) "\n")))) - (deffoo nnshimbun-retrieve-headers (articles &optional group server fetch-old) (when (nnshimbun-possibly-change-group group server) (if (nnshimbun-retrieve-headers-with-nov articles fetch-old) 'nov - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) + (with-current-buffer nntp-server-buffer + (delete-region (point-min) (point-max)) (let (header) (dolist (art articles) (if (stringp art) (setq art (nnshimbun-search-id group art))) (if (integerp art) (when (setq header - (save-excursion - (set-buffer (nnshimbun-open-nov group)) + (with-current-buffer (nnshimbun-open-nov group) (and (nnheader-find-nov-line art) (nnheader-parse-nov)))) (insert (format "220 %d Article retrieved.\n" art)) - (nnshimbun-insert-header header) + (shimbun-header-insert + nnshimbun-shimbun + (nnshimbun-make-shimbun-header header)) (insert ".\n") (delete-region (point) (point-max)))))) 'header)))) @@ -561,57 +329,31 @@ for a charset indication") ;;; Nov Database Operations (defun nnshimbun-generate-nov-database (group) - (prog1 (funcall nnshimbun-generate-nov group) - (nnshimbun-write-nov group))) - -(defun nnshimbun-generate-nov-for-each-group (group) (nnshimbun-possibly-change-group group) - (save-excursion - (set-buffer (nnshimbun-open-nov group)) - (let (i) - (goto-char (point-max)) - (forward-line -1) - (setq i (or (ignore-errors (read (current-buffer))) 0)) - (dolist (header (save-excursion - (set-buffer nnshimbun-buffer) - (erase-buffer) - (nnshimbun-retrieve-url (eval nnshimbun-index-url) t) - (goto-char (point-min)) - (funcall nnshimbun-get-headers))) - (unless (nnshimbun-search-id group (mail-header-id header)) - (mail-header-set-number header (setq i (1+ i))) - (goto-char (point-max)) - (nnheader-insert-nov header) - (if nnshimbun-pre-fetch-article - (nnshimbun-request-article-1 i group nil nnshimbun-buffer))))))) - -(defun nnshimbun-generate-nov-for-all-groups (&rest args) - (unless (and nnshimbun-nov-last-check - (< (nnshimbun-lapse-seconds nnshimbun-nov-last-check) - nnshimbun-check-interval)) - (save-excursion - (dolist (list (funcall nnshimbun-get-headers)) - (let ((group (car list))) - (nnshimbun-possibly-change-group group) - (when (cdr list) - (set-buffer (nnshimbun-open-nov group)) - (let (i) - (goto-char (point-max)) - (forward-line -1) - (setq i (or (ignore-errors (read (current-buffer))) 0)) - (dolist (header (cdr list)) - (unless (nnshimbun-search-id group (mail-header-id header)) - (mail-header-set-number header (setq i (1+ i))) - (goto-char (point-max)) - (nnheader-insert-nov header) - (if nnshimbun-pre-fetch-article - (nnshimbun-request-article-1 i group nil nnshimbun-buffer)))))))) - (nnshimbun-save-nov) - (setq nnshimbun-nov-last-check (current-time))))) + (let (i) + (with-current-buffer (nnshimbun-open-nov group) + (goto-char (point-max)) + (forward-line -1) + (setq i (or (ignore-errors (read (current-buffer))) 0)) + (dolist (header (shimbun-headers nnshimbun-shimbun)) + (unless (nnshimbun-search-id group (shimbun-header-id header)) + (goto-char (point-max)) + (nnheader-insert-nov + (make-full-mail-header (setq i (1+ i)) + (shimbun-header-subject header) + (shimbun-header-from header) + (shimbun-header-date header) + (shimbun-header-id header) + (shimbun-header-references header) + (shimbun-header-chars header) + (shimbun-header-lines header) + (shimbun-header-xref header))) + (if nnshimbun-pre-fetch-article + (nnshimbun-request-article-1 i group nil nnshimbun-buffer))))) + (nnshimbun-write-nov group))) (defun nnshimbun-search-id (group id &optional nov) - (save-excursion - (set-buffer (nnshimbun-open-nov group)) + (with-current-buffer (nnshimbun-open-nov group) (goto-char (point-min)) (let (found) (while (and (not found) @@ -624,34 +366,19 @@ for a charset indication") (setq found t))) (unless found (goto-char (point-min)) - (when (search-forward (concat "X-Nnshimbun-Id: " id) nil t) - (forward-line 0) - (setq found t))) + (setq id (concat "X-Nnshimbun-Id: " id)) + (while (and (not found) + (search-forward id nil t)) + (if (not (search-backward "\t" (gnus-point-at-bol) t 8)) + (forward-line 1) + (forward-line 0) + (setq found t)))) (if found (if nov (nnheader-parse-nov) ;; We return the article number. (ignore-errors (read (current-buffer)))))))) -(defun nnshimbun-nov-fix-header (group header args) - (save-excursion - (set-buffer (nnshimbun-open-nov group)) - (when (nnheader-find-nov-line (mail-header-number header)) - (dolist (arg args) - (if (eq (car arg) 'id) - (let ((extra (mail-header-extra header))) - (unless (assq 'X-Nnshimbun-Id extra) - (mail-header-set-extra - header - (cons (cons 'X-Nnshimbun-Id (mail-header-id header)) - extra))) - (mail-header-set-id header (cdr arg))) - (let ((func (intern (concat "mail-header-set-" (symbol-name (car arg)))))) - (if (cdr arg) (eval (list func header (cdr arg))))))) - (mail-header-set-xref header (nnshimbun-header-xref header)) - (delete-region (point) (progn (forward-line 1) (point))) - (nnheader-insert-nov header)))) - (defun nnshimbun-open-nov (group) (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist)))) (if (buffer-live-p buffer) @@ -696,6 +423,7 @@ for a charset indication") ;;; Server Initialize + (defun nnshimbun-possibly-change-group (group &optional server) (when server (unless (nnshimbun-server-opened server) @@ -707,8 +435,12 @@ for a charset indication") (format " *nnshimbun %s*" (nnoo-current-server 'nnshimbun)))))) (if (not group) t + (condition-case err + (shimbun-open-group nnshimbun-shimbun group) + (error (nnheader-report 'nnshimbun "%s" (error-message-string err)))) (let ((pathname (nnmail-group-pathname group nnshimbun-server-directory)) - (pathname-coding-system 'binary)) + (file-name-coding-system nnmail-pathname-coding-system) + (pathname-coding-system nnmail-pathname-coding-system)) (unless (equal pathname nnshimbun-current-directory) (setq nnshimbun-current-directory pathname nnshimbun-current-group group)) @@ -723,772 +455,17 @@ for a charset indication") -;;; Misc Functions - -(eval-and-compile - (if (fboundp 'eword-encode-string) - ;; For Semi-Gnus. - (defun nnshimbun-mime-encode-string (string) - (mapconcat - #'identity - (split-string (eword-encode-string (nnweb-decode-entities-string string)) "\n") - "")) - ;; For pure Gnus. - (defun nnshimbun-mime-encode-string (string) - (mapconcat - #'identity - (split-string - (with-temp-buffer - (insert (nnweb-decode-entities-string string)) - (rfc2047-encode-region (point-min) (point-max)) - (buffer-substring (point-min) (point-max))) - "\n") - "")))) - -(defun nnshimbun-lapse-seconds (time) - (let ((now (current-time))) - (+ (* (- (car now) (car time)) 65536) - (- (nth 1 now) (nth 1 time))))) - -(defun nnshimbun-make-date-string (year month day &optional time) - (format "%02d %s %04d %s +0900" - day - (aref [nil "Jan" "Feb" "Mar" "Apr" "May" "Jun" - "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"] - month) - (cond ((< year 69) - (+ year 2000)) - ((< year 100) - (+ year 1900)) - ((< year 1000) ; possible 3-digit years. - (+ year 1900)) - (t year)) - (or time "00:00"))) - -(if (fboundp 'regexp-opt) - (defalias 'nnshimbun-regexp-opt 'regexp-opt) - (defun nnshimbun-regexp-opt (strings &optional paren) - "Return a regexp to match a string in STRINGS. -Each string should be unique in STRINGS and should not contain any regexps, -quoted or not. If optional PAREN is non-nil, ensure that the returned regexp -is enclosed by at least one regexp grouping construct." - (let ((open-paren (if paren "\\(" "")) (close-paren (if paren "\\)" ""))) - (concat open-paren (mapconcat 'regexp-quote strings "\\|") close-paren)))) - - -;; Fast fill-region function - -(defvar nnshimbun-fill-column (min 80 (- (frame-width) 4))) - -(defconst nnshimbun-kinsoku-bol-list - (append "!)-_~}]:;',.?、。，．・：；？！゛゜´｀¨＾￣＿ヽヾゝゞ〃\ -仝々〆〇ー―‐／＼〜‖｜…‥’”）〕］｝〉》」』】°′″℃ぁぃぅぇぉ\ -っゃゅょゎァィゥェォッャュョヮヵヶ" nil)) - -(defconst nnshimbun-kinsoku-eol-list - (append "({[`‘“（〔［｛〈《「『【°′″§" nil)) - -(defun nnshimbun-fill-line () - (forward-line 0) - (let ((top (point)) chr) - (while (if (>= (move-to-column nnshimbun-fill-column) - nnshimbun-fill-column) - (not (progn - (if (memq (preceding-char) nnshimbun-kinsoku-eol-list) - (progn - (backward-char) - (while (memq (preceding-char) nnshimbun-kinsoku-eol-list) - (backward-char)) - (insert "\n")) - (while (memq (setq chr (following-char)) nnshimbun-kinsoku-bol-list) - (forward-char)) - (if (looking-at "\\s-+") - (or (eolp) (delete-region (point) (match-end 0))) - (or (> (char-width chr) 1) - (re-search-backward "\\<" top t) - (end-of-line))) - (or (eolp) (insert "\n")))))) - (setq top (point)))) - (forward-line 1) - (not (eobp))) - -(defsubst nnshimbun-shallow-rendering () - (goto-char (point-min)) - (while (search-forward "

" nil t) - (insert "\n\n")) - (goto-char (point-min)) - (while (search-forward "
" nil t) - (insert "\n")) - (nnweb-remove-markup) - (nnweb-decode-entities) - (goto-char (point-min)) - (while (nnshimbun-fill-line)) - (goto-char (point-min)) - (when (skip-chars-forward "\n") - (delete-region (point-min) (point))) - (while (search-forward "\n\n" nil t) - (let ((p (point))) - (when (skip-chars-forward "\n") - (delete-region p (point))))) - (goto-char (point-max)) - (when (skip-chars-backward "\n") - (delete-region (point) (point-max))) - (insert "\n")) - -(defun nnshimbun-make-text-or-html-contents (header &optional x-face) - (let ((case-fold-search t) (html t) (start)) - (when (and (re-search-forward nnshimbun-contents-start nil t) - (setq start (point)) - (re-search-forward nnshimbun-contents-end nil t)) - (delete-region (match-beginning 0) (point-max)) - (delete-region (point-min) start) - (nnshimbun-shallow-rendering) - (setq html nil)) - (goto-char (point-min)) - (nnshimbun-insert-header header) - (insert "Content-Type: " (if html "text/html" "text/plain") - "; charset=ISO-2022-JP\nMIME-Version: 1.0\n") - (when x-face - (insert x-face) - (unless (bolp) - (insert "\n"))) - (insert "\n") - (encode-coding-string (buffer-string) - (mime-charset-to-coding-system "ISO-2022-JP")))) - -(defun nnshimbun-make-html-contents (header &optional x-face) - (let (start) - (when (and (re-search-forward nnshimbun-contents-start nil t) - (setq start (point)) - (re-search-forward nnshimbun-contents-end nil t)) - (delete-region (match-beginning 0) (point-max)) - (delete-region (point-min) start)) - (goto-char (point-min)) - (nnshimbun-insert-header header) - (insert "Content-Type: text/html; charset=ISO-2022-JP\n" - "MIME-Version: 1.0\n") - (when x-face - (insert x-face) - (unless (bolp) - (insert "\n"))) - (insert "\n") - (encode-coding-string (buffer-string) - (mime-charset-to-coding-system "ISO-2022-JP")))) - -(defun nnshimbun-make-mhonarc-contents (header &rest args) - (require 'mml) - (if (search-forward "" nil t) - (progn - (forward-line 0) - ;; Processing headers. - (save-restriction - (narrow-to-region (point-min) (point)) - (nnweb-decode-entities) - (goto-char (point-min)) - (while (search-forward "\n\n" nil t) - (replace-match "\n")) - (goto-char (point-min)) - (while (search-forward "\t" nil t) - (replace-match " ")) - (goto-char (point-min)) - (let (buf refs) - (while (not (eobp)) - (cond - ((looking-at "\n" nil t) - (point))) - (when (search-forward "\n\n" nil t) - (forward-line -1) - (delete-region (point) (point-max))) - (nnweb-remove-markup) - (nnweb-decode-entities))) - (goto-char (point-min)) - (nnshimbun-insert-header header) - (insert "Content-Type: text/html; charset=ISO-2022-JP\nMIME-Version: 1.0\n\n")) - (encode-coding-string (buffer-string) - (mime-charset-to-coding-system "ISO-2022-JP"))) - -(defun nnshimbun-make-fml-contents (header &rest args) - (require 'mml) - (catch 'stop - (if (search-forward "" nil t) - (delete-region (point-min) (point)) - (throw 'stop nil)) - (if (search-forward "") - (progn - (beginning-of-line) - (delete-region (point) (point-max))) - (throw 'stop nil)) - (if (search-backward "") - (progn - (beginning-of-line) - (kill-line)) - (throw 'stop nil)) - (save-restriction - (narrow-to-region (point-min) (point)) - (subst-char-in-region (point-min) (point-max) ?\t ? t) - (nnweb-decode-entities) - (goto-char (point-min)) - (let (buf field value start value-beg end) - (while (and (setq start (point)) - (re-search-forward "\\(.*\\):" - nil t) - (setq field (match-string 2)) - (re-search-forward - (concat "") nil t) - (setq value-beg (point)) - (search-forward "" nil t) - (setq end (point))) - (setq value (buffer-substring value-beg - (progn (search-backward "") - (point)))) - (delete-region start end) - (cond ((string= field "Date") - (push (cons 'date value) buf)) - ((string= field "From") - (push (cons 'from value) buf)) - ((string= field "Subject") - (push (cons 'subject value) buf)) - ((string= field "Message-Id") - (push (cons 'id value) buf)) - ((string= field "References") - (push (cons 'references value) buf)) - (t - (insert (concat field ": " value "\n"))))) - (nnshimbun-nov-fix-header nnshimbun-current-group header buf) - (goto-char (point-min)) - (nnshimbun-insert-header header)) - (goto-char (point-max))) - ;; Processing body. - (save-restriction - (narrow-to-region (point) (point-max)) - (nnweb-remove-markup) - (nnweb-decode-entities))) - (encode-coding-string (buffer-string) - (mime-charset-to-coding-system "ISO-2022-JP"))) - -;;; www.asahi.com - -(defun nnshimbun-asahi-get-headers () - (when (search-forward "\n\n" nil t) - (delete-region (point-min) (point)) - (when (search-forward "\n\n" nil t) - (forward-line -1) - (delete-region (point) (point-max)) - (goto-char (point-min)) - (let (headers) - (while (re-search-forward - "^[ \t\r\f\n]*" - nil t) - (let ((id (format "<%s%s%%%s>" - (match-string 2) - (match-string 3) - nnshimbun-current-group)) - (url (match-string 1))) - (push (make-full-mail-header - 0 - (nnshimbun-mime-encode-string - (mapconcat 'identity - (split-string - (buffer-substring - (match-end 0) - (progn (search-forward "
" nil t) (point))) - "\\(<[^>]+>\\|\r\\)") - "")) - nnshimbun-from-address - "" id "" 0 0 - (format "%s%s/update/%s" nnshimbun-url nnshimbun-current-group url)) - headers))) - (setq headers (nreverse headers)) - (let ((i 0)) - (while (and (nth i headers) - (re-search-forward - "^(\\([0-9][0-9]\\)/\\([0-9][0-9]\\) \\([0-9][0-9]:[0-9][0-9]\\))" - nil t)) - (let ((month (string-to-number (match-string 1))) - (date (decode-time (current-time)))) - (mail-header-set-date - (nth i headers) - (nnshimbun-make-date-string - (if (and (eq 12 month) (eq 1 (nth 4 date))) - (1- (nth 5 date)) - (nth 5 date)) - month - (string-to-number (match-string 2)) - (match-string 3)))) - (setq i (1+ i)))) - (nreverse headers))))) - - - -;;; www.sponichi.co.jp - -(defun nnshimbun-sponichi-get-headers () - (when (search-forward "ニュースインデックス" nil t) - (delete-region (point-min) (point)) - (when (search-forward "アドタグ" nil t) - (forward-line 2) - (delete-region (point) (point-max)) - (goto-char (point-min)) - (let ((case-fold-search t) headers) - (while (re-search-forward - "^" - nil t) - (let ((url (match-string 1)) - (id (format "<%s%s%s%s%%%s>" - (match-string 3) - (match-string 4) - (match-string 5) - (match-string 6) - nnshimbun-current-group)) - (date (nnshimbun-make-date-string - (string-to-number (match-string 3)) - (string-to-number (match-string 4)) - (string-to-number (match-string 5))))) - (push (make-full-mail-header - 0 - (nnshimbun-mime-encode-string - (mapconcat 'identity - (split-string - (buffer-substring - (match-end 0) - (progn (search-forward "
" nil t) (point))) - "<[^>]+>") - "")) - nnshimbun-from-address - date id "" 0 0 (concat nnshimbun-url url)) - headers))) - headers)))) - - - -;;; CNET Japan - -(defun nnshimbun-cnet-get-headers () - (let ((case-fold-search t) headers) - (while (search-forward "\n\n" nil t) - (let ((subject (buffer-substring (point) (gnus-point-at-eol))) - (point (point))) - (forward-line -2) - (when (looking-at "") - (let ((url (match-string 1)) - (id (format "<%s%s%%%s>" - (match-string 2) - (match-string 3) - nnshimbun-current-group)) - (date (nnshimbun-make-date-string - (string-to-number (match-string 2)) - (string-to-number (match-string 4)) - (string-to-number (match-string 5))))) - (push (make-full-mail-header - 0 - (nnshimbun-mime-encode-string subject) - nnshimbun-from-address - date id "" 0 0 (concat nnshimbun-url url)) - headers))) - (goto-char point))) - headers)) - - - -;;; Wired - -(defun nnshimbun-wired-get-all-headers () - (save-excursion - (set-buffer nnshimbun-buffer) - (let ((group-header-alist (mapcar (lambda (g) (cons g nil)) nnshimbun-groups)) - (case-fold-search t) - (regexp (format - "" - (regexp-quote nnshimbun-url) - (nnshimbun-regexp-opt nnshimbun-groups)))) - (dolist (xover (list (concat nnshimbun-url "news/news/index.html") - (concat nnshimbun-url "news/news/last_seven.html"))) - (erase-buffer) - (nnshimbun-retrieve-url xover t) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (let* ((url (concat nnshimbun-url (match-string 2))) - (group (downcase (match-string 3))) - (id (format "<%s%%%s>" (match-string 4) group)) - (date (nnshimbun-make-date-string - (string-to-number (match-string 5)) - (string-to-number (match-string 6)) - (string-to-number (match-string 7)))) - (header (make-full-mail-header - 0 - (nnshimbun-mime-encode-string - (mapconcat 'identity - (split-string - (buffer-substring - (match-end 0) - (progn (search-forward "" nil t) (point))) - "<[^>]+>") - "")) - nnshimbun-from-address - date id "" 0 0 url)) - (x (assoc group group-header-alist))) - (setcdr x (cons header (cdr x)))))) - group-header-alist))) - - - -;;; www.yomiuri.co.jp - -(defun nnshimbun-yomiuri-get-all-headers () - (save-excursion - (set-buffer nnshimbun-buffer) - (erase-buffer) - (nnshimbun-retrieve-url (eval nnshimbun-index-url) t) - (let ((case-fold-search t) - (group-header-alist (mapcar (lambda (g) (cons g nil)) nnshimbun-groups))) - (dolist (group nnshimbun-groups) - (let (start) - (goto-char (point-min)) - (when (and (search-forward (format "\n\n" group) nil t) - (setq start (point)) - (search-forward (format "\n\n" group) nil t)) - (forward-line -1) - (save-restriction - (narrow-to-region start (point)) - (goto-char start) - (while (re-search-forward - "]*>" - nil t) - (let ((url (concat (match-string 1) "a/" (match-string 2))) - (id (format "<%s%s%%%s>" - (match-string 1) - (match-string 3) - group)) - (year (string-to-number (match-string 4))) - (month (string-to-number (match-string 5))) - (day (string-to-number (match-string 6))) - (subject (mapconcat - 'identity - (split-string - (buffer-substring - (match-end 0) - (progn (search-forward "
" nil t) (point))) - "<[^>]+>") - "")) - date x) - (when (string-match "^◆" subject) - (setq subject (substring subject (match-end 0)))) - (if (string-match "(\\([0-9][0-9]:[0-9][0-9]\\))$" subject) - (setq date (nnshimbun-make-date-string - year month day (match-string 1 subject)) - subject (substring subject 0 (match-beginning 0))) - (setq date (nnshimbun-make-date-string year month day))) - (setcdr (setq x (assoc group group-header-alist)) - (cons (make-full-mail-header - 0 - (nnshimbun-mime-encode-string subject) - nnshimbun-from-address - date id "" 0 0 (concat nnshimbun-url url)) - (cdr x))))))))) - group-header-alist))) - - - -;;; Zdnet Japan - -(defun nnshimbun-zdnet-get-headers () - (let ((case-fold-search t) headers) - (goto-char (point-min)) - (let (start) - (while (and (search-forward "" nil t)) - (delete-region start (point)))) - (goto-char (point-min)) - (while (re-search-forward - "" - nil t) - (let ((year (+ 2000 (string-to-number (match-string 3)))) - (month (string-to-number (match-string 4))) - (day (string-to-number (match-string 5))) - (id (format "<%s%s%s%s%%%s>" - (match-string 3) - (match-string 4) - (match-string 5) - (match-string 6) - nnshimbun-current-group)) - (url (match-string 2))) - (push (make-full-mail-header - 0 - (nnshimbun-mime-encode-string - (mapconcat 'identity - (split-string - (buffer-substring - (match-end 0) - (progn (search-forward "" nil t) (point))) - "<[^>]+>") - "")) - nnshimbun-from-address - (nnshimbun-make-date-string year month day) - id "" 0 0 (concat nnshimbun-url url)) - headers))) - (nreverse headers))) - - - -;;; MLs on www.mew.org - -(defmacro nnshimbun-mew-concat-url (url) - `(concat nnshimbun-url - (nth 1 (assoc nnshimbun-current-group nnshimbun-mew-groups)) - "/" - ,url)) - -(defmacro nnshimbun-mew-reverse-order-p () - `(nth 2 (assoc nnshimbun-current-group nnshimbun-mew-groups))) - -(defmacro nnshimbun-mew-spew-p () - `(nth 3 (assoc nnshimbun-current-group nnshimbun-mew-groups))) - -(defsubst nnshimbun-mew-retrieve-xover (aux) - (erase-buffer) - (nnshimbun-retrieve-url - (nnshimbun-mew-concat-url (if (= aux 1) "index.html" (format "mail%d.html" aux))) - t)) - -(defconst nnshimbun-mew-regexp "]*HREF=\"\\(msg\\([0-9]+\\).html\\)\">\\([^<]+\\)<") - -(defmacro nnshimbun-mew-extract-header-values () - `(progn - (setq url (nnshimbun-mew-concat-url (match-string 1)) - id (format "<%05d%%%s>" - (1- (string-to-number (match-string 2))) - nnshimbun-current-group) - subject (match-string 3)) - (forward-line 1) - (if (nnshimbun-search-id nnshimbun-current-group id) - (throw 'stop headers) - (push (make-full-mail-header - 0 - (nnshimbun-mime-encode-string subject) - (if (looking-at "\\([^<]+\\)<") - (nnshimbun-mime-encode-string (match-string 1)) - "") - "" id "" 0 0 url) - headers)))) - -(eval-and-compile - (if (fboundp 'mime-entity-fetch-field) - ;; For Semi-Gnus. - (defmacro nnshimbun-mew-mail-header-subject (header) - `(mime-entity-fetch-field ,header 'Subject)) - ;; For pure Gnus. - (defalias 'nnshimbun-mew-mail-header-subject 'mail-header-subject))) - -(defun nnshimbun-mew-get-headers () - (if (nnshimbun-mew-spew-p) - (let ((headers (nnshimbun-mew-get-headers-1))) - (erase-buffer) - (insert-buffer-substring (nnshimbun-open-nov nnshimbun-current-group)) - (delq nil - (mapcar - (lambda (header) - (goto-char (point-min)) - (let ((subject (nnshimbun-mew-mail-header-subject header)) - (found)) - (while (and (not found) - (search-forward subject nil t)) - (if (not (and (search-backward "\t" nil t) - (not (search-backward "\t" (gnus-point-at-bol) t)))) - (forward-line 1) - (setq found t))) - (if found - nil - (goto-char (point-max)) - (nnheader-insert-nov header) - header))) - headers))) - (nnshimbun-mew-get-headers-1))) - -(defun nnshimbun-mew-get-headers-1 () - (let (headers) - (when (re-search-forward - "]*HREF=\"mail\\([0-9]+\\)\\.html\">\\[?Last Page\\]?" nil t) - (let ((limit (string-to-number (match-string 1)))) - (catch 'stop - (if (nnshimbun-mew-reverse-order-p) - (let ((aux 1)) - (while (let (id url subject) - (while (re-search-forward nnshimbun-mew-regexp nil t) - (nnshimbun-mew-extract-header-values)) - (< aux limit)) - (nnshimbun-mew-retrieve-xover (setq aux (1+ aux))))) - (while (> limit 0) - (nnshimbun-mew-retrieve-xover limit) - (setq limit (1- limit)) - (let (id url subject) - (goto-char (point-max)) - (while (re-search-backward nnshimbun-mew-regexp nil t) - (nnshimbun-mew-extract-header-values) - (forward-line -2))))) - headers))))) - - - -;;; MLs on www.xemacs.org - -(defmacro nnshimbun-xemacs-concat-url (url) - `(concat nnshimbun-url nnshimbun-current-group "/" ,url)) +;;; shimbun-gnus-mua +(luna-define-class shimbun-gnus-mua (shimbun-mua) ()) -(defun nnshimbun-xemacs-get-headers () - (let (headers auxs aux) - (catch 'stop - (while (re-search-forward - (concat "\\[Index\\]") - nil t) - (setq auxs (append auxs (list (match-string 1))))) - (while auxs - (erase-buffer) - (nnshimbun-retrieve-url - (nnshimbun-xemacs-concat-url (concat (setq aux (car auxs)) "/"))) - (let (id url subject) - (goto-char (point-max)) - (while (re-search-backward - "]*HREF=\"\\(msg\\([0-9]+\\).html\\)\">\\([^<]+\\)<" - nil t) - (setq url (nnshimbun-xemacs-concat-url - (concat aux "/" (match-string 1))) - id (format "<%s%05d%%%s>" - aux - (string-to-number (match-string 2)) - nnshimbun-current-group) - subject (match-string 3)) - (forward-line 1) - (if (nnshimbun-search-id nnshimbun-current-group id) - (throw 'stop headers) - (push (make-full-mail-header - 0 - (nnshimbun-mime-encode-string subject) - (if (looking-at "\\([^<]+\\)<") - (match-string 1) - "") - "" id "" 0 0 url) - headers)) - (message "%s" id) - (forward-line -2))) - (setq auxs (cdr auxs)))) - headers)) +(luna-define-method shimbun-mua-search-id ((mua shimbun-gnus-mua) id) + (nnshimbun-search-id + (shimbun-current-group-internal (shimbun-mua-shimbun-internal mua)) + id)) -;;; MLs on www.jp.netbsd.org +(luna-define-method shimbun-mua-use-entire-index ((mua shimbun-gnus-mua)) + nnshimbun-use-entire-index) -(defun nnshimbun-netbsd-get-headers () - (let ((case-fold-search t) headers months) - (goto-char (point-min)) - (while (re-search-forward "" nil t) - (push (match-string 1) months)) - (setq months (nreverse months)) - (catch 'exit - (dolist (month months) - (erase-buffer) - (nnshimbun-retrieve-url - (format "%s%s/%s/maillist.html" nnshimbun-url nnshimbun-current-group month) - t) - (let (id url subject) - (while (re-search-forward - "]*HREF=\"\\(msg\\([0-9]+\\)\\.html\\)\">\\([^<]+\\)" - nil t) - (setq url (format "%s%s/%s/%s" - nnshimbun-url - nnshimbun-current-group - month - (match-string 1)) - id (format "<%s%05d%%%s>" - month - (string-to-number (match-string 2)) - nnshimbun-current-group) - subject (match-string 3)) - (if (nnshimbun-search-id nnshimbun-current-group id) - (throw 'exit headers) - (push (make-full-mail-header - 0 - (nnshimbun-mime-encode-string subject) - (if (looking-at " *\\([^<]+\\)<") - (nnshimbun-mime-encode-string (match-string 1)) - "") - "" id "" 0 0 url) - headers))))) - headers))) - -;;; MLs using fml -(defun nnshimbun-fml-get-headers () - (let (headers auxs aux) - (catch 'stop - (while (re-search-forward "" nil t) - (setq auxs (append auxs (list (match-string 1))))) - (while auxs - (erase-buffer) - (nnshimbun-retrieve-url - (concat nnshimbun-url (setq aux (car auxs)) "/")) - (subst-char-in-region (point-min) (point-max) ?\t ? t) - (let (id url date subject from) - (goto-char (point-min)) - (while (re-search-forward - "

  • Article .*
    Article \\([0-9]+\\) at \\([^<]*\\) Subject: \\([^<]*\\)
    From: \\([^<]*\\)
    " - nil t) - (setq url (concat nnshimbun-url aux "/" (match-string 1)) - id (format "<%s%05d%%%s>" - aux - (string-to-number (match-string 2)) - nnshimbun-current-group) - date (match-string 3) - subject (match-string 4) - from (match-string 5)) - (forward-line 1) - (if (nnshimbun-search-id nnshimbun-current-group id) - (throw 'stop headers) - (push (make-full-mail-header - 0 - (nnshimbun-mime-encode-string subject) - from date id "" 0 0 url) - headers)) - ;;(message "%s" id) - )) - (setq auxs (cdr auxs)))) - headers)) (provide 'nnshimbun) ;;; nnshimbun.el ends here. -- 1.7.10.4