Mercurial > hg > xemacs

comparison my-news.el @ 32:cb9b76219c55

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
attempt to merge mail read and send from all over
author Henry S Thompson <ht@inf.ed.ac.uk>
date Sun, 08 Oct 2023 16:36:27 +0100
parents 0e5b39d2f8bb
children 034ed479179e
comparison
equal deleted inserted replaced
31:129123962e51 32:cb9b76219c55
1 ;; Last edited: Wed Aug 25 14:10:36 1999 1 (message "my-news")
2
3 ;(site-caseq (edin (require 'ccs-gnus)))
4
5 ; mix-spool stuff
6
7 (load "gnus" nil t)
8 ; (debug-on-entry 'gnus-start-news-server) 2 ; (debug-on-entry 'gnus-start-news-server)
9 (setq gnus-nntp-server nil) 3 (setq
10 ; 4 gnus-select-method '(nntp "hebe.uk.clara.net")
11 5 gnus-post-method '(nntp "usenet.inf.ed.ac.uk")
12 6 gnus-nntp-server nil ; override local default
13 (setq gnus-article-save-directory "/home/ht/mail/Mail") 7 )
14 (setq nnml-directory (expand-file-name "/home/ht/mail/Mail")) 8
15 (setq gnus-message-archive-method 9 (setq gnus-use-scoring nil ; not used yet
16 '(nnfolder "archive" 10 gnus-summary-gather-subject-limit nil
17 ;; the following two are not taking effect, not sure why, answer 11 gnus-thread-sort-functions
18 ;; _may_ lie in gnus-setup-news... 12 '(gnus-thread-sort-by-number gnus-thread-sort-by-simpl-subject)
19 (nnfolder-directory "/home/ht/mail/cpy") 13 gnus-summary-line-format "%U%R%5N%I%(%[%4L: %-12,12A%]%) %s\n"
20 (nnfolder-active-file "/home/ht/mail/cpy/active") 14 gnus-summary-make-false-root 'none
21 (nnfolder-get-new-mail nil) 15 gnus-mime-display-multipart-related-as-mixed t
22 (nnfolder-inhibit-expiry t))) 16 gnus-simplify-subject-regexp "^\\(re[:;.]\\| \\|fwd:\\)*")
23 (setq gnus-secondary-select-methods 17
18 (defsubst gnus-trim-simplify-subject (text)
19 (if (string-match gnus-simplify-subject-regexp text)
20 (substring text (match-end 0))
21 text))
22
23 (defun gnus-thread-sort-by-simpl-subject (h1 h2)
24 "sort by slightly simplified subject"
25 ; (message (format "%s:%s %s:%s" (mail-header-number (gnus-thread-header h1))(mail-header-subject (gnus-thread-header h1))(mail-header-number (gnus-thread-header h2))(mail-header-subject (gnus-thread-header h2))))
26 (let ((case-fold-search t))
27 (let ((result
28 (string-lessp
29 (downcase (gnus-trim-simplify-subject (mail-header-subject
30 (gnus-thread-header h1))))
31 (downcase (gnus-trim-simplify-subject (mail-header-subject
32 (gnus-thread-header h2)))))))
33 ; (message (format " %s\n" result))
34 result)))
35
36
37 (setq nnfolder-get-new-mail nil
38 nnfolder-inhibit-expiry t
39 gnus-secondary-select-methods
24 '((nnml "ht" 40 '((nnml "ht"
25 (gnus-show-threads nil) 41 (gnus-show-threads nil)
26 (gnus-article-sort-functions (gnus-article-sort-by-subject gnus-article-sort-by-date)) 42 (gnus-article-sort-functions
43 (gnus-article-sort-by-subject gnus-article-sort-by-date))
27 ))) 44 )))
28 (setq mail-sources '((file :path "/var/spool/mail/ht")))
29 ;;; fixup clarinews 45 ;;; fixup clarinews
30 ;(autoload 'gnus-clarinews-fun "clari-clean" "Clean ClariNews articles" t) 46 ;(autoload 'gnus-clarinews-fun "clari-clean" "Clean ClariNews articles" t)
31 ;(add-hook 'gnus-article-prepare-hook 'gnus-clarinews-fun) 47 ;(add-hook 'gnus-article-prepare-hook 'gnus-clarinews-fun)
32 48
33 49
49 (nntp-header-date b))))))) 65 (nntp-header-date b)))))))
50 reverse 66 reverse
51 )) 67 ))
52 68
53 ;(require 'util-mde) ; for string-replace-regexp-2 69 ;(require 'util-mde) ; for string-replace-regexp-2
54 (defun gnus-trim-simplify-subject (text) 70
55 "call gnus-simplify-subject and remove leading blanks"
56 (if text
57 (gnus-simplify-subject
58 (string-replace-regexp-2
59 (gnus-simplify-subject text t)
60 "^\\s-+"
61 "")
62 t)
63 ""))
64 71
65 (defun gnus-string-equal (a b) 72 (defun gnus-string-equal (a b)
66 "Return T if first arg string is equal than second in lexicographic order. 73 "Return T if first arg string is equal than second in lexicographic order.
67 If case-fold-search is non-nil, case of letters is ignored." 74 If case-fold-search is non-nil, case of letters is ignored."
68 (if case-fold-search 75 (if case-fold-search
77 ; (setq gnus-pre-config nil) 84 ; (setq gnus-pre-config nil)
78 ) 85 )
79 86
80 ;; Database stuff 87 ;; Database stuff
81 (defun open-white () 88 (defun open-white ()
82 (setq whitelist-db (open-database "/disk/scratch/mail/white" 'berkeley-db))) 89 (setq whitelist-db (open-database (concat my-mail-dir "/white") 'berkeley-db)))
83 (defun save-white () 90 (defun save-white ()
84 (close-database whitelist-db) 91 (close-database whitelist-db)
85 (open-white)) 92 (open-white))
86 93
87 (defun open-ad () 94 (defun open-ad ()
88 (setq adlist-db (open-database "/disk/scratch/mail/ad" 'berkeley-db))) 95 (setq adlist-db (open-database (concat my-mail-dir "/ad") 'berkeley-db)))
89 96
90 (defun save-ad () 97 (defun save-ad ()
91 (close-database adlist-db) 98 (close-database adlist-db)
92 (open-ad)) 99 (open-ad))
93 100
94 (defun open-quaker () 101 (defun open-quaker ()
95 (setq quaker-db (open-database "~/mail/quaker" 'berkeley-db))) 102 (setq quaker-db (open-database (concat my-mail-dir "/quaker") 'berkeley-db)))
96 (defun save-quaker () 103 (defun save-quaker ()
97 (close-database quaker-db) 104 (close-database quaker-db)
98 (open-quaker)) 105 (open-quaker))
99 106
107 (defvar database-names '(whitelist-db adlist-db quaker-db) "sic")
108
109 (defun db-status (&optional name)
110 "Check on the whereabouts of a name"
111 (interactive)
112 (let ((addr
113 (or name
114 (progn
115 (gnus-summary-goto-article (gnus-summary-article-number))
116 (get-canonical-from-addr (get-current-from-components)))))
117 res)
118 (dolist (dbn database-names)
119 (if (get-database addr (eval dbn))
120 (setq res (cons dbn res))))
121 (if name
122 res
123 (message "%s" res))))
100 124
101 (defun add-white (&optional addToBBDB) 125 (defun add-white (&optional addToBBDB)
102 (interactive "P") 126 (interactive "P")
103 (gnus-summary-goto-article (gnus-summary-article-number)) 127 (gnus-summary-goto-article (gnus-summary-article-number))
104 (let* ((components (get-current-from-components)) 128 (let* ((components (get-current-from-components))
154 (defun quaker-sig-if-quaker-1 (addr) 178 (defun quaker-sig-if-quaker-1 (addr)
155 (if (get-database addr quaker-db) 179 (if (get-database addr quaker-db)
156 (progn (quaker-sig-maybe) 180 (progn (quaker-sig-maybe)
157 t))) 181 t)))
158 182
159 (defun quaker-sig-maybe ()
160 (save-excursion
161 (goto-char (point-min))
162 (cond ((to-quaker-p)
163 (goto-char (point-min))
164 (cond ((search-forward "\nFrom: ht@home.hst.name" nil t)
165 (backward-char 13)
166 (delete-char 4)
167 (insert "rsof")))))
168
169 (goto-char (point-max))
170 (search-backward "\n-- \n")
171 (when (looking-at "\n-- \nHenry")
172 (forward-char 5)
173 (kill-entire-line 5)
174 (insert-file "~/.quaker-sig"))))
175
176 (defun kill-white () 183 (defun kill-white ()
177 (interactive) 184 (interactive)
178 (gnus-summary-goto-article (gnus-summary-article-number)) 185 (gnus-summary-goto-article (gnus-summary-article-number))
179 (let ((addr (get-current-from-addr))) 186 (let ((addr (downcase (get-current-from-addr))))
180 (rem-white addr))) 187 (rem-white addr)))
188
189 (defun kill-ad ()
190 (interactive)
191 (gnus-summary-goto-article (gnus-summary-article-number))
192 (let ((addr (downcase (get-current-from-addr))))
193 (rem-ad addr)))
181 194
182 (defun get-from-gnus-addr () 195 (defun get-from-gnus-addr ()
183 (get-from-addr (gnus-fetch-field "From"))) 196 (get-from-addr (gnus-fetch-field "From")))
184 197
185 (defun get-from-addr (addr) 198 (defun get-from-addr (addr)
280 (if (get-database addr adlist-db) 293 (if (get-database addr adlist-db)
281 nil 294 nil
282 (put-database addr "t" adlist-db) 295 (put-database addr "t" adlist-db)
283 t)) 296 t))
284 297
285 (defun rem-ad () 298 (defun rem-ad (addr)
286 (interactive) 299 (remove-database addr adlist-db)
287 (remove-database (downcase (get-current-from-addr)) adlist-db)
288 (save-ad)) 300 (save-ad))
289 301
290 (defun new-quaker (addr) 302 (defun new-quaker (addr)
291 (if (get-database addr quaker-db) 303 (if (get-database addr quaker-db)
292 nil 304 nil
293 (put-database addr "t" quaker-db) 305 (put-database addr "t" quaker-db)
294 t)) 306 t))
295 307
296 (defun rem-white (addr) 308 (defun rem-white (addr)
297 (remove-database (downcase addr) whitelist-db)) 309 (remove-database (downcase addr) whitelist-db)
310 (save-white))
298 311
299 (defun bogoOK (group) 312 (defun bogoOK (group)
300 (shell-command-on-region (point-min) (point-max) 313 (shell-command-on-region (point-min) (point-max)
301 "/afs/inf.ed.ac.uk/user/h/ht/share/bin/local/makeNonBogo") 314 "/afs/inf.ed.ac.uk/user/h/ht/share/bin/local/makeNonBogo")
302 'delete) 315 'delete)
321 (forward-char -3) 334 (forward-char -3)
322 (setq done (gnus-summary-mark-as-read-forward 1)))))))) 335 (setq done (gnus-summary-mark-as-read-forward 1))))))))
323 (gnus-summary-limit-to-unread) 336 (gnus-summary-limit-to-unread)
324 (gnus-summary-sort-by-original)) 337 (gnus-summary-sort-by-original))
325 338
339 (defun mark-and-mark (n)
340 (interactive "p")
341 (while (>= n 1)
342 (gnus-summary-mark-as-read)
343 (gnus-summary-mark-as-processable 1)
344 (setq n (- n 1))))
345
346 (defun split-on-whole-field (field pat list)
347 (goto-char (point-max))
348 (let ((hit (assq pat wsp-cache))
349 rpat)
350 (if hit
351 (setq rpat (cdr hit))
352 (setq rpat
353 (concat "^"
354 field
355 ":\\s-*"
356 (if (stringp pat)
357 pat
358 (cdr (assq pat
359 nnmail-split-abbrev-alist)))
360 "$"))
361 (setq wsp-cache (cons (cons pat rpat) wsp-cache)))
362 (if (re-search-backward rpat nil t)
363 list)))
364
365 (defun ht-gnus-summary-delete-forward ()
366 "REAL delete for nnmail gnus"
367 (interactive)
368 (gnus-summary-delete-article)
369 (gnus-summary-next-unread-article))
370
371 ;; run the first time we make a summary window
372 (defun gnus-summary-mode-fun1 ()
373 "install ht's mods"
374 (define-key gnus-summary-mode-map "D" 'ht-gnus-summary-delete-forward)
375 (define-key gnus-summary-mode-map "~" 'mark-and-mark)
376 (define-key gnus-summary-mode-map "\M-d" 'gnus-edit-and-move-to-diary)
377 (define-key gnus-summary-mode-map "\M-e" 'gnus-extract-attachment)
378 (define-key gnus-summary-mode-map "\M-w" 'add-white)
379 (define-key gnus-summary-mode-map [(control meta w)] 'copy-region-to-kill)
380 (define-key gnus-summary-mode-map "\M-h" 'showMPAhtml)
381 ;(define-key gnus-summary-mode-map [(control meta w)] 'kill-white)
382 (define-key gnus-summary-mode-map "\M-a" 'add-ad)
383 (define-key gnus-summary-mode-map "\M-n" 'ht-next-unseen-maybe)
384 (define-key gnus-summary-mode-map "\M-c" 'ht-catchup-and-next-unseen)
385 (define-key gnus-summary-mime-map "O" 'ht-article-save-parts)
386 (define-key gnus-summary-backend-map "M" 'ht-move-to-pers)
387 (remove-hook 'gnus-summary-mode-hook 'gnus-summary-mode-fun1))
388
389 (defun message-mode-fun1 ()
390 (define-key message-mode-map [(control meta q)] 'add-quaker)
391 (remove-hook 'message-mode-hook 'message-mode-fun1))
392
393 (defvar ht-gnus-just-read nil)
394
395 (defun ht-catchup-and-next-unseen ()
396 (interactive)
397 (when (gnus-summary-catchup nil t nil 'fast)
398 (gnus-summary-exit)
399 (previous-line 1)
400 (ht-next-with-unseen 1)))
401
402 (defun ht-next-unseen-maybe (n)
403 (interactive "p")
404 (cond
405 ((eq (gnus-summary-next-unread-subject n) n)
406 (gnus-summary-exit)
407 (previous-line 1)
408 (if (ht-next-with-unseen n)
409 (ht-read-group-unseen-only)))))
410
411 (defun ht-gnus-pers-refresh (n)
412 (interactive "p")
413 (let ((gn (concat "nnml+ht:pers-"
414 (format-time-string "%Y-%m" (current-time)))))
415 (gnus-group-get-new-news)
416 (let ((nn (gnus-number-of-unseen-articles-in-group gn)))
417 (gnus-group-goto-group gn)
418 (cond
419 ((> nn 0)
420 (gnus-group-read-group nn))
421 ((> n 1)
422 (let ((gnus-auto-select-subject
423 (lambda ()
424 (goto-char (point-max))
425 (previous-line 1))))
426 (gnus-group-read-group nil t)))
427 (t (goto-char (point-min))
428 (ht-next-with-unseen 1))))
429 (message "%s" ht-gnus-just-read))
430 )
431
432 (defun no-select ()
433 (if (member gnus-newsgroup-name no-select-groups)
434 (progn (make-variable-buffer-local 'gnus-auto-select-first)
435 (setq gnus-auto-select-first nil))))
326 436
327 (defun showMPAhtml () 437 (defun showMPAhtml ()
328 "Show the text/html parts of an multipart/alternative message using lynx" 438 "Show the text/html parts of an multipart/alternative message using lynx"
329 (interactive) 439 (interactive)
330 (gnus-summary-select-article) 440 (gnus-summary-select-article)
331 (with-current-buffer gnus-original-article-buffer 441 (with-current-buffer gnus-original-article-buffer
332 (shell-command-on-region (point-min) (point-max) "/home/ht/bin/showMPA.sh") 442 (shell-command-on-region (point-min) (point-max)
443 (expand-file-name "~/bin/showMPA.sh"))
333 ) 444 )
334 ) 445 )
335 446
447
448 ;; run the first time we make a group window
449 (defun gnus-group-mode-fun1 ()
450 "install ht's mods"
451 (require 'gnus-msg)
452 (define-key gnus-group-mode-map "\M-\C-g" 'ht-gnus-pers-refresh)
453 (define-key gnus-group-mode-map "\M-n" 'ht-next-with-unseen)
454 (define-key gnus-group-mode-map "\M-p" 'ht-previous-with-unseen)
455 (define-key gnus-group-mode-map "\M- " 'ht-read-group-unseen-only)
456 (define-key gnus-send-bounce-map "R" 'resend-to-schemadev)
457 (define-key gnus-send-bounce-map "x" 'flush-all-nogoods)
458 (remove-hook 'gnus-group-mode-hook 'gnus-group-mode-fun1))
459
460 (defun flush-all-nogoods ()
461 (interactive)
462 (while (re-search-forward
463 "] \\(\\(Returned\\|\\([Uu]n\\|[Nn]on-?\\)deliver\\(able\\|ed\\)\\)\\( [Mm]ail\\|:?\\)\\|DELIVERY FAILURE\\|Delivery \\(Notification: Delivery has failed\\|Status Notification .\\(Failure\\|Delay\\).\\)\\|failure \\(notice\\|delivery\\)\\)"
464 nil t)
465 (gnus-summary-mark-as-read)
466 (end-of-line)))
467
468 (defun gnus-user-format-function-t (header)
469 "display the to field (for archive messages)"
470 (let ((n (mail-header-number header)))
471 (with-current-buffer nntp-server-buffer
472 (save-excursion
473 (save-restriction
474 (let ((inhibit-point-motion-hooks t))
475 (goto-char (point-min))
476 (let ((beg (search-forward (format " %d Article retrieved." n)))
477 (end (search-forward "\n.\n")))
478 (narrow-to-region beg end)
479 (goto-char beg)
480 (message-fetch-field "To"))))))))
481
482 (defun gnus-extract-attachment ()
483 "extract attachments from a multi-part mime message"
484 (interactive)
485 (let ((sm gnus-show-mime))
486 (if sm
487 (progn (setq gnus-show-mime nil)
488 (gnus-summary-select-article t 'force))
489 )
490 (gnus-summary-show-all-headers)
491 (with-current-buffer gnus-article-buffer
492 (save-excursion
493 (save-restriction
494 (mime/viewer-mode)
495 (delete-other-windows)
496 (let ((pt 0))
497 (while (progn
498 (mime-viewer/next-content)
499 (and
500 (equal "*Preview-*Article**" (buffer-name (current-buffer)))
501 (not (= pt (point)))))
502 (setq pt (point))
503 (if (looking-at "^\\[[0-9]* \\([^ ]+ \\)+<")
504 (mime-viewer/extract-content)))))))
505 (kill-buffer "*Preview-*Article**")
506 (setq gnus-show-mime sm)
507 ))
508
509 ;;; Why???
510 (make-variable-buffer-local 'gnus-extra-headers)
511 (make-variable-buffer-local 'nnmail-extra-headers)
512
513
514 (defun resend-to-schemadev ()
515 (interactive)
516 (message "forwarding to xmlschema-dev")
517 (gnus-summary-resend-message "xmlschema-dev@w3.org" 1)
518 (gnus-summary-next-unread-article))
519
520 (defun brutal-resend ()
521 (interactive)
522 (message "editing for resend. . .")
523 (unless (eq (gnus-summary-article-number)
524 gnus-current-article)
525 (gnus-summary-select-article t))
526 (gnus-summary-toggle-header 1)
527 (with-current-buffer gnus-article-buffer
528 (toggle-read-only)
529 (gnus-article-date-original)
530 (goto-char (point-min))
531 (replace-regexp "^\\(X-Diagnostic\\|X-Envelope-To\\|X-Original-To\\|Delivered-To\\):.*\n" "")
532 (goto-char (point-min))
533 (gnus-summary-edit-article-done
534 (or (mail-header-references gnus-current-headers) "")
535 (gnus-group-read-only-p) gnus-summary-buffer nil))
536 (call-interactively (function gnus-summary-resend-message))
537 (gnus-summary-next-unread-article))
538
539 ; (unless (fboundp 'builtin-coding-system-p)
540 ; (fset 'builtin-coding-system-p (symbol-function 'coding-system-p))
541 ; (defun coding-system-p (obj)
542 ; (cond
543 ; ((builtin-coding-system-p obj) t)
544 ; ((memq obj '(utf-8 gb2312 koi8-r iso-8859-1))
545 ; (message (format "Coding system: %s" obj))
546 ; t))))
547
548 ;;; dangerous hack to improve display of names and subjects in mail/news
549 (if nil (progn
550 (require 'mm-util)
551 (defun mm-decode-coding-string (str cs)
552 (if (and str (eq cs 'utf-8))
553 (if (or (string-match "Â" str)
554 (string-match "Ã" str))
555 (let* ((r 0) ; read pointer
556 (w 0) ; write pointer
557 (l (length str)))
558 (while (< r l)
559 (let* ((c (aref str r))
560 (i (char-int c)))
561 (cond ((= i 194)
562 (aset str w (aref str (+ r 1)))
563 (setq r (+ r 2)))
564 ((= i 195)
565 (aset str w
566 (int-char
567 (+ 64
568 (char-int (aref str (+ r 1))))))
569 (setq r (+ r 2)))
570 (t
571 (aset str w c)
572 (setq r (+ r 1)))))
573 (setq w (+ w 1)))
574 (substring str 0 w))
575 str)
576 str))
577
578 (defun mm-sort-coding-systems-predicate (a b)
579 ;; from mm-util, abort if no priorities
580 (or (not mm-coding-system-priorities)
581 (let ((priorities
582 (mapcar (lambda (cs)
583 ;; Note: invalid entries are dropped silently
584 (and (setq cs (mm-coding-system-p cs))
585 (coding-system-base cs)))
586 mm-coding-system-priorities)))
587 (and (setq a (mm-coding-system-p a))
588 (if (setq b (mm-coding-system-p b))
589 (> (length (memq (coding-system-base a) priorities))
590 (length (memq (coding-system-base b) priorities)))
591 t)))))))
592
593 (require 'browse-url)
594
595 ;;; This version collects extra lines if you use right-button
596 ;;; to click on a URL
597 (defun browse-url (url &rest args)
598 "Ask a WWW browser to load URL.
599 Prompts for a URL, defaulting to the URL at or before point. Variable
600 `browse-url-browser-function' says which browser to use."
601 (interactive (browse-url-interactive-arg "URL: "))
602 (unless (interactive-p)
603 (setq args (or args (list browse-url-new-window-flag))))
604 (if (and (boundp 'event)(= 3 (event-button event)))
605 (let ((thisLine url))
606 (while (and (progn (forward-char (length thisLine))
607 (eolp))
608 (progn (forward-line 1)
609 (beginning-of-line)
610 (not (looking-at "\\s-"))))
611 (looking-at "\\S-*")
612 (setq thisLine (buffer-substring (match-beginning 0)
613 (match-end 0)))
614 (setq url (concat url thisLine)))))
615 (if (functionp browse-url-browser-function)
616 (apply browse-url-browser-function url args)
617 ;; The `function' can be an alist; look down it for first match
618 ;; and apply the function (which might be a lambda).
619 (catch 'done
620 (dolist (bf browse-url-browser-function)
621 (when (string-match (car bf) url)
622 (apply (cdr bf) url args)
623 (throw 'done t)))
624 (error "No browse-url-browser-function matching URL %s"
625 url))))
626
627 (defun gnus-user-format-function-H (dummy)
628 (format "%c"
629 (cond ((eq gnus-tmp-summary-live ?*)
630 ?*)
631 ((> (gnus-number-of-unseen-articles-in-group gnus-tmp-group) 0)
632 ?.)
633 (t ? ))))
634
635 (defun ht-next-with-unseen (n)
636 (interactive "p")
637 (let* ((gvl (mapcar (function string-to-number)
638 (split-string gnus-version-number "\\.")))
639 (pattern (if (or (> (car gvl) 5)
640 (and (eq (car gvl) 5)
641 (or (> (cadr gvl) 10)
642 (and (eq (cadr gvl) 10)
643 (> (caddr gvl) 7)))))
644 "\\."
645 ":\\.")))
646 (if (looking-at pattern)
647 (if (< n 0)
648 (backward-char 1)
649 (forward-char 1)))
650 (let ((missing 0)
651 (winning (looking-at pattern)))
652 (while (and (zerop missing)
653 (not winning))
654 (setq missing (gnus-group-next-unread-group n))
655 (setq winning (looking-at pattern)))
656 winning)))
657
658 (defun ht-read-group-unseen-only ()
659 (interactive)
660 (gnus-group-read-group
661 (gnus-number-of-unseen-articles-in-group (gnus-group-group-name))))
662
663 (defun ht-previous-with-unseen (n)
664 (interactive "p")
665 (ht-next-with-unseen (- n)))
666
667 (defun ht-gnus-note-save-to-group ()
668 (let ((g (caar group-art)))
669 (if (not (member g ht-gnus-just-read))
670 (setq ht-gnus-just-read (cons g ht-gnus-just-read)))))
671
672 (defvar ht-stash-directory (concat my-mail-dir "/stash/"))
673
674 (defun ht-save-part (handle n)
675 (let ((sup-type (mm-handle-media-supertype handle))
676 (sub-type (mm-handle-media-subtype handle)))
677 (message (format "%s %s/%s" n sup-type sub-type))
678 (cond ((and (equal sup-type "multipart")
679 (or (equal sub-type "alternative")
680 (equal sub-type "related")))
681 (let ((alts (cddr handle))
682 (j 0))
683 (while alts
684 (let* ((alt (pop alts))
685 (handle-type (mm-handle-type alt)))
686 (let* ((sub (mm-handle-media-subtype alt))
687 (ext (cdr
688 (assoc sub '(("calendar" . "vcs")
689 ("v-calendar" . "vcs"))))))
690 (setq j (+ j 1))
691 (if (not (or (mail-content-type-get
692 (mm-handle-disposition alt) 'filename)
693 (mail-content-type-get
694 handle-type 'name)))
695 (nconc
696 handle-type
697 (list (cons 'name (format "%s.%s.%s"
698 n j (or ext sub))))))
699 (ht-save-part alt (format "%s.%s" n j)))))))
700 ((and (equal sup-type "text")(not
701 (member sub-type '("html"
702 "v-calendar"
703 "calendar"))))
704 (message "Skipping text part: %s" (mm-handle-disposition handle)))
705 (t
706 (mm-save-part handle)))))
707
708 (defun ht-move-to-pers (n)
709 (interactive "p")
710 (gnus-summary-move-article n
711 (concat
712 "nnml+ht:pers-"
713 (format-time-string "%Y-%m" (current-time)))))
714
715 (defun ht-article-save-parts (n)
716 "Save non t/p MIME parts starting at N, which is the numerical prefix."
717 (interactive "p2")
718 (let ((window (get-buffer-window gnus-article-buffer 'visible))
719 frame)
720 (when window
721 ;; It is necessary to select the article window so that
722 ;; `gnus-article-goto-part' may really move the point.
723 (setq frame (selected-frame))
724 (gnus-select-frame-set-input-focus (window-frame window))
725 (unwind-protect
726 (save-window-excursion
727 (select-window window)
728 (let ((len (length gnus-article-mime-handle-alist)))
729 (setq mm-default-directory ht-stash-directory)
730 (while (<= n len)
731 (gnus-article-goto-part n)
732 (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
733 (ht-save-part handle n))
734 (setq n (+ n 1))
735 )))
736 (gnus-select-frame-set-input-focus frame))))
737 )
738
739
740 (defun gnus-article-part-wrapper (n function)
741 (let ((window (get-buffer-window gnus-article-buffer 'visible))
742 frame)
743 (when window
744 ;; It is necessary to select the article window so that
745 ;; `gnus-article-goto-part' may really move the point.
746 (setq frame (selected-frame))
747 (gnus-select-frame-set-input-focus (window-frame window))
748 (unwind-protect
749 (save-window-excursion
750 (select-window window)
751 (when (> n (length gnus-article-mime-handle-alist))
752 (error "No such part"))
753 (gnus-article-goto-part n)
754 (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
755 (funcall function handle)))
756 (gnus-select-frame-set-input-focus frame)))))
757
758 (defun mhstore-me (dir)
759 (interactive (list (read-directory-name "Save parts to " "/tmp" "/tmp" t)))
760 (let ((art (gnus-summary-article-number)))
761 (let* ((grp-parts (split-string gnus-newsgroup-name ":"))
762 (meth (car grp-parts))
763 (grp (cadr grp-parts)))
764 (if (string= meth "nnml+ht")
765 (let ((doit
766 (format (concat "cd %s && mhstore -f "
767 my-mail-dir "/Mail/%s/%s) -auto")
768 dir grp art)))
769 (message doit)
770 (shell-command doit))
771 ))))
772
773 (defun my-message-send-and-exit (&optional arg)
774 (interactive "P")
775 (let ((message-required-mail-headers
776 (if arg
777 (mapcar
778 (lambda(x)
779 (if(and(consp x)(eq(cdr x)'In-Reply-To))
780 (cons 'optional 'xyzzy)
781 x))
782 message-required-mail-headers)
783 message-required-mail-headers)))
784 (orig-message-send-and-exit)))
785
786 (require 'message)
787 (if (not (fboundp 'orig-message-send-and-exit))
788 (progn
789 (fset 'orig-message-send-and-exit (symbol-function 'message-send-and-exit))
790 (fset 'message-send-and-exit (symbol-function 'my-message-send-and-exit))))
791
336 (provide 'my-news) 792 (provide 'my-news)