forked from wanderlust/wanderlust
/
wl-action.el
973 lines (914 loc) · 32.3 KB
/
wl-action.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
;;; wl-action.el --- Mark and actions in the Summary mode for Wanderlust.
;; Copyright (C) 2003 Yuuichi Teranishi <teranisi@gohome.org>
;; Author: Yuuichi Teranishi <teranisi@gohome.org>
;; Keywords: mail, net news
;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;
;;; Commentary:
;;
;;; Code:
;;
(require 'wl-summary)
(eval-when-compile
(defalias-maybe 'wl-summary-target-mark 'ignore)
(defalias-maybe 'wl-summary-target-mark-region 'ignore))
(defsubst wl-summary-action-mark (action)
(nth 0 action))
(defsubst wl-summary-action-symbol (action)
(nth 1 action))
(defsubst wl-summary-action-argument-function (action)
(nth 2 action))
(defsubst wl-summary-action-set-function (action)
(nth 3 action))
(defsubst wl-summary-action-exec-function (action)
(nth 4 action))
(defsubst wl-summary-action-face (action)
(nth 5 action))
(defsubst wl-summary-action-docstring (action)
(concat (nth 6 action)
"\nThis function is defined by `wl-summary-define-mark-action'."))
(defsubst wl-summary-action-unmark-docstring (action)
(concat "Unmark `" (wl-summary-action-mark action) "' from the current line."
"\nIf NUMBER is non-nil, unmark the summary line specified by NUMBER."
"\nThis function is defined by `wl-summary-define-mark-action'."))
;; Set mark
(defun wl-summary-set-mark (&optional set-mark number interactive data)
"Set temporary mark SET-MARK on the message with NUMBER.
NUMBER is the message number to set the mark on.
INTERACTIVE is set as t if it have to run interactively.
DATA is passed to the set-action function of the action as an argument.
Return number if put mark succeed"
(let* ((set-mark (or set-mark
(completing-read "Mark: " wl-summary-mark-action-list)))
(current (wl-summary-message-number))
(action (assoc set-mark wl-summary-mark-action-list))
visible mark cur-mark)
(when (zerop (elmo-folder-length wl-summary-buffer-elmo-folder))
(error "Set mark failed"))
(prog1
(save-excursion
;; Put mark
(if number
;; Jump to message if cursor is not on the message.
(when (and (setq visible (wl-summary-message-visible-p number))
(not (eq number current)))
(wl-summary-jump-to-msg number))
(setq visible t
number current))
(setq cur-mark (nth 1 (wl-summary-registered-temp-mark number)))
(unless number
(error "No message"))
(if (wl-summary-reserve-temp-mark-p cur-mark)
(when interactive
(error "Already marked as `%s'" cur-mark))
(when (and interactive
(null data)
(wl-summary-action-argument-function action))
(setq data (funcall (wl-summary-action-argument-function action)
(wl-summary-action-symbol action)
number)))
;; Unset the current mark.
(wl-summary-unset-mark number)
;; Set action.
(funcall (wl-summary-action-set-function action)
number
(wl-summary-action-mark action)
data)
(when visible
(wl-summary-put-temp-mark set-mark)
(when wl-summary-highlight
(wl-highlight-summary-current-line))
(when data
(wl-summary-print-argument number data)))
(when (and (eq wl-summary-buffer-view 'thread)
interactive)
(wl-thread-open-children number))
(set-buffer-modified-p nil)
;; Return value.
number))
;; Move the cursor.
(if interactive
(if (eq wl-summary-move-direction-downward nil)
(wl-summary-prev)
(wl-summary-next))))))
(defun wl-summary-register-target-mark (number mark data)
(or (memq number wl-summary-buffer-target-mark-list)
(setq wl-summary-buffer-target-mark-list
(cons number wl-summary-buffer-target-mark-list))))
(defun wl-summary-unregister-target-mark (number)
(setq wl-summary-buffer-target-mark-list
(delq number wl-summary-buffer-target-mark-list)))
(defun wl-summary-have-target-mark-p (number)
(memq number wl-summary-buffer-target-mark-list))
(defun wl-summary-target-mark-set-action (action)
(unless (eq (wl-summary-action-symbol action) 'target-mark)
(unless wl-summary-buffer-target-mark-list (error "no target"))
(save-excursion
(goto-char (point-min))
(let ((numlist wl-summary-buffer-number-list)
number mlist data)
;; use firstly marked message.
(when (wl-summary-action-argument-function action)
(while numlist
(if (memq (car numlist) wl-summary-buffer-target-mark-list)
(setq number (car numlist)
numlist nil))
(setq numlist (cdr numlist)))
(wl-summary-jump-to-msg number)
(setq data (funcall (wl-summary-action-argument-function action)
(wl-summary-action-symbol action) number)))
(while (not (eobp))
(when (string= (wl-summary-temp-mark) "*")
(let (wl-summary-buffer-disp-msg)
(when (setq number (wl-summary-message-number))
(wl-summary-set-mark (wl-summary-action-mark action)
nil nil data)
(setq wl-summary-buffer-target-mark-list
(delq number wl-summary-buffer-target-mark-list)))))
(forward-line 1))
(setq mlist wl-summary-buffer-target-mark-list)
(while mlist
(wl-summary-register-temp-mark (car mlist)
(wl-summary-action-mark action) data)
(setq wl-summary-buffer-target-mark-list
(delq (car mlist) wl-summary-buffer-target-mark-list))
(setq mlist (cdr mlist)))))))
;; wl-summary-buffer-temp-mark-list specification
;; ((1 "D" nil)(2 "o" "+fuga")(3 "O" "+hoge"))
(defun wl-summary-register-temp-mark (number mark mark-info)
(let ((elem (assq number wl-summary-buffer-temp-mark-list)))
(setq wl-summary-buffer-temp-mark-list
(delq elem wl-summary-buffer-temp-mark-list)))
(setq wl-summary-buffer-temp-mark-list
(cons (list number mark mark-info) wl-summary-buffer-temp-mark-list)))
(defun wl-summary-unregister-temp-mark (number)
(let ((elem (assq number wl-summary-buffer-temp-mark-list)))
(setq wl-summary-buffer-temp-mark-list
(delq elem wl-summary-buffer-temp-mark-list))))
(defun wl-summary-registered-temp-mark (number)
(and wl-summary-buffer-temp-mark-list
(assq number wl-summary-buffer-temp-mark-list)))
(defun wl-summary-collect-temp-mark (mark &optional begin end)
(if (or begin end)
(save-excursion
(save-restriction
(let (mark-list)
(narrow-to-region (or begin (point-min))(or end (point-max)))
(goto-char (point-min))
;; for thread...
(if (eq wl-summary-buffer-view 'thread)
(let (number entity mark-info)
(while (not (eobp))
(setq number (wl-summary-message-number)
entity (wl-thread-get-entity number)
mark-info (wl-summary-registered-temp-mark number))
;; toplevel message mark.
(when (string= (nth 1 mark-info) mark)
(setq mark-list (cons mark-info mark-list)))
;; When thread is closed...children should also be checked.
(unless (wl-thread-entity-get-opened entity)
(dolist (msg (wl-thread-get-children-msgs number))
(setq mark-info (wl-summary-registered-temp-mark
msg))
(when (string= (nth 1 mark-info) mark)
(setq mark-list (cons mark-info mark-list)))))
(forward-line 1)))
(let (number mark-info)
(while (not (eobp))
(setq number (wl-summary-message-number)
mark-info (wl-summary-registered-temp-mark number))
(when (string= (nth 1 mark-info) mark)
(setq mark-list (cons mark-info mark-list)))
(forward-line 1))))
mark-list)))
(let (mark-list)
(dolist (mark-info wl-summary-buffer-temp-mark-list)
(when (string= (nth 1 mark-info) mark)
(setq mark-list (cons mark-info mark-list))))
mark-list)))
;; Unset mark
(defun wl-summary-unset-mark (&optional number interactive force)
"Unset temporary mark of the message with NUMBER.
NUMBER is the message number to unset the mark.
If not specified, the message on the cursor position is treated.
Optional INTERACTIVE is non-nil when it should be called interactively.
If optional FORCE is non-nil, remove scored mark too.
Return number if put mark succeed"
(interactive)
(save-excursion
(beginning-of-line)
(let ((buffer-read-only nil)
visible mark action)
(if number
;; Jump to message
(when (and (setq visible (wl-summary-message-visible-p number))
(not (eq number (wl-summary-message-number))))
(wl-summary-jump-to-msg number))
(setq visible t
number (wl-summary-message-number)))
(setq mark (wl-summary-temp-mark))
;; Remove from temporal mark structure.
(wl-summary-unregister-target-mark number)
(wl-summary-unregister-temp-mark number)
;; Delete mark on buffer.
(when visible
(unless (string= mark " ")
(wl-summary-put-temp-mark
(or (unless force (wl-summary-get-score-mark number))
" "))
(setq action (assoc mark wl-summary-mark-action-list))
(when wl-summary-highlight
(wl-highlight-summary-current-line))
(when (wl-summary-action-argument-function action)
(wl-summary-remove-argument)))
(set-buffer-modified-p nil))))
;;; Move the cursor.
;;; (if (or interactive (interactive-p))
;;; (if (eq wl-summary-move-direction-downward nil)
;;; (wl-summary-prev)
;;; (wl-summary-next))))
)
(defun wl-summary-make-destination-numbers-list (mark-list)
(let (dest-numbers dest-number)
(dolist (elem mark-list)
(setq dest-number (assoc (nth 2 elem) dest-numbers))
(if dest-number
(unless (memq (car elem) (cdr dest-number))
(nconc dest-number (list (car elem))))
(setq dest-numbers (nconc dest-numbers
(list
(list (nth 2 elem)
(car elem)))))))
dest-numbers))
(defun wl-summary-move-mark-list-messages (mark-list folder-name message)
(if (null mark-list)
(message "No marks")
(save-excursion
(let ((start (point))
(refiles (mapcar 'car mark-list))
(refile-failures 0)
dst-msgs ; loop counter
result)
;; begin refile...
(goto-char start) ; avoid moving cursor to
; the bottom line.
(elmo-with-progress-display
(elmo-folder-move-messages (length refiles))
message
(setq result nil)
(condition-case nil
(setq result (elmo-folder-move-messages
wl-summary-buffer-elmo-folder
refiles
(if (eq folder-name 'null)
'null
(wl-folder-get-elmo-folder folder-name))))
(error nil))
(when result ; succeeded.
;; update buffer.
(wl-summary-delete-messages-on-buffer refiles)
;; update wl-summary-buffer-temp-mark-list.
(dolist (mark-info mark-list)
(setq wl-summary-buffer-temp-mark-list
(delq mark-info wl-summary-buffer-temp-mark-list)))))
(wl-summary-set-message-modified)
;; Return the operation failed message numbers.
(if result
0
(length refiles))))))
(defun wl-summary-get-refile-destination-subr (action number learn)
(let* ((number (or number (wl-summary-message-number)))
(msgid (and number
(elmo-message-field wl-summary-buffer-elmo-folder
number 'message-id)))
(entity (and number
(elmo-message-entity wl-summary-buffer-elmo-folder
number)))
folder cur-mark tmp-folder)
(catch 'done
(when (null entity)
(message "Cannot decide destination.")
(throw 'done nil))
(when (null number)
(message "No message.")
(throw 'done nil))
(setq folder (wl-summary-read-folder
(or (wl-refile-guess entity) wl-trash-folder)
(format "for %s " action)))
;; Cache folder hack by okada@opaopa.org
(when (and (eq (elmo-folder-type-internal
(wl-folder-get-elmo-folder
(wl-folder-get-realname folder))) 'cache)
(not (string= folder
(setq tmp-folder
(concat "'cache/"
(elmo-cache-get-path-subr
(elmo-msgid-to-cache msgid)))))))
(setq folder tmp-folder)
(message "Force refile to %s." folder))
(if (string= folder (wl-summary-buffer-folder-name))
(error "Same folder"))
(if (or (not (elmo-folder-writable-p (wl-folder-get-elmo-folder folder)))
(string= folder wl-queue-folder)
(string= folder wl-draft-folder))
(error "Don't set as target: %s" folder))
;; learn for refile.
(when learn
(wl-refile-learn entity folder))
folder)))
;;; Actions
(defun wl-summary-define-mark-action ()
(interactive)
(dolist (action wl-summary-mark-action-list)
(fset (intern (format "wl-summary-%s" (wl-summary-action-symbol action)))
`(lambda (&optional number data)
,(wl-summary-action-docstring action)
(interactive)
(wl-summary-set-mark ,(wl-summary-action-mark action)
number (interactive-p) data)))
(fset (intern (format "wl-summary-unmark-%s"
(wl-summary-action-symbol action)))
`(lambda (&optional number)
,(wl-summary-action-unmark-docstring action)
(interactive)
(wl-summary-unmark number ,(wl-summary-action-mark action))))
(fset (intern (format "wl-summary-%s-region"
(wl-summary-action-symbol action)))
`(lambda (beg end)
,(wl-summary-action-docstring action)
(interactive "r")
(save-excursion
(goto-char beg)
(wl-summary-mark-region-subr
(quote ,(intern (format "wl-summary-%s"
(wl-summary-action-symbol action))))
beg end
(if (quote ,(wl-summary-action-argument-function action))
(funcall (function
,(wl-summary-action-argument-function action))
(quote ,(wl-summary-action-symbol action))
(wl-summary-message-number)))))))
(fset (intern (format "wl-summary-target-mark-%s"
(wl-summary-action-symbol action)))
`(lambda ()
,(wl-summary-action-docstring action)
(interactive)
(wl-summary-target-mark-set-action (quote ,action))))
(fset (intern (format "wl-thread-%s"
(wl-summary-action-symbol action)))
`(lambda (arg)
,(wl-summary-action-docstring action)
(interactive "P")
(wl-thread-call-region-func
(quote ,(intern (format "wl-summary-%s-region"
(wl-summary-action-symbol action))))
arg)
(if arg
(wl-summary-goto-top-of-current-thread))
(if (not wl-summary-move-direction-downward)
(wl-summary-prev)
(wl-thread-goto-bottom-of-sub-thread)
(if wl-summary-buffer-disp-msg
(wl-summary-redisplay)))))))
(defun wl-summary-get-dispose-folder (folder)
(if (string= folder wl-trash-folder)
'null
(let* ((type (or (wl-get-assoc-list-value wl-dispose-folder-alist folder)
'trash)))
(cond ((stringp type)
type)
((or (equal type 'remove) (equal type 'null))
'null)
(t;; (equal type 'trash)
(let ((trash-folder (wl-folder-get-elmo-folder wl-trash-folder)))
(unless (elmo-folder-exists-p trash-folder)
(if (y-or-n-p
(format "Trash Folder %s does not exist, create it? "
wl-trash-folder))
(elmo-folder-create trash-folder)
(error "Trash Folder is not created"))))
wl-trash-folder)))))
;; Dispose action.
(defun wl-summary-exec-action-dispose (mark-list)
(wl-summary-move-mark-list-messages mark-list
(wl-summary-get-dispose-folder
(wl-summary-buffer-folder-name))
"Disposing messages"))
;; Delete action.
(defun wl-summary-exec-action-delete (mark-list)
(wl-summary-move-mark-list-messages mark-list
'null
"Deleting messages"))
;; Refile action
(defun wl-summary-set-action-refile (number mark data)
(when (null data)
(error "Destination folder is empty"))
(wl-summary-register-temp-mark number mark data)
(setq wl-summary-buffer-prev-refile-destination data))
(defun wl-summary-get-refile-destination (action number)
"Decide refile destination."
(wl-summary-get-refile-destination-subr action number t))
(defun wl-summary-exec-action-refile (mark-list)
(save-excursion
(let ((start (point))
(failures 0)
dst-msgs)
;; begin refile...
(setq dst-msgs (wl-summary-make-destination-numbers-list mark-list))
(goto-char start) ; avoid moving cursor to the bottom line.
(elmo-with-progress-display
(elmo-folder-move-messages (length mark-list))
"Refiling messages"
(dolist (pair dst-msgs)
(if (condition-case nil
(elmo-folder-move-messages
wl-summary-buffer-elmo-folder
(cdr pair)
(wl-folder-get-elmo-folder (car pair)))
(error nil))
(progn
;; update buffer.
(wl-summary-delete-messages-on-buffer (cdr pair))
(setq wl-summary-buffer-temp-mark-list
(wl-delete-associations
(cdr pair)
wl-summary-buffer-temp-mark-list)))
(setq failures (+ failures (length (cdr pair)))))))
failures)))
;; Copy action
(defun wl-summary-get-copy-destination (action number)
(wl-summary-get-refile-destination-subr action number nil))
(defun wl-summary-exec-action-copy (mark-list)
(save-excursion
(let ((start (point))
(failures 0)
dst-msgs)
;; begin refile...
(setq dst-msgs
(wl-summary-make-destination-numbers-list mark-list))
(goto-char start) ; avoid moving cursor to the bottom line.
(elmo-with-progress-display
(elmo-folder-move-messages (length mark-list))
"Copying messages"
(dolist (pair dst-msgs)
(if (condition-case nil
(elmo-folder-move-messages
wl-summary-buffer-elmo-folder
(cdr pair)
(wl-folder-get-elmo-folder (car pair))
'no-delete)
(error nil))
(progn
;; update buffer.
(wl-summary-delete-copy-marks-on-buffer (cdr pair))
(setq wl-summary-buffer-temp-mark-list
(wl-delete-associations
(cdr pair)
wl-summary-buffer-temp-mark-list)))
(setq failures (+ failures (length (cdr pair)))))))
failures)))
;; Prefetch.
(defun wl-summary-exec-action-prefetch (mark-list)
(save-excursion
(let* ((count 0)
(length (length mark-list))
(mark-list-copy (copy-sequence mark-list))
(pos (point))
(failures 0))
(dolist (mark-info mark-list-copy)
(message "Prefetching...(%d/%d)"
(setq count (+ 1 count)) length)
(if (wl-summary-prefetch-msg (car mark-info))
(progn
(wl-summary-unset-mark (car mark-info))
(sit-for 0))
(incf failures)))
(message "Prefetching...done")
0)))
;; Resend.
(defun wl-summary-get-resend-address (action number)
"Decide resend address."
(wl-address-read-from-minibuffer "Resend message to: "))
(defun wl-summary-exec-action-resend (mark-list)
(let ((failure 0))
(dolist (mark-info mark-list)
(if (condition-case nil
(progn
(wl-summary-exec-action-resend-subr (car mark-info)
(nth 2 mark-info))
t)
(error))
(wl-summary-unmark (car mark-info))
(incf failure)))
failure))
(defun wl-summary-exec-action-resend-subr (number address)
"Resend the message with NUMBER to ADDRESS."
(message "Resending message to %s..." address)
(let ((folder wl-summary-buffer-elmo-folder))
(with-current-buffer (get-buffer-create " *wl-draft-resend*")
;; We first set up a normal mail buffer.
(set-buffer-multibyte nil)
(erase-buffer)
(setq wl-sent-message-via nil)
;; Insert our usual headers.
(wl-draft-insert-from-field)
(wl-draft-insert-date-field)
(insert "To: " address "\n")
(goto-char (point-min))
;; Rename them all to "Resent-*".
(while (re-search-forward "^[A-Za-z]" nil t)
(forward-char -1)
(insert "Resent-"))
(widen)
(forward-line)
(delete-region (point) (point-max))
(let ((beg (point)))
;; Insert the message to be resent.
(insert
;; elmo-message-fetch is erase current buffer before fetch message
(elmo-message-fetch-string folder number
(if wl-summary-resend-use-cache
(elmo-make-fetch-strategy
'entire 'maybe nil
(elmo-file-cache-get-path
(elmo-message-field
folder number 'message-id)))
(elmo-make-fetch-strategy 'entire))
'unread))
(goto-char (point-min))
(search-forward "\n\n")
(forward-char -1)
(save-restriction
(narrow-to-region beg (point))
(wl-draft-delete-fields wl-ignored-resent-headers)
(goto-char (point-max)))
(insert mail-header-separator)
;; Rename all old ("Previous-")Resent headers.
(while (re-search-backward "^\\(Previous-\\)*Resent-" beg t)
(beginning-of-line)
(insert "Previous-"))
;; Quote any "From " lines at the beginning.
(goto-char beg)
(when (looking-at "From ")
(replace-match "X-From-Line: ")))
(run-hooks 'wl-summary-resend-hook)
;; Send it.
(wl-draft-dispatch-message)
(kill-buffer (current-buffer)))
(message "Resending message to %s...done" address)))
;;;
(defun wl-summary-remove-argument ()
(save-excursion
(let ((inhibit-read-only t)
(buffer-read-only nil)
(buf (current-buffer))
sol eol rs re)
(setq sol (point-at-bol))
(beginning-of-line)
(search-forward "\r")
(forward-char -1)
(setq eol (point))
(setq rs (next-single-property-change sol 'wl-summary-action-argument
buf eol))
(setq re (next-single-property-change rs 'wl-summary-action-argument
buf eol))
(put-text-property rs re 'wl-summary-action-argument nil)
(put-text-property rs re 'invisible nil)
(goto-char re)
(delete-char (- eol re)))))
(defun wl-summary-collect-numbers-region (begin end)
"Return a list of message number in the region specified by BEGIN and END."
(save-excursion
(save-restriction
(let (numbers)
(wl-summary-narrow-to-region (or begin (point-min))(or end (point-max)))
(goto-char (point-min))
;; for thread...
(if (eq wl-summary-buffer-view 'thread)
(let (number entity)
(while (not (eobp))
(setq numbers (cons (wl-summary-message-number) numbers)
entity (wl-thread-get-entity number))
;; When thread is closed...children should also be checked.
(unless (wl-thread-entity-get-opened entity)
(dolist (msg (wl-thread-get-children-msgs number))
(setq numbers (cons msg numbers))))
(forward-line 1)))
(let (number)
(while (not (eobp))
(setq numbers (cons (wl-summary-message-number) numbers))
(forward-line 1))))
(nreverse (delq nil numbers))))))
(defun wl-summary-exec (&optional numbers)
(interactive)
(let ((failures 0)
collected pair action modified)
(dolist (action wl-summary-mark-action-list)
(setq collected (cons (cons
(wl-summary-action-mark action)
nil) collected)))
(dolist (mark-info wl-summary-buffer-temp-mark-list)
(setq pair
(when (or (null numbers)
(memq (nth 0 mark-info) numbers))
(assoc (nth 1 mark-info) collected)))
(if pair
(setcdr pair (cons mark-info (cdr pair)))))
;; collected is a pair of
;; mark-string and a list of mark-info
(dolist (pair collected)
(when (cdr pair)
(setq action (assoc (car pair) wl-summary-mark-action-list))
(when (wl-summary-action-exec-function action)
(setq modified t)
(setq failures (+ failures (funcall
(wl-summary-action-exec-function action)
(cdr pair)))))))
(when modified
(wl-summary-set-message-modified))
(run-hooks 'wl-summary-exec-hook)
;; message buffer is not up-to-date
(unless (and wl-message-buffer
(eq (wl-summary-message-number)
(with-current-buffer wl-message-buffer
wl-message-buffer-cur-number)))
(wl-summary-toggle-disp-msg 'off)
(setq wl-message-buffer nil))
(set-buffer-modified-p nil)
(when (> failures 0)
(message "%d execution(s) were failed" failures))))
(defun wl-summary-exec-region (beg end)
(interactive "r")
(wl-summary-exec
(wl-summary-collect-numbers-region beg end)))
(defun wl-summary-read-folder (default &optional purpose ignore-error
no-create init)
(let ((fld (completing-read
(format "Folder name %s(%s): " (or purpose "")
default)
'wl-folder-complete-folder
nil nil (or init wl-default-spec)
'wl-read-folder-history)))
(if (or (string= fld wl-default-spec)
(string= fld ""))
(setq fld default))
(setq fld (elmo-string (wl-folder-get-realname fld)))
(if (string-match "\n" fld)
(error "Not supported folder name: %s" fld))
(unless no-create
(if ignore-error
(condition-case nil
(wl-folder-confirm-existence
(wl-folder-get-elmo-folder
fld))
(error))
(wl-folder-confirm-existence (wl-folder-get-elmo-folder
fld))))
fld))
(defun wl-summary-print-argument (msg-num data)
"Print action argument on line."
(when data
(wl-summary-remove-argument)
(save-excursion
(let ((inhibit-read-only t)
(data (copy-sequence data))
(buffer-read-only nil)
len rs re c)
(setq len (string-width data))
(if (< len 1) ()
;;(end-of-line)
(beginning-of-line)
(search-forward "\r")
(forward-char -1)
(setq re (point))
(let ((width (cond (wl-summary-width
(1- wl-summary-width))
(wl-summary-print-argument-within-window
(1- (window-width)))))
(c (current-column))
(padding 0))
(if (and width
(> (+ c len) width))
(progn
(move-to-column width)
(setq c (current-column))
(while (> (+ c len) width)
(forward-char -1)
(setq c (current-column)))
(when (< (+ c len) width)
(setq data (concat " " data)))
(setq rs (point))
(put-text-property rs re 'invisible t))
(when (and width
(> (setq padding (- width len c)) 0))
(setq data (concat (make-string padding (string-to-char " "))
data)))
(setq rs (1- re))))
(put-text-property rs re 'wl-summary-action-argument t)
(goto-char re)
(wl-highlight-action-argument-string data)
(insert data)
(set-buffer-modified-p nil))))))
(defsubst wl-summary-reserve-temp-mark-p (mark)
"Return t if temporal MARK should be reserved."
(member mark wl-summary-reserve-mark-list))
;; Refile prev destination
(defun wl-summary-refile-prev-destination ()
"Refile message to previously refiled destination."
(interactive)
(funcall (symbol-function 'wl-summary-refile)
(wl-summary-message-number)
wl-summary-buffer-prev-refile-destination)
(if (and (interactive-p)
(eq wl-summary-move-direction-downward nil))
(wl-summary-prev)
(wl-summary-next)))
(defun wl-summary-refile-prev-destination-region (beg end)
"Refile messages in the region to previously refiled destination."
(interactive "r")
(wl-summary-mark-region-subr 'wl-summary-refile
beg end
wl-summary-buffer-prev-refile-destination))
(defun wl-thread-refile-prev-destination (arg)
"Refile messages in the thread to previously refiled destination."
(interactive "P")
(wl-thread-call-region-func
'wl-summary-refile-prev-destination-region
arg))
(defun wl-summary-target-mark-refile-prev-destination ()
"Refile messages with target mark to previously refiled destination."
(interactive)
(let ((elem wl-summary-mark-action-list)
action)
(while elem
(when (eq (wl-summary-action-symbol (car elem)) 'refile)
(setq action (car elem))
(setq elem nil))
(setq elem (cdr elem)))
(wl-summary-target-mark-set-action
(list
(car action)
'refile-prev-destination
(lambda (&rest args) wl-summary-buffer-prev-refile-destination)
(nth 2 action)
(nth 3 action)
(nth 4 action)
(nth 6 action)))))
(defsubst wl-summary-no-auto-refile-message-p (number)
(member (wl-summary-message-mark wl-summary-buffer-elmo-folder number)
wl-summary-auto-refile-skip-marks))
(defvar wl-auto-refile-guess-functions
'(wl-refile-guess-by-rule)
"*List of functions which is used for guessing refile destination folder.")
(defun wl-summary-auto-refile (&optional open-all)
"Set refile mark automatically according to 'wl-refile-guess-by-rule'."
(interactive "P")
(message "Marking...")
(save-excursion
(if (and (eq wl-summary-buffer-view 'thread)
open-all)
(wl-thread-open-all))
(let* ((spec (wl-summary-buffer-folder-name))
checked-dsts
(count 0)
number dst thr-entity)
(goto-char (point-min))
(while (not (eobp))
(setq number (wl-summary-message-number))
(dolist (number (cons number
(and (eq wl-summary-buffer-view 'thread)
;; process invisible children.
(not (wl-thread-entity-get-opened
(setq thr-entity
(wl-thread-get-entity number))))
(wl-thread-entity-get-descendant
thr-entity))))
(when (and (not (wl-summary-no-auto-refile-message-p number))
(not (wl-summary-reserve-temp-mark-p
(nth 1 (wl-summary-registered-temp-mark number))))
(setq dst
(wl-folder-get-realname
(wl-refile-guess
(elmo-message-entity wl-summary-buffer-elmo-folder
number)
wl-auto-refile-guess-functions)))
(not (equal dst spec))
(let ((pair (assoc dst checked-dsts))
ret)
(if pair
(cdr pair)
(setq ret
(condition-case nil
(progn
(wl-folder-confirm-existence
(wl-folder-get-elmo-folder dst))
t)
(error)))
(setq checked-dsts (cons (cons dst ret) checked-dsts))
ret)))
(if (funcall (symbol-function 'wl-summary-refile) number dst)
(incf count))
(message "Marking...%d message(s)." count)))
(forward-line))
(if (eq count 0)
(message "No message was marked.")
(message "Marked %d message(s)." count)))))
(defun wl-summary-unmark (&optional number mark)
"Unmark temporary marks of the current line.
If NUMBER is non-nil, remove the mark of the summary line specified by NUMBER.
If MARK is non-nil, remove only the specified MARK from the summary line."
(interactive)
(if (or (null mark)
(string= mark (wl-summary-temp-mark number)))
(wl-summary-unset-mark number (interactive-p))))
(defun wl-summary-unmark-region (beg end)
(interactive "r")
(save-excursion
(save-restriction
(wl-summary-narrow-to-region beg end)
(goto-char (point-min))
(if (eq wl-summary-buffer-view 'thread)
(progn
(while (not (eobp))
(let* ((number (wl-summary-message-number))
(entity (wl-thread-get-entity number)))
(if (wl-thread-entity-get-opened entity)
;; opened...unmark line.
(wl-summary-unmark)
;; closed
(wl-summary-delete-marks-on-buffer
(wl-thread-get-children-msgs number))))
(forward-line 1)))
(while (not (eobp))
(wl-summary-unmark)
(forward-line 1))))))
(defun wl-summary-mark-region-subr (function beg end data)
(save-excursion
(save-restriction
(wl-summary-narrow-to-region beg end)
(goto-char (point-min))
(if (eq wl-summary-buffer-view 'thread)
(progn
(while (not (eobp))
(let* ((number (wl-summary-message-number))
(entity (wl-thread-get-entity number))
(wl-summary-move-direction-downward t)
children)
(if (wl-thread-entity-get-opened entity)
;; opened...delete line.
(funcall function nil data)
;; closed
(setq children (wl-thread-get-children-msgs number))
(while children
(funcall function (pop children) data)))
(forward-line 1))))
(while (not (eobp))
(funcall function nil data)
(forward-line 1))))))
(defun wl-summary-target-mark-all ()
(interactive)
(wl-summary-target-mark-region (point-min) (point-max)))
(defun wl-summary-delete-all-mark (mark)
(goto-char (point-min))
(while (not (eobp))
(wl-summary-unmark nil mark)
(forward-line 1))
(if (string= mark "*")
(setq wl-summary-buffer-target-mark-list nil)
(let (deleted)
(dolist (mark-info wl-summary-buffer-temp-mark-list)
(when (string= (nth 1 mark-info) mark)
(setq deleted (cons mark-info deleted))))
(dolist (delete deleted)
(setq wl-summary-buffer-temp-mark-list
(delq delete wl-summary-buffer-temp-mark-list))))))
(defun wl-summary-unmark-all ()
"Unmark all according to what you input."
(interactive)
(let ((unmarks (string-to-char-list (read-from-minibuffer "Unmark: ")))
cur-mark)
(save-excursion
(while unmarks
(setq cur-mark (char-to-string (car unmarks)))
(wl-summary-delete-all-mark cur-mark)
(setq unmarks (cdr unmarks))))))
(defun wl-summary-target-mark-thread ()
(interactive)
(wl-thread-call-region-func 'wl-summary-target-mark-region t))
(require 'product)
(product-provide (provide 'wl-action) (require 'wl-version))
;;; wl-action.el ends here