1;; mew-shimbun.el --- View shimbun contents with Mew
2
3;; Copyright (C) 2001-2007, 2010, 2016, 2017, 2019
4;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
5
6;; Author: TSUCHIYA Masatoshi <tsuchiya@namazu.org>
7;;         Hideyuki SHIRAI <shirai@meadowy.org>
8;; Keywords: Mew, shimbun, w3m, WWW, hypermedia
9
10;; This file is a part of emacs-w3m.
11
12;; This program is free software; you can redistribute it and/or
13;; modify it under the terms of the GNU General Public License as
14;; published by the Free Software Foundation; either version 2, or (at
15;; your option) any later version.
16
17;; This program is distributed in the hope that it will be useful, but
18;; WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
20;; General Public License for more details.
21
22;; You should have received a copy of the GNU General Public License
23;; along with this program; see the file COPYING.  If not, write to
24;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
25;; Boston, MA 02110-1301, USA.
26
27;;; Commentary:
28;; This package is `Shimbun' interface for Mew version 2.1 or later.
29
30;;; Instalation & Usage:
31;; Please read the emacs-w3m info (C-h i m emacs-w3m(-ja) RET m Mew Shimbun RET).
32;;
33
34;;; Code:
35
36(eval-and-compile
37  (require 'shimbun)
38  (require 'mew))
39
40;; Avoid byte-compile warnings,
41(declare-function mew-set-file-modes "mew-func" (path))
42(declare-function mew-biff-setup "mew-net")
43(declare-function mew-biff-clean-up "mew-net")
44(defvar mew-use-biff)
45(defvar mew-file-mode)
46(defvar mew-folder-list)
47(defvar mew-local-folder-list)
48(defvar mew-local-folder-alist)
49
50;; Variables
51(defgroup mew-shimbun nil
52  "SHIMBUN environment for Mew."
53  :group 'mew)
54
55(defcustom mew-shimbun-folder "+shimbun"
56  "The folder where SHIMBUN are contained."
57  :group 'shimbun
58  :group 'mew-shimbun
59  :type 'string)
60
61(defcustom mew-shimbun-folder-groups nil
62  "Alist of `shimbun folder name (exclude `mew-shimbun-folder')'
63and included `shimbun server.groups' and its `range parameters',
64show below example,
65  \\='((\"yomiuri\"		;; \"shimbun folder\"
66     (\"yomiuri.shakai\" . 2)	;; (\"server.group\" . range)
67     (\"yomiuri.sports\". 2)
68     (\"yomiuri.seiji\" . 2)
69     (\"yomiuri.kokusai\". 1))
70    (\"comp\"
71     (\"cnet.comp\" . last)
72     (\"zdnet.comp\" . last))
73    (\"mew/mgp\"
74     (\"mew.mgp-users\" . last)
75     (\"mew.mgp-users-jp\" . last))
76    (\"mew/mew-int\"
77     (\"mew.mew-int\" . last)))
78"
79  :group 'shimbun
80  :group 'mew-shimbun
81  :type '(repeat
82	  (cons
83	   :format "%v" :indent 2
84	   (string :format "Folder: %v")
85	   (repeat
86	    :format "%{Server.Group + Index_Checking_Range%}:\n %v%i\n"
87	    :indent 3 :sample-face underline
88	    (cons :format "%v" :indent 6
89		  (string :format "Server.Group: %v")
90		  (radio :format "Range: %v " :value all
91			 (const :format "%v " all)
92			 (const :format "%v " last)
93			 (integer :format "Pages: %v")))))))
94
95(defcustom mew-shimbun-db-file ".mew-shimbun-db"
96  "File name of mew-shimbun database."
97  :group 'shimbun
98  :group 'mew-shimbun
99  :type 'file)
100
101(defcustom mew-shimbun-expires nil
102  "Alist of `shimbun folder name' and expire days.
103Show below expire,
104  \\='((\"yomiuri\" . 7)
105    (\"comp\" . 3)
106    (\"mew/mgp\" . nil)) ;; not expire
107"
108  :group 'shimbun
109  :group 'mew-shimbun
110  :type '(repeat
111	  (cons :format "%v" :indent 11
112		(string :format "Folder: %v")
113		(integer :format "Days: %v"))))
114
115(defcustom mew-shimbun-use-expire-pack nil
116  "If non-nin, exec `pack' after expire."
117  :group 'shimbun
118  :group 'mew-shimbun
119  :type 'boolean)
120
121(defcustom mew-shimbun-db-length nil
122  "Max length of mew-shimbun database.
123If nil, same 'mew-lisp-max-length'.
124If integer, all server.group limit 'integer'.
125If alist, each cell has shimbun folder names and their max length,
126show below example,
127
128  \\='((\"mew/mgp\" . 1000)
129    (\"tcup/meadow\" . 20)
130    (\"asahi\" . 100)
131    (\"slashdot-jp/story\" . 3000)
132    (t . 2000))
133"
134  :group 'shimbun
135  :group 'mew-shimbun
136  :type '(radio
137	  (const :tag "Same as `mew-lisp-max-length'" nil)
138	  (integer :format "Limit for all groups: %v" :value 2000)
139	  (repeat :indent 4 :tag "Alist of folders and lengths"
140		  (cons :format "%v" :indent 8
141			(radio :format "%v" :value t
142			       (const :format "Other " t)
143			       (string :format "Folder: %v"))
144			(integer :format "Maximum length of database: %v"
145				 :value 2000)))))
146
147(defcustom mew-shimbun-unknown-from "foo@bar.baz"
148  "Shimbun mail address when From header is strange."
149  :group 'shimbun
150  :group 'mew-shimbun
151  :type 'string)
152
153(defcustom mew-shimbun-mark-re-retrieve mew-mark-review
154  "Shimbun re-retrieve mark."
155  :group 'shimbun
156  :group 'mew-shimbun
157  :type 'character)
158
159(defcustom mew-shimbun-mark-unseen mew-mark-unread
160  "Shimbun unseen mark."
161  :group 'shimbun
162  :group 'mew-shimbun
163  :type 'character)
164
165(defcustom mew-shimbun-use-unseen nil
166  "If non-nil, SHIMBUN folder support the 'unseen' mark."
167  :group 'shimbun
168  :group 'mew-shimbun
169  :type 'boolean)
170
171(defcustom mew-shimbun-use-unseen-cache-save nil
172  "If non-nin, save '.mew-cache' whenever remove the 'unseen' mark."
173  :group 'shimbun
174  :group 'mew-shimbun
175  :type 'boolean)
176
177(defcustom mew-shimbun-before-retrieve-hook nil
178  "Hook run after mew-shimbun-retrieve called."
179  :group 'shimbun
180  :group 'mew-shimbun
181  :type 'hook)
182
183(defcustom mew-shimbun-retrieve-hook nil
184  "Hook run after mew-shimbun-retrieve called."
185  :group 'shimbun
186  :group 'mew-shimbun
187  :type 'hook)
188
189(defconst mew-shimbun-id-format "%s+%s:%s")
190(defconst mew-shimbun-db-buffer-name " *mew-shimbun-overview*")
191(defconst mew-shimbun-article-buffer-name " *mew-shimbun-article*")
192
193(defvar mew-shimbun-unseen-regex nil)
194
195(defvar mew-shimbun-folder-regex
196  (mew-folder-regex (file-name-as-directory mew-shimbun-folder)))
197
198(defvar mew-shimbun-db nil)
199(defvar mew-shimbun-db2 nil)
200(defvar mew-shimbun-input-hist nil)
201
202;;; Macro:
203(defmacro mew-shimbun-db-search-id (id)
204  `(assoc ,id mew-shimbun-db))
205
206(defmacro mew-shimbun-db-search-id2 (id)
207  `(assoc ,id mew-shimbun-db2))
208
209(defsubst mew-shimbun-folder-p (fld)
210  (if (string-match mew-shimbun-folder-regex fld) t nil))
211
212(defvar mew-shimbun-lock-format1 "<%s@%s>")
213(defvar mew-shimbun-lock-format2 "<%s@%s:%d/%d/%d>")
214
215(defmacro mew-shimbun-element-body (sgr group server &rest body)
216  `(when (string-match "\\([^.]+\\)\\.\\(.+\\)" (car ,sgr))
217     (let ((server (match-string 1 (car ,sgr)))
218	   (group (match-string 2 (car ,sgr)))
219	   (range (cdr ,sgr)))
220       (mew-summary-lock 'shimbun
221			 (format mew-shimbun-lock-format1 ,group ,server))
222       (force-mode-line-update)
223       ,@body)))
224
225(put 'mew-shimbun-element-body 'lisp-indent-function 1)
226
227(defmacro mew-shimbun-headers (shimbun range)
228  `(let ((w3m-process-wait-discard-input t))
229     (shimbun-headers ,shimbun ,range)))
230
231(defmacro mew-shimbun-article (shimbun head)
232  `(let ((w3m-process-wait-discard-input t))
233     (shimbun-article ,shimbun ,head)))
234
235(defsubst mew-shimbun-mode-display (group server get count sum)
236  (mew-summary-lock
237   'shimbun (format mew-shimbun-lock-format2 group server get count sum))
238  (force-mode-line-update))
239
240(defalias 'mew-shimbun-visit-folder 'mew-summary-visit-folder)
241
242(defun mew-shimbun-unseen-regex ()
243  (setq mew-shimbun-unseen-regex
244	(concat "^" (regexp-quote (string mew-shimbun-mark-unseen)))))
245
246(defun mew-shimbun-set-form (fld)
247  (unless (mew-sinfo-get-summary-form)
248    (mew-sinfo-set-summary-form (mew-get-summary-form fld))))
249
250(defalias 'mew-shimbun-folder-file 'mew-expand-file)
251
252(defalias 'mew-shimbun-expand-msg 'mew-expand-msg)
253
254;;; Main:
255;;;###autoload
256(defun mew-shimbun-goto-unseen-folder ()
257  "Goto folder for SHIMBUN to have a few new messages."
258  (interactive)
259  (mew-shimbun-goto-folder t))
260
261;;;###autoload
262(defun mew-shimbun-goto-folder (&optional args)
263  "Goto folder for SHIMBUN.
264If called with '\\[universal-argument]', goto folder to have a few new messages."
265  (interactive "P")
266  (let ((flds (mapcar #'car mew-local-folder-alist))
267	sbflds alst fld cfile removes)
268    (save-excursion
269      (dolist (fld flds)
270	(when (and (mew-shimbun-folder-p fld)
271		   (file-exists-p
272		    (expand-file-name mew-shimbun-db-file
273				      (mew-expand-folder fld))))
274	  (when (string-match "/\\'" fld)
275	    (setq removes (cons (substring fld 0 (match-beginning 0)) removes)))
276	  (if (null args)
277	      (setq sbflds (cons fld sbflds))
278	    (if (mew-shimbun-folder-new-p fld)
279		(setq sbflds (cons fld sbflds))
280	      (if (get-buffer fld)
281		  (with-current-buffer fld
282		    (goto-char (point-min))
283		    (when (re-search-forward (or mew-shimbun-unseen-regex
284						 (mew-shimbun-unseen-regex))
285					     nil t)
286		      (setq sbflds (cons fld sbflds))))
287		(setq cfile (mew-shimbun-folder-file
288			     fld mew-summary-cache-file))
289		(when (file-readable-p cfile)
290		  (with-temp-buffer
291		    (mew-frwlet
292			mew-cs-text-for-read mew-cs-dummy
293		      (insert-file-contents cfile nil)
294		      (goto-char (point-min))
295		      (when (re-search-forward (or mew-shimbun-unseen-regex
296						   (mew-shimbun-unseen-regex))
297					       nil t)
298			(setq sbflds (cons fld sbflds))))))))))))
299    (mapc (lambda (x)
300	    (unless (member x removes)
301	      (setq alst (cons (list x) alst))))
302	  sbflds)
303    (let ((completion-ignore-case mew-complete-folder-ignore-case))
304      (setq fld (completing-read
305		 (if args
306		     "Shimbun UNREAD folder: "
307		   "Shimbun folder: ")
308		 alst
309		 nil t (file-name-as-directory mew-shimbun-folder)
310		 'mew-shimbun-input-hist)))
311    (when (string-match "[*%]\\'" fld)
312      (setq fld (substring fld 0 (match-beginning 0)))
313      (setcar mew-shimbun-input-hist fld))
314    (setq mew-input-folder-hist (cons fld mew-input-folder-hist))
315    (let ((newfld (mew-summary-switch-to-folder (directory-file-name fld))))
316      (mew-summary-ls newfld newfld))))
317
318;;;###autoload
319(defun mew-shimbun-retrieve (&optional newfld)
320  "Retrieve articles via SHIMBUN on this folder."
321  (interactive)
322  (when (mew-summary-exclusive-p)
323    (mew-summary-only
324     (let ((fld (mew-summary-folder-name 'ext))
325	   (mua (luna-make-entity 'shimbun-mew-mua))
326	   (count 0)
327	   alst server group range)
328       (if (not (mew-shimbun-folder-p fld))
329	   (message "This command can not execute here")
330	 (setq alst (assoc (substring fld (match-end 0))
331			   mew-shimbun-folder-groups))
332	 (if (null alst)
333	     (message "%s is not include 'mew-shimbun-folder-groups'" fld)
334	   (run-hooks 'mew-shimbun-before-retrieve-hook)
335	   (mew-window-configure 'summary)
336	   (mew-current-set nil nil nil)
337	   (mew-decode-syntax-delete)
338	   (mew-shimbun-set-form fld)
339	   (save-excursion
340	     (dolist (sgr (cdr alst))
341	       (mew-shimbun-element-body
342		sgr group server
343		(setq count
344		      (+ (mew-shimbun-retrieve-article
345			  mua server group range fld newfld)
346			 count)))))
347	   (run-hooks 'mew-shimbun-retrieve-hook)
348	   (message "Getting %s %s in '%s' done"
349		    (if (= count 0) "no" (number-to-string count))
350		    (if (> count 1) "messages" "message")
351		    fld)
352	   (when (> count 0)
353	     (mew-summary-folder-cache-save))))))))
354
355;;;###autoload
356(defun mew-shimbun-retrieve-all ()
357  "Retrieve all articles via SHIMBUN."
358  (interactive)
359  (mew-summary-only
360   (let ((mua (luna-make-entity 'shimbun-mew-mua))
361	 (cfld (mew-summary-folder-name 'ext))
362	 fld dir server group range newfld)
363     (run-hooks 'mew-shimbun-before-retrieve-hook)
364     (mew-window-configure 'summary)
365     (mew-current-set nil nil nil)
366     (mew-decode-syntax-delete)
367     (save-excursion
368       (dolist (fldgrp mew-shimbun-folder-groups)
369	 (setq fld (concat (file-name-as-directory mew-shimbun-folder)
370			   (car fldgrp)))
371	 (setq dir (mew-expand-folder fld))
372	 (unless (file-directory-p dir)
373	   (mew-make-directory dir)
374	   (setq newfld t))
375	 (mew-shimbun-visit-folder fld)
376	 (sit-for 0.5)
377	 (mew-rendezvous mew-summary-buffer-process)
378	 (mew-shimbun-retrieve newfld)
379	 (unless (eq (get-buffer cfld) (current-buffer))
380	   (mew-kill-buffer (current-buffer)))))
381     (mew-shimbun-visit-folder cfld)
382     (message "Getting done"))))
383
384(defun mew-shimbun-retrieve-article (mua server group range fld &optional newfld)
385  "Retrieve articles via SHIMBUN."
386  (luna-define-method shimbun-mua-search-id ((mua shimbun-mew-mua) id)
387    (let ((shimbun (shimbun-mua-shimbun mua)))
388      (mew-shimbun-db-search-id
389       (format mew-shimbun-id-format
390	       (shimbun-server shimbun)
391	       (shimbun-current-group shimbun)
392	       id))))
393  (let ((shimbun (shimbun-open server mua))
394	(biff mew-use-biff)
395	(count 0)
396	(dispcount 0)
397	msg file)
398    (if biff (mew-biff-clean-up))
399    (shimbun-open-group shimbun group)
400    (unless (file-exists-p (mew-expand-folder fld))
401      (setq newfld t)
402      (mew-make-directory (mew-expand-folder fld)))
403    (mew-shimbun-db-setup fld)
404    (unwind-protect
405	(let* ((headers (mew-shimbun-headers shimbun range))
406	       (sum (length headers)))
407	  (setq headers
408		(sort headers
409		      (lambda (x y)
410			(string< (mew-time-rfc-to-sortkey (or (elt x 3) ""))
411				 (mew-time-rfc-to-sortkey (or (elt y 3) ""))))))
412	  (dolist (head headers)
413	    (let ((id (format mew-shimbun-id-format
414			      server group
415			      (shimbun-header-id head)))
416		  buf md5)
417	      (unless (mew-shimbun-db-search-id id)
418		(setq buf (get-buffer-create mew-shimbun-article-buffer-name))
419		(with-current-buffer buf
420		  (mew-erase-buffer)
421		  (set-buffer-multibyte nil)
422		  (mew-shimbun-article shimbun head)
423		  (setq md5 (mew-shimbun-md5))
424		  (when (and (> (buffer-size) 0)
425			     (mew-shimbun-db-add-id id md5))
426		    (setq count (1+ count))
427		    (goto-char (point-min))
428		    (insert (format "X-Shimbun-Id: %s\n" id))
429		    (mew-shimbun-sanity-convert)
430		    (setq msg (mew-folder-new-message fld 'numonly))
431		    (setq file (mew-shimbun-expand-msg fld msg))
432		    (mew-frwlet
433			mew-cs-dummy mew-cs-text-for-write
434		      (write-region (point-min) (point-max) file nil 'nomsg))
435		    (mew-set-file-modes file)
436		    (mew-shimbun-scan-message fld msg)))
437		(kill-buffer buf))
438	      (setq dispcount (1+ dispcount))
439	      (mew-shimbun-mode-display group server count dispcount sum))))
440      (mew-summary-unlock)
441      (when newfld
442	(mew-local-folder-insert fld))
443      (if biff (mew-biff-setup))
444      (shimbun-close-group shimbun)
445      (shimbun-close shimbun)
446      (mew-shimbun-db-shutdown fld count))
447    count))
448
449;;;###autoload
450(defun mew-shimbun-re-retrieve (&optional args)
451  "Re-retrieve this message.
452If called with '\\[universal-argument]', re-retrieve messages marked with
453'mew-shimbun-mark-re-retrieve'."
454  (interactive "P")
455  (when (mew-summary-exclusive-p)
456    (mew-summary-only
457     (let* ((fld (mew-summary-folder-name 'ext))
458	    (msgs (list (progn (mew-summary-goto-message)
459			       (mew-summary-message-number))))
460	    (mua (luna-make-entity 'shimbun-mew-mua))
461	    (newcount 0) (rplcount 0) (same 0)
462	    countlst id-msgs alst server group range)
463       (if (not (mew-shimbun-folder-p fld))
464	   (message "This command can not execute here")
465	 (setq alst (assoc (substring fld (match-end 0))
466			   mew-shimbun-folder-groups))
467	 (if (null alst)
468	     (message "%s is not include 'mew-shimbun-folder-groups'" fld)
469	   (run-hooks 'mew-shimbun-before-retrieve-hook)
470	   (mew-window-configure 'summary)
471	   (mew-current-set nil nil nil)
472	   (mew-decode-syntax-delete)
473	   (mew-shimbun-set-form fld)
474	   (when args
475	     (setq msgs (mew-summary-mark-collect
476			 mew-shimbun-mark-re-retrieve)))
477	   (if (null msgs)
478	       (message "No message re-retrieve.")
479	     (setq id-msgs (mew-shimbun-get-id-msgs 'list fld msgs))
480	     (if id-msgs
481		 (save-excursion
482		   (dolist (sgr (cdr alst))
483		     (mew-shimbun-element-body
484		      sgr group server
485		      (setq countlst
486			    (mew-shimbun-re-retrieve-article
487			     mua server group range fld id-msgs))
488		      (setq rplcount (+ rplcount (nth 0 countlst)))
489		      (setq newcount (+ newcount (nth 1 countlst)))
490		      (setq same (+ same (nth 2 countlst)))))
491		   (message "Replace %s, new %s, same %s messages in '%s' done"
492			    rplcount newcount same fld)
493		   (when (> (+ newcount rplcount) 0)
494		     (mew-summary-folder-cache-save)))
495	       (message "No detect 'X-Shimbun-Id:'"))
496	     (run-hooks 'mew-shimbun-retrieve-hook))))))))
497
498;;;###autoload
499(defun mew-shimbun-re-retrieve-all (&optional arg)
500  "Re-retrieve all messages in this folder.
501If called with '\\[universal-argument]', re-retrieve messages in the region."
502  (interactive "P")
503  (when (mew-summary-exclusive-p)
504    (mew-summary-only
505     (let* ((fld (mew-summary-folder-name 'ext))
506	    (mua (luna-make-entity 'shimbun-mew-mua))
507	    (begend (cons (point-min) (point-max)))
508	    (newcount 0) (rplcount 0) (same 0)
509	    countlst id-msgs begmsg endmsg alst server group range)
510       (if (not (mew-shimbun-folder-p fld))
511	   (message "This command can not execute here")
512	 (setq alst (assoc (substring fld (match-end 0))
513			   mew-shimbun-folder-groups))
514	 (if (null alst)
515	     (message "%s is not include 'mew-shimbun-folder-groups'" fld)
516	   (when arg
517	     (setq begend (mew-summary-get-region)))
518	   (save-excursion
519	     (save-restriction
520	       (narrow-to-region (car begend) (cdr begend))
521	       (goto-char (point-min))
522	       (mew-summary-goto-message)
523	       (setq begmsg (mew-summary-message-number))
524	       (goto-char (point-max))
525	       (mew-summary-goto-message)
526	       (setq endmsg (mew-summary-message-number))))
527	   (setq id-msgs (mew-shimbun-get-id-msgs 'range fld begmsg endmsg))
528	   (mew-shimbun-set-form fld)
529	   (mew-window-configure 'summary)
530	   (mew-current-set nil nil nil)
531	   (mew-decode-syntax-delete)
532	   (run-hooks 'mew-shimbun-before-retrieve-hook)
533	   (if id-msgs
534	       (save-excursion
535		 (dolist (sgr (cdr alst))
536		   (mew-shimbun-element-body
537		    sgr group server
538		    (setq countlst
539			  (mew-shimbun-re-retrieve-article
540			   mua server group range fld id-msgs))
541		    (setq rplcount (+ rplcount (nth 0 countlst)))
542		    (setq newcount (+ newcount (nth 1 countlst)))
543		    (setq same (+ same (nth 2 countlst)))))
544		 (message "Replace %s, new %s, same %s messages in '%s' done"
545			  rplcount newcount same fld)
546		 (when (> (+ newcount rplcount) 0)
547		   (mew-summary-folder-cache-save)))
548	     (message "No detect 'X-Shimbun-Id:'"))
549	   (run-hooks 'mew-shimbun-retrieve-hook)))))))
550
551(defun mew-shimbun-re-retrieve-article (mua server group range fld id-msgs)
552  "Re-retrieve articles via SHIMBUN."
553  (luna-define-method shimbun-mua-search-id ((mua shimbun-mew-mua) id)
554    (let ((shimbun (shimbun-mua-shimbun mua)))
555      (mew-shimbun-db-search-id2
556       (format mew-shimbun-id-format
557	       (shimbun-server shimbun)
558	       (shimbun-current-group shimbun)
559	       id))))
560  (let ((shimbun (shimbun-open server mua))
561	(biff mew-use-biff)
562	(newcount 0) (rplcount 0) (same 0) (dispcount 0))
563    (if biff (mew-biff-clean-up))
564    (shimbun-open-group shimbun group)
565    (mew-shimbun-db-setup2 fld id-msgs)
566    (unwind-protect
567	(let* ((headers (mew-shimbun-headers shimbun range))
568	       (sum (length headers)))
569	  (setq headers
570		(sort headers
571		      (lambda (x y)
572			(string< (mew-time-rfc-to-sortkey (or (elt x 3) ""))
573				 (mew-time-rfc-to-sortkey (or (elt y 3) ""))))))
574	  (dolist (head headers)
575	    (let ((newid (format mew-shimbun-id-format
576				 server group
577				 (shimbun-header-id head)))
578		  newmd5 oldmd5
579		  buf alst msg file)
580	      (unless (mew-shimbun-db-search-id2 newid)
581		(if (setq alst (assoc newid id-msgs))
582		    ;; message replace?
583		    (progn
584		      (setq rplcount (1+ rplcount))
585		      (setq msg (cdr alst))
586		      (setq oldmd5 (cdr (mew-shimbun-db-search-id newid))))
587		  ;; new message
588		  (setq newcount (1+ newcount))
589		  (setq msg (mew-folder-new-message fld 'numonly))
590		  (setq oldmd5 nil))
591		(setq file (mew-shimbun-expand-msg fld msg))
592		(setq buf (get-buffer-create mew-shimbun-article-buffer-name))
593		(with-current-buffer buf
594		  (mew-erase-buffer)
595		  (set-buffer-multibyte nil)
596		  (mew-shimbun-article shimbun head)
597		  (when (> (buffer-size) 0)
598		    (setq newmd5 (mew-shimbun-md5))
599		    (if (and (stringp oldmd5) (string= oldmd5 newmd5))
600			;; same message
601			(setq rplcount (1- rplcount) same (1+ same))
602		      (mew-shimbun-db-add-id newid newmd5 (stringp oldmd5))
603		      (goto-char (point-min))
604		      (insert (format "X-Shimbun-Id: %s\n" newid))
605		      (mew-shimbun-sanity-convert)
606		      (mew-frwlet
607			  mew-cs-dummy mew-cs-text-for-write
608			(write-region (point-min) (point-max) file nil 'nomsg))
609		      (mew-set-file-modes file)
610		      (mew-shimbun-scan-message fld msg))))
611		(kill-buffer buf))
612	      (setq dispcount (1+ dispcount))
613	      (mew-shimbun-mode-display group server
614					(+ newcount rplcount) dispcount sum))))
615      (mew-summary-unlock)
616      (if biff (mew-biff-setup))
617      (shimbun-close-group shimbun)
618      (shimbun-close shimbun)
619      (mew-shimbun-db-shutdown2 fld (+ newcount rplcount)))
620    (list rplcount newcount same)))
621
622;;;###autoload
623(defun mew-shimbun-expire-all ()
624  "Expire all shimbun folder."
625  (interactive)
626  (let ((cfld (mew-summary-folder-name 'ext)) fld)
627    (dolist (alst mew-shimbun-expires)
628      (setq fld (concat (file-name-as-directory mew-shimbun-folder)
629			(car alst)))
630      (when (and (file-directory-p (mew-expand-folder fld))
631		 (file-exists-p (expand-file-name mew-shimbun-db-file
632						  (mew-expand-folder fld))))
633	(mew-shimbun-visit-folder fld)
634	(sit-for 0.5)
635	(mew-rendezvous mew-summary-buffer-process)
636	(mew-shimbun-expire)
637	(unless (eq (get-buffer cfld) (current-buffer))
638	  (mew-kill-buffer (current-buffer)))))
639    (mew-shimbun-visit-folder cfld)))
640
641(defun mew-shimbun-pick (&rest args)
642  (apply 'call-process mew-prog-mewl nil t nil args))
643
644(defun mew-shimbun-jump-msg (msg)
645  (re-search-forward (format "\r  %s " msg) nil t))
646
647;;;###autoload
648(defun mew-shimbun-expire ()
649  "Expire this shimbun folder."
650  (interactive)
651  (when (mew-summary-exclusive-p)
652    (mew-summary-only
653     (let* ((fld (mew-summary-folder-name 'ext))
654	    (days (mew-shimbun-expire-day fld))
655	    (i 0)
656	    file msgs msg-alist begmsg endmsg t1)
657       (if (not (mew-shimbun-folder-p fld))
658	   (message "This command can not execute here")
659	 (if (not days)
660	     (message "%s does not have an expire rule." fld)
661	   (mew-decode-syntax-delete)
662	   (message "Gathering date header in %s..." fld)
663	   (save-excursion
664	     (save-restriction
665	       (widen)
666	       (goto-char (point-min))
667	       (mew-summary-goto-message)
668	       (setq begmsg (mew-summary-message-number))
669	       (goto-char (point-max))
670	       (mew-summary-goto-message)
671	       (setq endmsg (mew-summary-message-number))
672	       (with-temp-buffer
673		 (mew-piolet
674		     mew-cs-text-for-read mew-cs-text-for-write
675		   (mew-shimbun-pick "-b" mew-mail-path
676				     "-d" "Date:"
677				     "-s" (format "%s %s-%s"
678						  fld begmsg endmsg))
679		   (goto-char (point-min))
680		   (while (not (eobp))
681		     (when (looking-at "^\\([1-9][0-9]*\\): *\\([^\n]+\\)$")
682		       (setq msg-alist
683			     (cons
684			      (cons (match-string 1)
685				    (mew-time-rfc-to-sortkey (match-string 2)))
686			      msg-alist)))
687		     (forward-line 1))))
688	       (setq t1 (decode-time (current-time)))
689	       (setq t1 (append (list (nth 0 t1) (nth 1 t1) (nth 2 t1)
690				      (- (nth 3 t1) days))
691				(nthcdr 4 t1)))
692	       (setq days (format-time-string "%Y%m%d%H%M%S"
693					      (apply 'encode-time t1)))
694	       (dolist (x msg-alist)
695		 (when (string< (cdr x) days)
696		   (setq msgs (cons (car x) msgs))))
697	       (setq msgs
698		     (sort msgs
699			   (lambda (x y)
700			     (< (string-to-number x) (string-to-number y)))))
701	       (setq t1 (length msgs))
702	       (if (zerop t1)
703		   (message "No expire (%s)" fld)
704		 (message "Expire (%s) 1/%d..." fld t1)
705		 (goto-char (point-min))
706		 (dolist (msg msgs)
707		   (setq i (1+ i))
708		   (when (zerop (% i 10))
709		     (message "Expire (%s) %d/%d..." fld i t1))
710		   (when (mew-shimbun-jump-msg msg)
711		     (beginning-of-line)
712		     (mew-elet
713		      (delete-region (point)
714				     (progn (forward-line) (point)))))
715		   (setq file (mew-shimbun-expand-msg fld msg))
716		   (when (and (file-exists-p file)
717			      (file-readable-p file)
718			      (file-writable-p file))
719		     (delete-file file)))
720		 (mew-elet
721		  (mew-summary-folder-cache-save)
722		  (set-buffer-modified-p nil))
723		 (when (and mew-shimbun-use-expire-pack
724			    (> t1 0))
725		   (mew-summary-pack-body fld))
726		 (message "Expire (%s) %d/%d...done" fld t1 t1))))))))))
727
728(defun mew-shimbun-expire-day (fld)
729  (catch 'det
730    (dolist (x mew-shimbun-expires)
731      (when (string-match (concat "\\`"
732				  (regexp-quote
733				   (concat
734				    (file-name-as-directory mew-shimbun-folder)
735				    (car x))))
736			  fld)
737	(throw 'det (cdr x))))))
738
739(defun mew-shimbun-get-id-msgs (type &rest args)
740  (let (id-msgs)
741    (cond
742     ((eq type 'list)
743      ;; folder msgs
744      (with-temp-buffer
745	(dolist (msg (car (cdr args)))
746	  (erase-buffer)
747	  (mew-insert-message (car args) msg mew-cs-text-for-read 512)
748	  (goto-char (point-min))
749	  (when (re-search-forward "^X-Shimbun-Id: \\(.+\\)\n" nil t)
750	    (setq id-msgs (cons (cons (match-string 1) msg) id-msgs)))))
751      (nreverse id-msgs))
752     ((eq type 'range)
753      ;; folder begin-message end-message
754      (with-temp-buffer
755	(mew-piolet
756	    mew-cs-text-for-read mew-cs-text-for-write
757	  (mew-shimbun-pick
758	   "-b" mew-mail-path
759	   "-d" "X-Shimbun-Id:"
760	   "-s" (format "%s %s-%s" (nth 0 args) (nth 1 args) (nth 2 args))))
761	(goto-char (point-min))
762	(while (re-search-forward "^\\([1-9][0-9]*\\): \\([^\n]+\\)" nil t)
763	  (setq id-msgs
764		(cons (cons (match-string 2) (match-string 1)) id-msgs))))
765      (nreverse id-msgs))
766     ;; something error
767     (t nil))))
768
769;;; Mew interface funcitions:
770(defun mew-shimbun-scan-message (fld msg)
771  (set-buffer-multibyte t)
772  (let ((width (1- (mew-scan-width)))
773	(vec (mew-scan-header)))
774    (mew-scan-set-folder vec fld)
775    (mew-scan-set-message vec msg)
776    (set-buffer-multibyte nil)
777    (mew-scan-insert-line fld vec width msg nil)
778    (when mew-shimbun-use-unseen
779      ;; xxxxx more fast
780      (with-current-buffer fld
781	(goto-char (point-min))
782	(when (mew-shimbun-jump-msg msg)
783	  (mew-mark-put-mark mew-shimbun-mark-unseen 'nomsg))
784	(forward-line)))
785    ;; for summary redraw
786    (sit-for 0.01)))
787
788(defun mew-shimbun-sanity-convert ()
789  (if (re-search-forward mew-eoh nil t)
790      (beginning-of-line)
791    (goto-char (point-max))
792    (insert "\n"))
793  (save-restriction
794    (let ((case-fold-search t)
795	  (unknown-from mew-shimbun-unknown-from)
796	  beg end from from13)
797      (narrow-to-region (point-min) (point))
798      (goto-char (point-min))
799      (if (not (re-search-forward mew-from: nil t))
800	  ;; No From:
801	  (progn
802	    (goto-char (point-max))
803	    (insert (concat mew-from: " " unknown-from "\n")))
804	(setq beg (match-end 0))
805	(forward-line)
806	(mew-header-goto-next)
807	(setq end (1- (point)))
808	(setq from (or (buffer-substring beg end) ""))
809	(setq from (or (mew-addrstr-parse-address from) ""))
810	(unless (string-match "\
811\\`[-A-Za-z0-9._!%]+@[A-Za-z0-9][-A-Za-z0-9._!]+[A-Za-z0-9]\\'"
812			      from)
813	  ;; strange From:
814	  (goto-char (point-min))
815	  (when (re-search-forward "^From-R13:" nil t)
816	    ;; From-R13:
817	    (setq beg (match-end 0))
818	    (forward-line)
819	    (mew-header-goto-next)
820	    (setq from13 (buffer-substring beg (1- (point))))
821	    (when (setq from13 (mew-shimbun-sanity-convert-rot13 from13))
822	      (setq unknown-from from13)))
823	  (goto-char end)
824	  (insert " <" unknown-from ">"))))))
825
826(defun mew-shimbun-sanity-convert-rot13 (from13)
827  (with-temp-buffer
828    (insert from13)
829    ;; from13 is binary
830    (mew-cs-decode-region (point-min) (point-max) mew-cs-autoconv)
831    (goto-char (point-min))
832    ;; Extent rot14(@,A-Z,[) + rot13(a-z)
833    (while (< (point) (point-max))
834      (let* ((chr (char-after (point))))
835	(cond
836	 ((and (<= ?@ chr) (<= chr ?\[))
837	  (setq chr (+ chr 14))
838	  (when (> chr ?\[) (setq chr (- chr 28)))
839	  (delete-char 1)
840	  (insert chr))
841	 ((and (<= ?a chr) (<= chr ?z))
842	  (setq chr (+ chr 13))
843	  (when (> chr ?z) (setq chr (- chr 26)))
844	  (delete-char 1)
845	  (insert chr))
846	 (t (forward-char)))))
847    (setq from13 (buffer-substring (point-min) (point-max)))
848    (mew-addrstr-parse-address from13)))
849
850;;; Message-ID database:
851(defun mew-shimbun-db-setup (fld)
852  (setq mew-shimbun-db
853	(mew-lisp-load
854	 (expand-file-name mew-shimbun-db-file
855			   (mew-expand-folder fld)))))
856
857(defun mew-shimbun-db-setup2 (fld id-msgs)
858  (mew-shimbun-db-setup fld)
859  (setq mew-shimbun-db2 (copy-sequence mew-shimbun-db))
860  (dolist (x id-msgs)
861    (setq mew-shimbun-db2
862	  (delq (assoc (car x) mew-shimbun-db2)
863		mew-shimbun-db2))))
864
865(defun mew-shimbun-db-shutdown (fld count)
866  (when (> count 0)
867    (let ((mew-lisp-max-length (mew-shimbun-db-length fld)))
868      (mew-lisp-save
869       (expand-file-name mew-shimbun-db-file (mew-expand-folder fld))
870       mew-shimbun-db)
871      (mew-touch-folder fld)))
872  (setq mew-shimbun-db nil))
873
874(defun mew-shimbun-db-shutdown2 (fld count)
875  (mew-shimbun-db-shutdown fld count)
876  (setq mew-shimbun-db2 nil))
877
878(defun mew-shimbun-db-add-id (id md5 &optional replace)
879  (let ((alist (mew-shimbun-db-search-id id)))
880    (if (null alist)
881	;; new
882	(setq mew-shimbun-db (cons (cons id md5) mew-shimbun-db))
883      (when replace
884	;; replace
885	(setq mew-shimbun-db
886	      (cons (cons id md5) (delq alist mew-shimbun-db)))))))
887
888(defun mew-shimbun-db-length (fld)
889  (cond
890   ((null mew-shimbun-db-length)
891    mew-lisp-max-length)
892   ((numberp mew-shimbun-db-length)
893    mew-shimbun-db-length)
894   (t
895    (catch 'det
896      (dolist (x mew-shimbun-db-length)
897	(when (and (stringp (car x))
898		   (string-match
899		    (concat "\\`" (regexp-quote
900				   (concat
901				    (file-name-as-directory mew-shimbun-folder)
902				    (car x))))
903		    fld))
904	  (throw 'det (cdr x))))
905      (or (cdr (assq t mew-shimbun-db-length))
906	  mew-lisp-max-length)))))
907
908(luna-define-class shimbun-mew-mua (shimbun-mua) ())
909
910;;; Misc
911(defun mew-shimbun-md5 ()
912  "Calculate MD5 with boundary remove."
913  (let ((str (mew-buffer-substring
914	      (point-min)
915	      (min (point-max) (+ (point-min) 6144)))) ;; (* 4096 1.5)
916	(case-fold-search nil)
917	beg)
918    (with-temp-buffer
919      (insert str)
920      (goto-char (point-min))
921      ;; boundary include current-time()
922      (while (re-search-forward "===shimbun_[0-9]+_[0-9]+_[0-9]+===" nil t)
923	(replace-match ""))
924      (goto-char (point-min))
925      ;; delete X-Face:
926      (when (re-search-forward "^X-Face:" nil t)
927	(beginning-of-line)
928	(setq beg (point))
929	(forward-line)
930	(mew-header-goto-next)
931	(delete-region beg (point)))
932      (md5 (encode-coding-string
933	    (mew-buffer-substring (point-min)
934				  (min (point-max) (+ (point-min) 4096)))
935	    'utf-8-emacs)
936	   nil nil 'binary))))
937
938(defvar mew-shimbun-touch-folder-p t)
939
940(defun mew-shimbun-folder-new-p (fld)
941  (let* ((dir (file-chase-links (mew-expand-folder fld)))
942	 (tdir (mew-file-get-time
943		(expand-file-name mew-summary-touch-file
944				  (mew-expand-folder dir))))
945	 (cache (expand-file-name mew-summary-cache-file dir))
946	 (tcache (mew-file-get-time cache)))
947    (cond
948     ((null tdir) nil)
949     ((null tcache) t) ;; do update
950     ((> (nth 0 tdir) (nth 0 tcache)) t)
951     ((= (nth 0 tdir) (nth 0 tcache))
952      (if (> (nth 1 tdir) (nth 1 tcache)) t nil))
953     (t nil))))
954
955;;; Unseen
956(defun mew-shimbun-unseen-remove-advice ()
957  "Remove 'unseen' mark."
958  (let ((fld (mew-summary-folder-name)))
959    (when (mew-shimbun-folder-p fld)
960      (let* ((vfld (mew-summary-folder-name 'ext))
961	     (msg (mew-summary-message-number))
962	     (part (mew-syntax-nums)))
963	(when (and fld msg (null part))
964	  (save-excursion
965	    (beginning-of-line)
966	    (when (looking-at (or mew-shimbun-unseen-regex
967				  (mew-shimbun-unseen-regex)))
968	      ;; in normal or thread folder
969	      (mew-mark-unmark)
970	      (set-buffer-modified-p nil)
971	      (when (and (not (string= fld vfld)) (get-buffer fld))
972		;; thread => normal shimbun folder
973		(mew-summary-unmark-in-physical fld msg)))))))))
974
975(defun mew-shimbun-unseen-setup ()
976  "`Shimbun unseen mark' support advices."
977  (interactive)
978  (when (and mew-shimbun-use-unseen mew-shimbun-use-unseen-cache-save)
979    ;; "C-cC-q"
980    (defadvice mew-kill-buffer (before shimbun-cache-save activate)
981      (let* ((buf (or buf (current-buffer)))
982	     (fld (if (bufferp buf) (buffer-name buf) buf)))
983	(when (and (get-buffer buf) (mew-shimbun-folder-p fld))
984	  (with-current-buffer buf
985	    (unless (mew-summary-folder-dir-newp)
986	      (mew-summary-folder-cache-save))))))
987
988    ;; "Q" or exit Emacs
989    (defadvice mew-mark-clean-up (before shimbun-cache-save activate)
990      (save-current-buffer
991	(dolist (fld mew-buffers)
992	  (when (and (get-buffer fld) (mew-shimbun-folder-p fld))
993	    (set-buffer fld)
994	    (unless (mew-summary-folder-dir-newp)
995	      (mew-summary-folder-cache-save))))))
996    ))
997
998;;; unseen setup
999(when mew-shimbun-use-unseen
1000  (mew-shimbun-unseen-setup))
1001
1002(provide 'mew-shimbun)
1003
1004;;; mew-shimbun.el ends here
1005