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