X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=sidebyside;f=lisp%2Fnnshimbun.el;h=71a9e8d76b073bf1d7911756c98f77edc647b27a;hb=2635fbbcd4b8dca39a3db3ce7aec78244028f931;hp=682e370a3fc5a1812beeedcc9a91bee4ddcaa07d;hpb=1bcae209194eb578605c3e6a2e5c8bfae3d95b5e;p=elisp%2Fgnus.git-

diff --git a/lisp/nnshimbun.el b/lisp/nnshimbun.el
index 682e370..71a9e8d 100644
--- a/lisp/nnshimbun.el
+++ b/lisp/nnshimbun.el
@@ -117,6 +117,26 @@
      (contents-end   . "<!--BODYEND-->"))
     ))
 
+(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.")
 
@@ -128,7 +148,7 @@
 (defvoo nnshimbun-pre-fetch-article nil
   "*Non nil means that nnshimbun fetch unread articles when scanning groups.")
 
-;; set by nnshimbun-possibly-change-server
+;; set by nnshimbun-possibly-change-group
 (defvoo nnshimbun-buffer nil)
 (defvoo nnshimbun-current-directory nil)
 (defvoo nnshimbun-current-group nil)
@@ -274,14 +294,20 @@
 			   (set-buffer (nnshimbun-open-nov group))
 			   (and (nnheader-find-nov-line article)
 				(nnheader-parse-nov))))
-	(let ((xref (substring (mail-header-xref header) 6)))
+	(let* ((xref (substring (mail-header-xref header) 6))
+	       (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))
+	    (setq contents (funcall nnshimbun-make-contents header x-face))
 	    (nnheader-message 6 "nnshimbun: Make contents...done"))))
       (when contents
 	(save-excursion
@@ -325,6 +351,7 @@
   (nnshimbun-generate-nov-database group))
 
 (deffoo nnshimbun-close-group (group &optional server)
+  (nnshimbun-write-nov group)
   t)
 
 (deffoo nnshimbun-request-list (&optional server)
@@ -411,11 +438,7 @@
 
 (defun nnshimbun-generate-nov-database (group)
   (prog1 (funcall nnshimbun-generate-nov group)
-    (save-excursion
-      (set-buffer (nnshimbun-open-nov group))
-      (when (buffer-modified-p)
-	(nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
-			     nil 'nomesg)))))
+    (nnshimbun-write-nov group)))
 
 (defun nnshimbun-generate-nov-for-each-group (group)
   (nnshimbun-possibly-change-group group)
@@ -425,7 +448,6 @@
       (goto-char (point-max))
       (forward-line -1)
       (setq i (or (ignore-errors (read (current-buffer))) 0))
-      (goto-char (point-max))
       (dolist (header (save-excursion
 			(set-buffer nnshimbun-buffer)
 			(erase-buffer)
@@ -434,6 +456,7 @@
 			(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)))))))
@@ -452,32 +475,59 @@
 	      (goto-char (point-max))
 	      (forward-line -1)
 	      (setq i (or (ignore-errors (read (current-buffer))) 0))
-	      (goto-char (point-max))
 	      (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)))))
 
-(defun nnshimbun-search-id (group id)
+(defun nnshimbun-search-id (group id &optional nov)
   (save-excursion
     (set-buffer (nnshimbun-open-nov group))
     (goto-char (point-min))
-    (let (number found)
+    (let (found)
       (while (and (not found)
 		  (search-forward id nil t)) ; We find the ID.
 	;; And the id is in the fourth field.
 	(if (not (and (search-backward "\t" nil t 4)
 		      (not (search-backward "\t" (gnus-point-at-bol) t))))
 	    (forward-line 1)
-	  (beginning-of-line)
-	  (setq found t)
-	  ;; We return the article number.
-	  (setq number (ignore-errors (read (current-buffer))))))
-      number)))
+	  (forward-line 0)
+	  (setq found t)))
+      (unless found
+	(goto-char (point-min))
+	(when (search-forward (concat "X-Nnshimbun-Original-Id: " id) nil t)
+	  (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)) x)
+	      (when (setq x (assq 'X-Nnshimbun-Original-Id extra))
+		(setq extra (delq x extra)))
+	      (mail-header-set-extra
+	       header
+	       (cons (cons 'X-Nnshimbun-Original-Id (cdr arg)) extra)))
+	  (let ((func (intern (concat "mail-header-set-" (symbol-name (car arg))))))
+	    (if (cdr arg) (eval (list func header (cdr arg)))))))
+      (let ((xref (mail-header-xref header)))
+	(when (string-match "^Xref: " xref)
+	  (mail-header-set-xref header (substring xref 6))))
+      (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))))
@@ -499,6 +549,15 @@
       (push (cons group buffer) nnshimbun-nov-buffer-alist)
       buffer)))
 
+(defun nnshimbun-write-nov (group)
+  (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
+    (when (buffer-live-p buffer)
+      (save-excursion
+	(set-buffer buffer)
+	(buffer-modified-p)
+	(nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
+			     nil 'nomesg)))))
+
 (defun nnshimbun-save-nov ()
   (save-excursion
     (while nnshimbun-nov-buffer-alist
@@ -574,7 +633,13 @@
 	  (aref [nil "Jan" "Feb" "Mar" "Apr" "May" "Jun"
 		     "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"]
 		month)
-	  year
+	  (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)
@@ -610,7 +675,8 @@ is enclosed by at least one regexp grouping construct."
 (defun nnshimbun-fill-line ()
   (forward-line 0)
   (let ((top (point)) chr)
-    (while (if (>= (move-to-column fill-column) fill-column)
+    (while (if (>= (move-to-column nnshimbun-fill-column)
+		   nnshimbun-fill-column)
 	       (not (progn
 		      (if (memq (preceding-char) nnshimbun-kinsoku-eol-list)
 			  (progn
@@ -653,7 +719,7 @@ is enclosed by at least one regexp grouping construct."
     (delete-region (point) (point-max)))
   (insert "\n"))
 
-(defun nnshimbun-make-text-or-html-contents (header)
+(defun nnshimbun-make-text-or-html-contents (header &optional x-face)
   (let ((case-fold-search t) (html t) (start))
     (when (and (search-forward nnshimbun-contents-start nil t)
 	       (setq start (point))
@@ -665,11 +731,16 @@ is enclosed by at least one regexp grouping construct."
     (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\n")
+	    "; 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)
+(defun nnshimbun-make-html-contents (header &optional x-face)
   (let (start)
     (when (and (search-forward nnshimbun-contents-start nil t)
 	       (setq start (point))
@@ -678,7 +749,13 @@ is enclosed by at least one regexp grouping construct."
       (delete-region (- (point) (length nnshimbun-contents-end)) (point-max)))
     (goto-char (point-min))
     (nnshimbun-insert-header header)
-    (insert "Content-Type: text/html; charset=ISO-2022-JP\nMIME-Version: 1.0\n\n")
+    (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"))))
 
@@ -710,7 +787,7 @@ is enclosed by at least one regexp grouping construct."
 				(buffer-substring
 				 (match-end 0)
 				 (progn (search-forward "<br>" nil t) (point)))
-				"<[^>]+>")
+				"\\(<[^>]+>\\|\r\\)")
 			       ""))
 		   nnshimbun-from-address
 		   "" id "" 0 0 (concat nnshimbun-url url))