;;; nnshimbun.el --- interfacing with web newspapers -*- coding: junet; -*-
-;; Authors: TSUCHIYA Masatoshi <tsuchiya@pine.kuee.kyoto-u.ac.jp>
-;; Akihiro Arisawa <ari@atesoft.advantest.co.jp>
+;; Authors: TSUCHIYA Masatoshi <tsuchiya@namazu.org>,
+;; Akihiro Arisawa <ari@atesoft.advantest.co.jp>,
+;; Katsumi Yamaoka <yamaoka@jpl.org>,
+;; Yuuichi Teranishi <teranisi@gohome.org>
;; Keywords: news
;;; Copyright:
;; 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<!-- Start of kiji -->\n")
- (contents-end . "\n<!-- End of kiji -->\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<span class=\"text\">\e$B!!\e(B")
- (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<!--KIJI-->\n")
- (contents-end . "\n<!--/KIJI-->\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<!-- START_OF_BODY -->\n")
- (contents-end . "\n<!-- END_OF_BODY -->\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<!-- honbun start -->\n")
- (contents-end . "\n<!-- honbun end -->\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 . "\\(<!--BODY-->\\|<!--DATE-->\\)")
- (contents-end . "\\(<!--BODYEND-->\\|<!--BYLINEEND-->\\)"))
- ("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.")
(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 "")
(defvoo nnshimbun-backlog-articles nil)
(defvoo nnshimbun-backlog-hashtb nil)
-(defconst nnshimbun-meta-content-type-charset-regexp
- (eval-when-compile
- (concat "<meta[ \t]+http-equiv=\"?Content-type\"?[ \t]+content=\"\\([^;]+\\)"
- ";[ \t]*charset=\"?\\([^\"]+\\)\"?"
- ">"))
- "Regexp used in parsing `<META HTTP-EQUIV=\"Content-Type\" content=\"...;charset=...\">
-for a charset indication")
-
-(defconst nnshimbun-meta-charset-content-type-regexp
- (eval-when-compile
- (concat "<meta[ \t]+content=\"\\([^;]+\\)"
- ";[ \t]*charset=\"?\\([^\"]+\\)\"?"
- "[ \t]+http-equiv=\"?Content-type\"?>"))
- "Regexp used in parsing `<META content=\"...;charset=...\" HTTP-EQUIV=\"Content-Type\">
-for a charset indication")
-
-
-
;;; backlog
(defmacro nnshimbun-backlog (&rest form)
`(let ((gnus-keep-backlog nnshimbun-keep-backlog)
(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
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))
(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)"))
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))
(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))))
;;; 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)
(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)
;;; Server Initialize
+
(defun nnshimbun-possibly-change-group (group &optional server)
(when server
(unless (nnshimbun-server-opened server)
(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))
-;;; 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 "!)-_~}]:;',.?\e$B!"!#!$!%!&!'!(!)!*!+!,!-!.!/!0!1!2!3!4!5!6!7\e(B\
-\e$B!8!9!:!;!<!=!>!?!@!A!B!C!D!E!G!I!K!M!O!Q!S!U!W!Y![!k!l!m!n$!$#$%$'$)\e(B\
-\e$B$C$c$e$g$n%!%#%%%'%)%C%c%e%g%n%u%v\e(B" nil))
-
-(defconst nnshimbun-kinsoku-eol-list
- (append "({[`\e$B!F!H!J!L!N!P!R!T!V!X!Z!k!l!m!x\e(B" 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 "<p>" nil t)
- (insert "\n\n"))
- (goto-char (point-min))
- (while (search-forward "<br>" 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 "<!--X-Head-End-->" 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<!--X-" nil t)
- (replace-match "\n"))
- (goto-char (point-min))
- (while (search-forward " -->\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 "<!--")
- (delete-region (point) (progn (forward-line 1) (point))))
- ((looking-at "Subject: +")
- (push (cons 'subject (nnheader-header-value)) buf)
- (delete-region (point) (progn (forward-line 1) (point))))
- ((looking-at "From: +")
- (push (cons 'from (nnheader-header-value)) buf)
- (delete-region (point) (progn (forward-line 1) (point))))
- ((looking-at "Date: +")
- (push (cons 'date (nnheader-header-value)) buf)
- (delete-region (point) (progn (forward-line 1) (point))))
- ((looking-at "Message-Id: +")
- (push (cons 'id (concat "<" (nnheader-header-value) ">")) buf)
- (delete-region (point) (progn (forward-line 1) (point))))
- ((looking-at "Reference: +")
- (push (concat "<" (nnheader-header-value) ">") refs)
- (delete-region (point) (progn (forward-line 1) (point))))
- ((looking-at "Content-Type: ")
- (unless (search-forward "charset" (gnus-point-at-eol) t)
- (end-of-line)
- (insert "; charset=ISO-2022-JP"))
- (forward-line 1))
- (t (forward-line 1))))
- (insert "MIME-Version: 1.0\n")
- (if refs (push (cons 'references (mapconcat 'identity refs " ")) buf))
- (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))
- (delete-region
- (point)
- (progn
- (search-forward "\n<!--X-Body-of-Message-->\n" nil t)
- (point)))
- (when (search-forward "\n<!--X-Body-of-Message-End-->\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 "<SPAN CLASS=mailheaders>" nil t)
- (delete-region (point-min) (point))
- (throw 'stop nil))
- (if (search-forward "</PRE>")
- (progn
- (beginning-of-line)
- (delete-region (point) (point-max)))
- (throw 'stop nil))
- (if (search-backward "</SPAN>")
- (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 "<SPAN CLASS=\\(.*\\)>\\(.*\\)</SPAN>:"
- nil t)
- (setq field (match-string 2))
- (re-search-forward
- (concat "<SPAN CLASS=" (match-string 1) "-value>") nil t)
- (setq value-beg (point))
- (search-forward "</SPAN>" nil t)
- (setq end (point)))
- (setq value (buffer-substring value-beg
- (progn (search-backward "</SPAN>")
- (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<!-- Start of past -->\n" nil t)
- (delete-region (point-min) (point))
- (when (search-forward "\n<!-- End of past -->\n" nil t)
- (forward-line -1)
- (delete-region (point) (point-max))
- (goto-char (point-min))
- (let (headers)
- (while (re-search-forward
- "^<a href=\"\\(\\([0-9][0-9][0-9][0-9]\\)/\\([A-z]*[0-9]*\\)\\.html\\)\">[ \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 "<br>" 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 "\e$B%K%e!<%9%$%s%G%C%/%9\e(B" nil t)
- (delete-region (point-min) (point))
- (when (search-forward "\e$B%"%I%?%0\e(B" nil t)
- (forward-line 2)
- (delete-region (point) (point-max))
- (goto-char (point-min))
- (let ((case-fold-search t) headers)
- (while (re-search-forward
- "^<a href=\"/\\(\\([A-z]*\\)/kiji/\\([0-9][0-9][0-9][0-9]\\)/\\([0-9][0-9]\\)/\\([0-9][0-9]\\)/\\([0-9][0-9]\\)\\.html\\)\">"
- 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 "<br>" 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<!--*****\e$B8+=P$7\e(B*****-->\n" nil t)
- (let ((subject (buffer-substring (point) (gnus-point-at-eol)))
- (point (point)))
- (forward-line -2)
- (when (looking-at "<a href=\"/\\(News/\\([0-9][0-9][0-9][0-9]\\)/Item/\\([0-9][0-9]\\([0-9][0-9]\\)\\([0-9][0-9]\\)-[0-9]+\\).html\\)\">")
- (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
- "<a href=\"\\(%s\\|/\\)\\(news/news/\\(%s\\)/story/\\(\\([0-9][0-9][0-9][0-9]\\)\\([0-9][0-9]\\)\\([0-9][0-9]\\)[0-9]+\\)\\.html\\)\"><b>"
- (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 "</b>" 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<!-- /news/%s=start -->\n" group) nil t)
- (setq start (point))
- (search-forward (format "\n<!-- /news/%s=end -->\n" group) nil t))
- (forward-line -1)
- (save-restriction
- (narrow-to-region start (point))
- (goto-char start)
- (while (re-search-forward
- "<a href=\"/\\([0-9]+\\)/\\(\\(\\([0-9][0-9][0-9][0-9]\\)\\([0-9][0-9]\\)\\([0-9][0-9]\\)[A-z0-9]+\\)\\.htm\\)\"[^>]*>"
- 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 "<br>" nil t) (point)))
- "<[^>]+>")
- ""))
- date x)
- (when (string-match "^\e$B"!\e(B" 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)
- (setq start (- (point) 4))
- (search-forward "-->" nil t))
- (delete-region start (point))))
- (goto-char (point-min))
- (while (re-search-forward
- "<a href=\"\\(/news/\\)?\\(\\([0-9][0-9]\\)\\([0-9][0-9]\\)/\\([0-9][0-9]\\)/\\([^\\.]+\\).html\\)\"><font size=\"4\"><strong>"
- 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 "</a>" 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 "<A[^>]*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 "<EM>\\([^<]+\\)<")
- (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
- "<A[^>]*HREF=\"mail\\([0-9]+\\)\\.html\">\\[?Last Page\\]?</A>" 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 "<A HREF=\"/" nnshimbun-current-group
- "/\\([12][0-9][0-9][0-9][0-1][0-9]\\)/\">\\[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
- "<A[^>]*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 "<td><em>\\([^<]+\\)<")
- (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 "<A HREF=\"\\([0-9]+\\)/\\(threads.html\\)?\">" 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
- "<A[^>]*HREF=\"\\(msg\\([0-9]+\\)\\.html\\)\">\\([^<]+\\)</A>"
- 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 "</STRONG> *<EM>\\([^<]+\\)<")
- (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 "<a href=\"\\([0-9]+\\(\\.week\\|\\.month\\)?\\)/index.html\">" 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
- "<LI><A HREF=\"\\([0-9]+\\.html\\)\">Article .*</A> <DIV><SPAN CLASS=article>Article <SPAN CLASS=article-value>\\([0-9]+\\)</SPAN></SPAN> at <SPAN CLASS=Date-value>\\([^<]*\\)</SPAN> <SPAN CLASS=Subject>Subject: <SPAN CLASS=Subject-value>\\([^<]*\\)</SPAN></SPAN></DIV><DIV><SPAN CLASS=From>From: <SPAN CLASS=From-value>\\([^<]*\\)</SPAN></SPAN></DIV>"
- 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.
projects / elisp / gnus.git- / commitdiff