cgit.sxemacs.org Git - packages/blob - xemacs-packages/mew/mew/mew-refile.el

   1 ;;; mew-refile.el --- Refile for Mew
   2
   3 ;; Author:  Yoshinari NOMURA <nom@csce.kyushu-u.ac.jp>
   4 ;;          Kazu Yamamoto <Kazu@Mew.org>
   5 ;; Created: Jun 11, 1994
   6 ;; Revised: Aug 30, 1999
   7
   8 ;;; Code:
   9
  10 (defconst mew-refile-version "mew-refile.el version 0.76")
  11
  12 (require 'mew)
  13
  14 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  15 ;;;
  16 ;;; Variables
  17 ;;;
  18
  19 (defvar mew-refile-msgid-alist nil
  20   "Alist of message-id and folder pair")
  21 (defvar mew-refile-msgid-file-name ".mew-refile-msgid-alist")
  22 (defvar mew-refile-from-alist nil
  23   "Alist of From: address and folder pair")
  24 (defvar mew-refile-from-file-name ".mew-refile-from-alist")
  25
  26 (defvar mew-refile-last-folder nil
  27   "Folder name previously you refiled")
  28
  29 (defvar mew-refile-ctrl-multi t
  30   "*If *non-nil*, guess functions guess multi folders.")
  31
  32 (defvar mew-refile-guess-alist nil
  33   "*If non-nil, mew guesses destination folder by using this hint.
  34 The format is like this:
  35
  36     (setq mew-refile-guess-alist
  37           '((\"To:\"
  38               (\"wide@wide\" . \"+wide/wide\")
  39               (\"adam\"      . \"+labo/adam\"))
  40             (\"Newsgroups:\"
  41               (\"^nifty\\\\.\\\\([^ ]+\\\\)\" . \"+Nifty/\\\\1\"))
  42             (\"From:\"
  43               (\"uucp\" . \"+adm/uucp\")
  44               (\".*\"   . \"+misc\"))
  45             ))
  46 ")
  47
  48 (defvar mew-refile-guess-key-list mew-destination:-list
  49   "*A list of field key used by mew-refile-guess-by-folder.")
  50
  51 (defvar mew-refile-guess-control
  52   '(mew-refile-guess-by-alist
  53     mew-refile-ctrl-throw
  54     mew-refile-guess-by-newsgroups
  55     mew-refile-guess-by-folder
  56     mew-refile-ctrl-throw
  57     mew-refile-ctrl-auto-boundary
  58     mew-refile-guess-by-thread
  59     mew-refile-ctrl-throw
  60     mew-refile-guess-by-from-folder
  61     mew-refile-ctrl-throw
  62     mew-refile-guess-by-from
  63     mew-refile-ctrl-throw
  64     mew-refile-guess-by-default))
  65
  66 (defvar mew-refile-auto-refile-skip-any-mark nil
  67   "*If *non-nil*, 'mew-summary-auto-refile' doesn't touch
  68 any alredy marked message.")
  69
  70 (defvar mew-refile-auto-refile-confirm nil
  71   "*If *non-nil*, 'mew-summary-auto-refile' prompts the user for
  72 confirmation before refiling.")
  73
  74 (defvar mew-refile-guess-strip-domainpart t
  75   "*If *non-nil*, 'mew-refile-guess-by-default' strips domainpart of from")
  76
  77 (defvar mew-refile-guess-from-me-is-special nil
  78   "*If *non-nil*, 'mew-refile-guess-by-from-*' think the mails from yourself
  79 as special. They use To: or Cc: instead of From:")
  80
  81 ;;
  82 ;; initialize function
  83 ;;
  84 (defun mew-refile-init ()
  85   ;; load message id alist
  86   (or mew-refile-msgid-alist
  87       (setq mew-refile-msgid-alist (mew-lisp-load mew-refile-msgid-file-name)))
  88   ;; load from alist
  89   (or mew-refile-from-alist
  90       (setq mew-refile-from-alist (mew-lisp-load mew-refile-from-file-name))))
  91
  92 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  93 ;;;
  94 ;;; Guess functions
  95 ;;;
  96
  97 ;; We have two types of functions in mew-refile-guess-control,
  98 ;; guess function and ctrl function.
  99 ;; guess function must return a folder list or folder string or nil.
 100 ;; guess function must not have a string "ctrl" in its symbol name.
 101 ;; ctrl function must have a string "ctrl" in its symbol name.
 102
 103 ;; dispatcher returns: ((guess1 guess2 ..) info1 info2 ...) multi  guess mode
 104 ;;                     ((guess1)           info1 info2 ...) single guess mode
 105 ;;            info1:   ('guess-func-name guess1 guess2 ...)
 106 ;;
 107 ;; that is, 'car' is a list of judged  folders.
 108 ;;          'cdr' is a alist of opinions by guess functions.
 109 ;;
 110 (defun mew-refile-guess (&optional auto show-all)
 111   (let ((funcs mew-refile-guess-control) ret guess info stop)
 112     (catch 'last
 113       (while funcs
 114         (cond
 115          ;; func is control function
 116          ((string-match "ctrl" (symbol-name (car funcs)))
 117           (if (setq ret (funcall (car funcs) guess auto))
 118               (progn
 119                 (setq stop t)
 120                 (or show-all (throw 'last t)))))
 121          ;; func is guess function
 122          (t
 123           (setq ret (funcall (car funcs)))))
 124         ;; now, ret is the return value from a function.
 125         ;; make sure ret is a list.
 126         (setq ret (or (and (listp ret) ret) (and ret (list ret))))
 127         ;; shape the guess: (guess1 guess2 ...)
 128         ;;            info: (info1 info2 ...)
 129         (setq info (nconc info (list (cons (car funcs) ret))))
 130         (if (not stop) (setq guess (nconc (reverse ret) guess)))
 131         (setq funcs (cdr funcs))))
 132     (setq guess (nreverse guess))
 133     (if mew-refile-ctrl-multi
 134         (cons (mew-uniq-list guess) info)
 135       (cons (list (car guess)) info))))
 136
 137
 138 ;;
 139 ;; guess control functions
 140 ;;
 141 (defun mew-refile-ctrl-auto-boundary (guess auto)
 142   (if auto 'stop))
 143
 144 (defun mew-refile-ctrl-throw (guess auto)
 145   (if guess 'stop))
 146
 147 ;;
 148 ;; by alist returns: (guess1 guess2 ...) or nil
 149 ;;
 150 (defun mew-refile-guess-by-alist ()
 151   (mew-refile-guess-by-alist1 mew-refile-guess-alist))
 152
 153 (defun mew-refile-guess-by-alist1 (alist)
 154   (let (name header sublist key val ent ret)
 155     (while alist
 156       (setq name (car (car alist)))
 157       (setq sublist (cdr (car alist)))
 158       (cond
 159        ((eq name t)
 160         (setq ret (cons sublist ret)))
 161        ((eq name nil)
 162         (or ret (setq ret (cons sublist ret))))
 163        (t
 164         (setq header (mew-header-get-value name))
 165         (if header
 166             (while sublist
 167               (setq key (car (car sublist)))
 168               (setq val (cdr (car sublist)))
 169               (if (and (stringp key) (string-match key header))
 170                   (cond
 171                    ((stringp val)
 172                     (setq ent (mew-refile-guess-by-alist2 key header val)))
 173                    ((listp val)
 174                     (setq ent (mew-refile-guess-by-alist1 val)))))
 175               (if ent
 176                   (if (listp ent)
 177                       (setq ret (nconc ent ret) ent nil)
 178                     (setq ret (cons ent ret))))
 179               (setq sublist (cdr sublist))))))
 180       (setq alist (cdr alist)))
 181     (mew-uniq-list (nreverse ret))))
 182
 183 (defun mew-refile-guess-by-alist2 (regexp field string)
 184   (let (match-strings match-list)
 185     (string-match regexp field)
 186     (setq match-list (cdr (cdr (match-data))))
 187     (while (car match-list)
 188       (setq match-strings
 189             (cons (substring field
 190                              (car match-list) (car (cdr match-list)))
 191                   match-strings))
 192       (setq match-list (cdr (cdr match-list))))
 193     (while (string-match "\\\\\\([1-9]\\)" string)
 194         (setq string
 195               (concat (substring string 0 (match-beginning 0))
 196                       (nth (- (length match-strings)
 197                               (string-to-int
 198                                (substring string
 199                                           (match-beginning 1)
 200                                           (match-end 1))))
 201                            match-strings)
 202                       (substring string (match-end 0)))))
 203     string))
 204
 205 ;;
 206 ;; by newsgroups returns (guess1 guess2 ...) or nil
 207 ;;
 208 (defun mew-refile-guess-by-newsgroups ()
 209   (let ((newsgroups (mew-addrstr-parse-value-list2
 210                      (mew-header-get-value mew-newsgroups:)))
 211         ent ret)
 212     (if (not newsgroups)
 213         ()
 214       (while newsgroups
 215         (setq ent (mew-assoc-case-equal (car newsgroups) mew-folder-alist 1))
 216         (if ent (setq ret (cons (nth 0 ent) ret)))
 217         (setq newsgroups (cdr newsgroups)))
 218       (mew-uniq-list (nreverse ret)))))
 219
 220 ;;
 221 ;; by folder returns: (guess1 guess2 ...) or nil
 222 ;;
 223 (defun mew-refile-guess-by-folder ()
 224   (let ((to-cc (mew-header-parse-address-list mew-refile-guess-key-list))
 225         ent ret ml-name)
 226     (while to-cc
 227       (setq ml-name (mew-addrstr-extract-user (or (car to-cc) "")))
 228       (setq ent (mew-assoc-case-equal ml-name mew-folder-alist 1))
 229       (if ent (setq ret (cons (nth 0 ent) ret)))
 230       (setq to-cc (cdr to-cc)))
 231     (mew-uniq-list (nreverse ret))))
 232
 233 ;;
 234 ;; by message-thread returns: guess1 or nil
 235 ;;
 236 (defun mew-refile-guess-by-thread ()
 237   (let ((msgid (or (mew-header-get-value mew-references:)
 238                    (mew-header-get-value mew-in-reply-to:))))
 239     ;; search for msgid
 240     (if (and msgid
 241              (string-match "\\(<[^ \t\n]*>\\)[^>]*\0" (concat msgid "\0")))
 242         (nth 1 (assoc (substring msgid
 243                                  (match-beginning 1)
 244                                  (match-end 1))
 245                       mew-refile-msgid-alist)))))
 246
 247 ;;
 248 ;; by from-{folder,alist} returns: guess1 or (guess1 ...) or nil
 249 ;;
 250 (defun mew-refile-guess-by-from-folder (&optional addr)
 251   (mew-refile-guess-from-dispatch 'mew-refile-guess-by-from-folder-body addr))
 252
 253 (defun mew-refile-guess-by-from (&optional addr)
 254   (mew-refile-guess-from-dispatch 'mew-refile-guess-by-from-body addr))
 255
 256 (defun mew-refile-guess-by-from-folder-body (&optional addr)
 257   (let* ((pfix (cond ((equal mew-folders-default-folder "" ) "+")
 258                      ((equal mew-folders-default-folder nil) "+")
 259                      ((equal mew-folders-default-folder "+") "+")
 260                      (t (file-name-as-directory mew-folders-default-folder))))
 261          (from (downcase (or addr (mew-header-parse-address mew-from:) "")))
 262          (user (mew-addrstr-extract-user from))
 263          (pfix-regex (concat "^" (regexp-quote pfix) "\\(.*/\\)?"))
 264          (from-regex (concat pfix-regex (regexp-quote from) "/?$"))
 265          (user-regex (concat pfix-regex (regexp-quote user) "/?$")))
 266     (or
 267      (mew-refile-match-in-list from-regex mew-folder-list)
 268      (mew-refile-match-in-list user-regex mew-folder-list))))
 269
 270 (defun mew-refile-guess-by-from-body (&optional addr)
 271   (let ((from   (downcase (or addr (mew-header-parse-address mew-from:) ""))))
 272     (cdr (assoc from mew-refile-from-alist))))
 273
 274 ;;
 275 ;; dispatcher to make mew-refile-guess-by-from-* consider
 276 ;; mew-refile-guess-from-me-is-special.
 277 ;;
 278 (defun mew-refile-guess-from-dispatch (func &optional addr)
 279   (let ((addr (downcase (or addr (mew-header-parse-address mew-from:) ""))))
 280     ;; if From: is my address, addr is the list extracted from To:, Cc:
 281     (if (and mew-refile-guess-from-me-is-special
 282              (mew-is-my-address (mew-get-my-address-regex-list) addr))
 283         (let ((addr (mew-header-parse-address-list mew-refile-guess-key-list))
 284               (a nil) (r nil))
 285           (while addr
 286             (if (setq a (funcall func (car addr)))
 287                 (setq r (cons a r)))
 288             (setq addr (cdr addr)))
 289           (mew-uniq-list (nreverse r)))
 290       (funcall func addr))))
 291
 292 ;;
 293 ;; by default returns: guess1
 294 ;;
 295 (defun mew-refile-guess-by-default (&optional addr)
 296   (mew-refile-guess-from-dispatch 'mew-refile-guess-by-default-body addr))
 297
 298 (defun mew-refile-guess-by-default-body (&optional addr)
 299   (let* ((pfix (cond ((equal mew-folders-default-folder "" ) "+")
 300                      ((equal mew-folders-default-folder nil) "+")
 301                      ((equal mew-folders-default-folder "+") "+")
 302                      (t (file-name-as-directory mew-folders-default-folder))))
 303          (from (downcase (or addr (mew-header-parse-address mew-from:) "")))
 304          (user (mew-addrstr-extract-user from)))
 305     (if mew-refile-guess-strip-domainpart
 306         (concat pfix user)
 307       (concat pfix from))))
 308
 309 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 310 ;;;
 311 ;;; Learning functions
 312 ;;;
 313
 314 ;; dispatcher
 315 ;;
 316 ;; mew-refile-guess-learn (buf result)
 317 ;;
 318 ;; buf is message buffer.
 319 ;;
 320 ;; result is ((chosen1 chosen2 ...)
 321 ;;           (guess-func-name1 guess1 guess2...)
 322 ;;           (guess-func-name2 guess1 guess2...))
 323 ;;
 324 ;; that is, 'car' is a list of user chosen folders.
 325 ;;          'cdr' is a list of opinions by guess functions.
 326 ;;
 327 (defun mew-refile-guess-learn (buf result)
 328   (let ((chosen (car result))  ;; (folder1 folder2 ...)
 329         (info   (cdr result))) ;; (guess-func-name guess1 guess2...)
 330     (save-excursion
 331       (set-buffer buf)
 332       (if (member 'mew-refile-guess-by-from mew-refile-guess-control)
 333           (mew-refile-guess-by-from-learn chosen info))
 334       (if (member 'mew-refile-guess-by-thread mew-refile-guess-control)
 335           (mew-refile-guess-by-thread-learn chosen info)))))
 336 ;;
 337 ;; learn from msgid
 338 ;;
 339 (defun mew-refile-guess-by-thread-learn (chosen info)
 340   (let* ((msgid  (mew-header-get-value mew-message-id:))
 341          (folder (car chosen))
 342          ;; ohter people's honest opinion and my honest opinion.
 343          (oho    info)
 344          (mho    (cdr (assoc 'mew-refile-guess-by-thread info))))
 345     (if (and msgid (string-match "<[^ \n>]*>" msgid))
 346         (setq msgid (substring msgid (match-beginning 0) (match-end 0))))
 347     (if (or (not msgid) (not chosen))
 348         ()
 349       ;; if my opninion was right, I learn it.
 350       ;; or a folder was not in other people's opinion,
 351       ;; I accept it.
 352       (catch 'match
 353         (while chosen
 354           (if (or (member (car chosen) mho)
 355                   (not (catch 'find
 356                     (while oho
 357                       (and (member (car chosen) (car oho)) (throw 'find t))
 358                       (setq oho (cdr oho))))))
 359               (throw 'match (setq folder (car chosen))))
 360           (setq chosen (cdr chosen))))
 361       (setq mew-refile-msgid-alist
 362             (cons (list msgid folder "??")
 363                   (delete (assoc msgid mew-refile-msgid-alist)
 364                           mew-refile-msgid-alist))))))
 365 ;;
 366 ;; learn from "From:" field
 367 ;;
 368 (defun mew-refile-guess-by-from-learn (chosen info)
 369   (let* ((from  (downcase (or (mew-header-parse-address mew-from:) "")))
 370          (folder nil)
 371          ;; 'my honest opinion' guessed by mew-refile-guess-by-from.
 372          (mho    (nth 1 (assoc 'mew-refile-guess-by-from       info))))
 373
 374     (if (or (or (null from) (null chosen)) ;; if from and/or chosen is empty
 375             (and mho (member mho chosen))) ;; or my opinion was right,
 376         ()                                 ;; do nothing.
 377
 378       ;; I decide which folder is most important among the user chosen
 379       ;; folders.
 380       (catch 'match
 381         (while chosen
 382           ;; searching a folder anyone couldn't predict.
 383           (if (not (mew-refile-guess-member-p (car chosen) info))
 384               (throw 'match (setq folder (car chosen))))
 385           (setq chosen (cdr chosen))))
 386
 387       ;; If candidate was found, I memorize it.
 388       (if folder
 389           (setq mew-refile-from-alist
 390                 (cons (cons from folder)
 391                       (delete (assoc from mew-refile-from-alist)
 392                               mew-refile-from-alist)))))))
 393
 394 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 395 ;;;
 396 ;;; Backyard functions.
 397 ;;;
 398
 399 (defun mew-refile-guess-save ()
 400   (if (and mew-refile-from-alist
 401            (member 'mew-refile-guess-by-from mew-refile-guess-control))
 402       (mew-lisp-save mew-refile-from-file-name mew-refile-from-alist))
 403   (if (and mew-refile-msgid-alist
 404            (member 'mew-refile-guess-by-thread mew-refile-guess-control))
 405       (mew-lisp-save mew-refile-msgid-file-name mew-refile-msgid-alist)))
 406
 407 (defun mew-refile-guess-subfolder-p (parent child)
 408   (string-match
 409    (concat  "^" (regexp-quote (file-name-as-directory parent)))
 410    child))
 411
 412 ;;
 413 ;; search x in a nested list.
 414 ;;
 415 (defun mew-refile-guess-member-p (x lst)
 416   (catch 'found
 417     (while lst
 418       (cond
 419        ((listp (car lst))
 420         (if (mew-refile-guess-member-p x (car lst))
 421             (throw 'found t)))
 422        (t
 423         (if (equal  x (car lst))
 424             (throw 'found t))))
 425       (setq lst (cdr lst)))))
 426
 427 ;;
 428 ;; grep with regex in a list of string. (first match)
 429 ;;
 430 (defun mew-refile-match-in-list (regex lst)
 431   (let ((case-fold-search t))
 432     (catch 'found
 433       (while lst
 434         (if (string-match regex (car lst))
 435             (throw 'found (car lst)))
 436         (setq lst (cdr lst))))))
 437
 438 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 439 ;;;
 440 ;;; Summary mode
 441 ;;;
 442 (defun mew-refile-set (msg folder)
 443   (let* ((msg-folders (assoc msg mew-summary-buffer-refile))
 444          (folders (cdr msg-folders)))
 445     (if folders
 446         (if (not (mew-folder-member folder folders))
 447             (setq mew-summary-buffer-refile
 448                   (cons (nreverse (cons folder (nreverse (cons msg folders))))
 449                         (delete msg-folders mew-summary-buffer-refile))))
 450       (setq mew-summary-buffer-refile
 451             (cons (list msg folder) mew-summary-buffer-refile)))))
 452
 453 (defun mew-refile-reset (msg)
 454   (setq mew-summary-buffer-refile
 455         (delete (assoc msg mew-summary-buffer-refile)
 456                 mew-summary-buffer-refile)))
 457
 458 ;; mew-refile-decide-folders returns: ((input1 input2...)
 459 ;;                                     (guess-func-name1 guess1 guess2...)
 460 ;;                                     (guess-func-name2 guess1 guess2...))
 461 ;; that is, 'car' is a list of user chosen folders.
 462 ;;          'cdr' is a alist of opinions by guess functions.
 463 ;; cdr is needed for learning functions.
 464 ;;
 465 (defun mew-refile-decide-folders (buf msg mark &optional auto)
 466   (let (learn-info folders ret)
 467     (save-excursion
 468       (set-buffer buf)
 469       (setq learn-info (mew-refile-guess auto)))
 470     (setq
 471      folders
 472      (cond
 473       ;; if auto is set, simply use the guess.
 474       (auto (car learn-info))
 475       ;; add new folder
 476       ((equal mew-mark-refile mark)
 477        (mew-input-folders
 478         nil (mew-join ","
 479                       (cdr (assoc msg mew-summary-buffer-refile)))))
 480       ;; multi guess
 481       ((nth 1 (car learn-info))
 482        (mew-input-folders nil (mew-join "," (car learn-info))))
 483       ;; single guess
 484       (t
 485        (mew-input-folders (nth 0 (car learn-info))))))
 486     ;; check folder existence.
 487     (while folders
 488       (if (mew-folder-check (car folders))
 489           (setq ret (cons (car folders) ret)))
 490       (setq folders (cdr folders)))
 491     (cons (nreverse ret) (cdr learn-info)))) ;; return value
 492
 493 (defvar mew-header-reasonable-size 5000)
 494
 495 (defun mew-summary-refile (&optional report)
 496  "Put the refile mark(default is 'o') on this message. If already
 497 marked with 'o', it prints where this message will be refiled. This
 498 can overlay other marks. When it overlays, the cursor stays on the
 499 message. If it marks newly, displays the next message. If executed
 500 with '\\[universal-argument]', it displays how the refile rules work in Message mode."
 501  (interactive "P")
 502  (if report (mew-summary-refile-report) (mew-summary-refile-body)))
 503
 504 (defun mew-summary-refile-body (&optional exp-flds auto)
 505   (mew-summary-only
 506    (mew-summary-msg-or-part
 507     (let (msg folders mark buf learn-info fld)
 508       (save-excursion
 509         ;; save the cursor position anyway
 510         (mew-summary-goto-message)
 511         ;; on the message
 512         (setq fld (mew-summary-folder-name))
 513         (setq msg (mew-summary-message-number)) ;; msg is never nil
 514         (setq mark (mew-summary-get-mark))) ;; any mark
 515       (if exp-flds
 516           (setq folders exp-flds)
 517         ;; show message if not displayed
 518         (if (or auto (null mew-summary-buffer-disp-msg))
 519             (save-excursion
 520               (mew-set-buffer-tmp)
 521               (setq buf (current-buffer))
 522               (mew-insert-message fld msg mew-cs-autoconv
 523                                   mew-header-reasonable-size)
 524               (goto-char (point-min))
 525               (if (and (re-search-forward (concat "^$\\|^" mew-subj:) nil t)
 526                        (not (looking-at "^$")))
 527                   (let ((med (point)))
 528                     (forward-line)
 529                     (mew-header-goto-next)
 530                     (mew-header-decode-region 'text med (point)))))
 531           (mew-summary-display nil) ;; cursor position is important
 532           (setq buf (or (mew-cache-hit (cons (buffer-name) msg))
 533                         (mew-buffer-message)))) ;; for ","
 534         (setq learn-info (mew-refile-decide-folders buf msg mark auto))
 535         (setq folders (car learn-info)))
 536       ;; mark refile
 537       (if folders
 538           (save-excursion
 539             (mew-summary-goto-message)
 540             (or exp-flds auto (mew-refile-guess-learn buf learn-info))
 541             (mew-refile-reset msg)
 542             (mapcar (function (lambda (x) (mew-refile-set msg x))) folders)
 543             (mew-mark-unmark)
 544             (mew-summary-mark-as mew-mark-refile)))
 545       ;; memorize last-folder
 546       (setq mew-refile-last-folder folders)
 547       (if (or mark auto (not folders))
 548           () ;; stay here
 549         (mew-summary-goto-message)
 550         ;; on the message
 551         (mew-decode-syntax-delete)
 552         ;; for C-x C-x
 553         (beginning-of-line)
 554         (let ((zmacs-regions nil))
 555           (push-mark (point) t t))
 556         (mew-summary-display-after mew-summary-mark-direction))
 557       (set-buffer-modified-p nil)
 558       folders)))) ;; return value
 559
 560 (defun mew-summary-refile-report ()
 561   (mew-summary-only
 562    (mew-summary-msg-or-part
 563     (let (fld msg guess buf
 564               (customize-var '(mew-refile-ctrl-multi
 565                                mew-refile-guess-key-list
 566                                mew-refile-guess-strip-domainpart
 567                                mew-refile-guess-from-me-is-special)))
 568       (save-excursion
 569         ;; save the cursor position anyway
 570         (mew-summary-goto-message)
 571         ;; on the message
 572         (setq fld (mew-summary-folder-name))
 573         (setq msg (mew-summary-message-number)) ;; msg is never nil
 574         (mew-set-buffer-tmp)
 575         (mew-insert-message fld msg mew-cs-autoconv
 576                             mew-header-reasonable-size)
 577         (setq guess (mew-refile-guess nil t)))
 578       (setq buf (buffer-name))
 579       (mew-window-configure buf 'message)
 580       (mew-elet
 581        (mew-erase-buffer)
 582        (save-excursion
 583          ;; report result of guess.
 584          (insert (format "** Guess result: %s\n" (car guess)))
 585          ;; report status of customize variables.
 586          (insert "\n** Current Configurations:\n\n")
 587          (while customize-var
 588            (insert (format "%-40s:  " (car customize-var)))
 589            (insert (format "%s\n"     (eval (car customize-var))))
 590            (setq customize-var (cdr customize-var)))
 591          (insert "\n** Each function's opinion:\n\n")
 592          ;; report how each functions guessed.
 593          (setq guess (cdr guess))
 594          (while guess
 595            (insert (format "%-32s  " (car (car guess))))
 596            (insert (format "return: %s\n" (cdr (car guess))))
 597            (setq guess (cdr guess)))))
 598       (mew-message-clear-end-of)
 599       (set-buffer-modified-p nil)
 600       (mew-pop-to-buffer buf)))))
 601
 602 (defun mew-summary-refile-again ()
 603   "Put a refile mark on this message according to the previous
 604 refile folder."
 605   (interactive)
 606   (mew-summary-only
 607    (mew-summary-refile-body mew-refile-last-folder)))
 608
 609 (defun mew-summary-auto-refile (&optional mew-mark-review-only)
 610   "Refile each message in the folder automatically. If
 611 'mew-refile-auto-refile-skip-any-mark' is non-nil,
 612 any previousely marked message will be skipped.
 613 If '\\[universal-argument]' is specified, only messages marked with
 614 'mew-mark-review' will be conserned."
 615   (interactive "P")
 616   (mew-summary-only
 617    (let ((after-change-function nil)  ;; XEmacs - obsolete variable, ignore warnings.
 618          (after-change-functions nil)
 619          (mew-use-highlight-x-face nil)
 620          (lines (count-lines (point-min) (point-max)))
 621          (line 1) (mark nil) msg)
 622      (cond
 623       (mew-mark-review-only
 624        (setq msg (format "Refile all messages marked with '%c'? "
 625                          mew-mark-review)))
 626       (mew-refile-auto-refile-skip-any-mark
 627        (setq msg (format "Refile all non-marked messages? ")))
 628       (t
 629        (setq msg (format "Refile all messages except those marked with '%c' and '%c'? " mew-mark-refile mew-mark-delete))))
 630      (if (and mew-refile-auto-refile-confirm (null (yes-or-no-p msg)))
 631          (message "Not refiled.")
 632        (message "Auto refiling ...")
 633        (save-window-excursion
 634          (goto-char (point-min))
 635          (while (not (eobp))
 636            (setq mark (mew-summary-get-mark))
 637            (if mew-mark-review-only
 638                (and (equal mark mew-mark-review)
 639                     (mew-summary-refile-body nil t))
 640              (or (equal mark mew-mark-refile)
 641                  (equal mark mew-mark-delete)
 642                  (and mark mew-refile-auto-refile-skip-any-mark)
 643                  (mew-summary-refile-body nil t)))
 644            (forward-line)
 645            (if (equal (% (/ (* 100 line) lines) 10) 0)
 646                (message "Auto refiling ... %s%%"
 647                         (/ (* 100 line) lines)))
 648            (setq line (1+ line)))
 649          (message "Auto refiling ... done"))))))
 650
 651 ;;
 652 ;; "mx" extension
 653 ;;
 654 (defun mew-summary-mark-refile ()
 655   "\\<mew-summary-mode-map>
 656 Put the refile mark onto all messages marked with '*'.
 657 This is very convenient to refile all messages picked by '\\[mew-summary-search-mark]'."
 658   (interactive)
 659   (mew-summary-only
 660    (let ((after-change-function nil) ;; XEmacs - obsolete variable, ignore warnings.
 661          (after-change-functions nil)
 662          (mew-use-highlight-x-face nil)
 663          (last nil)
 664          (regex (concat mew-summary-message-regex
 665                         (regexp-quote (char-to-string mew-mark-review)))))
 666      (message "Mark refiling ...")
 667      (save-excursion
 668        (save-window-excursion
 669          (goto-char (point-min))
 670          (while (re-search-forward regex nil t)
 671            (setq last (mew-summary-refile-body last))
 672            (forward-line))
 673          (message "Mark refiling ... done"))))))
 674
 675 (provide 'mew-refile)
 676
 677 ;;; Copyright Notice:
 678
 679 ;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999 Mew developing team.
 680 ;; All rights reserved.
 681
 682 ;; Redistribution and use in source and binary forms, with or without
 683 ;; modification, are permitted provided that the following conditions
 684 ;; are met:
 685 ;;
 686 ;; 1. Redistributions of source code must retain the above copyright
 687 ;;    notice, this list of conditions and the following disclaimer.
 688 ;; 2. Redistributions in binary form must reproduce the above copyright
 689 ;;    notice, this list of conditions and the following disclaimer in the
 690 ;;    documentation and/or other materials provided with the distribution.
 691 ;; 3. Neither the name of the team nor the names of its contributors
 692 ;;    may be used to endorse or promote products derived from this software
 693 ;;    without specific prior written permission.
 694 ;;
 695 ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND
 696 ;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 697 ;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
 698 ;; PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE
 699 ;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 700 ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 701 ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
 702 ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 703 ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
 704 ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
 705 ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 706
 707 ;;; mew-refile.el ends here