2419b2685c0a15eb8d4e143cead76ed6982f569e
[emacs.git] / .emacs.d / elisp / local / ganneff-gnus.el
1 ;;; ganneff.el --- Lotsa functiuons and their variables for stuff
2 ;;; ganneffs .emacs wants
3
4 ;; Copyright (C) 2012 Joerg Jaspert
5
6 ;; Filename: ganneff.de
7 ;; Author: Joerg Jaspert <joerg@debian.org>
8
9 ;; The functions in the bh/ namespace are taken from
10 ;; http://doc.norang.ca/org-mode.org.html which has:
11 ;; #+AUTHOR: Bernt Hansen (IRC:Thumper_ on freenode)
12 ;; #+EMAIL: bernt@norang.ca
13 ;; and the following license statement:
14 ;;
15 ;; This document http://doc.norang.ca/org-mode.html and (either in its
16 ;; HTML format or in its Org format) is licensed under the GNU Free
17 ;; Documentation License version 1.3 or later
18 ;; (http://www.gnu.org/copyleft/fdl.html).
19
20 ;; The code examples and css stylesheets are licensed under the GNU
21 ;; General Public License v3 or later
22 ;; (http://www.gnu.org/licenses/gpl.html).
23
24
25 ;;** Correct message and unread count (http://www.emacswiki.org/emacs/GnusNiftyTricks)
26 (require 'imap)
27
28 ;;;###autoload
29 (defun gnus-nnimap-count-format (n)
30 (let ((method (or gnus-tmp-method gnus-select-method)))
31 (when (eq (car method) 'nnimap)
32 (let ((counts (nnimap-request-message-counts gnus-tmp-group method)))
33 (if counts (format "%d" (nth n counts)) "?")))))
34
35 ;;;###autoload
36 (defun gnus-user-format-function-t (dummy)
37 (or (gnus-nnimap-count-format 0)
38 gnus-tmp-number-total))
39
40 ;;;###autoload
41 (defun gnus-user-format-function-x (dummy)
42 (or (gnus-nnimap-count-format 1)
43 gnus-tmp-number-of-unread))
44
45 (defvar gnus-user-format-function-g-prev "" "")
46 ;;;###autoload
47 (defun empty-common-prefix (left right)
48 "Given `left' '(\"foo\" \"bar\" \"fie\") and `right' '(\"foo\"
49 \"bar\" \"fum\"), return '(\" \" \" \" \"fum\")."
50 (if (and (cdr right) ; always keep the last part of right
51 (equal (car left) (car right)))
52 (cons (make-string (length (car left)) ? )
53 (empty-common-prefix (cdr left) (cdr right)))
54 right))
55 ;;;###autoload
56 (defun gnus-user-format-function-g (arg)
57 "The full group name, but if it starts with a previously seen
58 prefix, empty that prefix."
59 (if (equal gnus-user-format-function-g-prev gnus-tmp-group) ; line-format is updated on exiting the summary, making prev equal this
60 gnus-tmp-group
61 (let* ((prev (split-string-and-unquote gnus-user-format-function-g-prev "\\.\\|:"))
62 (this (split-string-and-unquote gnus-tmp-group "\\.\\|:")))
63 (setq gnus-user-format-function-g-prev gnus-tmp-group)
64 (combine-and-quote-strings
65 (empty-common-prefix prev this)
66 "."))))
67
68
69 (defvar nnimap-message-count-cache-alist nil)
70
71 ;;;###autoload
72 (defun nnimap-message-count-cache-clear ()
73 (setq nnimap-message-count-cache-alist nil))
74
75 ;;;###autoload
76 (defun nnimap-message-count-cache-get (group)
77 (cadr (assoc group nnimap-message-count-cache-alist)))
78
79 ;;;###autoload
80 (defun nnimap-message-count-cache-set (group count)
81 (push (list group count) nnimap-message-count-cache-alist))
82
83 ;;;###autoload
84 (defun nnimap-request-message-counts (group method)
85 (or (nnimap-message-count-cache-get group)
86 (let ((counts (nnimap-fetch-message-counts group method)))
87 (nnimap-message-count-cache-set group counts)
88 counts)))
89
90 ;;;###autoload
91 (defun nnimap-fetch-message-counts (group method)
92 (let ((imap-group (nnimap-decode-gnus-group (car (last (split-string group ":")))))
93 (server (cadr method)))
94 (when (nnimap-change-group imap-group server)
95 (message "Requesting message count for %s..." group)
96 (with-current-buffer (nnimap-buffer)
97 (let ((response
98 (assoc "MESSAGES"
99 (assoc "STATUS"
100 (nnimap-command "STATUS %S (MESSAGES UNSEEN)"
101 (utf7-encode imap-group t))))))
102 (message "Requesting message count for %s...done" group)
103 (and response
104 (mapcar #'string-to-number
105 (list
106 (nth 1 response) (nth 3 response)))))))))
107
108 ;;;###autoload
109 (defun jj-forward-spam ()
110 (interactive)
111 (gnus-summary-mail-forward 1)
112 (message-goto-to)
113 (insert "joerg@ganneff.de")
114 (message-goto-body)
115 (let ((ans (completing-read "Spam / Nospam? "
116 '(("s") ("n"))
117 t nil nil)))
118 (cond ((string= ans "s")
119 (insert "command ganneffcrm spam"))
120 ((string= ans "n")
121 (insert "command ganneffcrm nonspam"))
122 (t
123 (error "Invalid choice.")))))
124
125 ;;;###autoload
126 (defun jj-forward-ham-lists-debconf ()
127 (interactive)
128 (gnus-summary-resend-message "mailmansplit-and-learn-as-ham@smithers.debconf.org" 1)
129 )
130 ;;;###autoload
131 (defun jj-forward-spam-lists-debconf ()
132 (interactive)
133 (gnus-summary-resend-message "mailmansplit-discard-and-learn-as-spam@smithers.debconf.org" 1)
134 )
135
136 ;;;###autoload
137 (defun jj-forward-ham-lists-oftc ()
138 (interactive)
139 (gnus-summary-resend-message "mailmansplit-and-learn-as-ham@lists.oftc.net" 1)
140 )
141
142 ;;;###autoload
143 (defun jj-forward-spam-lists-oftc ()
144 (interactive)
145 (gnus-summary-resend-message "mailmansplit-discard-and-learn-as-spam@lists.oftc.net" 1)
146 )
147
148 ;;;###autoload
149 (defun jj-forward-ham-lists-spi ()
150 (interactive)
151 (gnus-summary-resend-message "mailmansplit-and-learn-as-ham@lists.spi-inc.org" 1)
152 )
153
154 ;;;###autoload
155 (defun jj-forward-spam-lists-spi ()
156 (interactive)
157 (gnus-summary-resend-message "mailmansplit-discard-and-learn-as-spam@lists.spi-inc.org" 1)
158 )
159 ;;;###autoload
160 (defun jj-forward-issue ()
161 (interactive)
162 (gnus-summary-resend-message "ganneff_tm+c57957@rmilk.com" 1)
163 )
164 ;;;###autoload
165 (defun jj-move-mail-spambox ()
166 (interactive)
167 (gnus-summary-move-article nil "nnfolder+archive:Spam" nil))
168 ; (gnus-summary-move-article nil "nnimap+gkar:learnspam" nil))
169
170 ;;;###autoload
171 (defun jj-copy-mail-hambox ()
172 (interactive)
173 (gnus-summary-copy-article nil "nnfolder+archive:Ham" nil))
174
175 ;;** Funktion liefert einen korrekten Datumsstring zurueck, fuer Summaryanzeige
176 ;;;###autoload
177 (defun gnus-user-format-function-y (header)
178 "Convert the DATE to DD.MM.YYYY, HH:MM."
179 (format-time-string "%d.%m.%y, %R"
180 (gnus-date-get-time (mail-header-date header))))
181
182 ;;;###autoload
183 (defun gnus-user-format-function-j (headers)
184 (let ((to (gnus-extra-header 'To headers)))
185 (if (string-match gnus-ignored-from-addresses to)
186 (if (string-match "," to) "~" "»")
187 (if (or (string-match gnus-ignored-from-addresses
188 (gnus-extra-header 'Cc headers))
189 (string-match gnus-ignored-from-addresses
190 (gnus-extra-header 'BCc headers)))
191 "~"
192 " "))))
193
194 ;;** Ich will jeder Nachricht/Mail Header beifügen. Dies tu ich mit Aufruf dieser Funktion.
195 ;;;###autoload
196 (defun my-message-add-content ()
197 (message-add-header "X-GPG-ID: 0xB12525C4")
198 (message-add-header "X-GPG-FP: FBFA BDB5 41B5 DC95 5BD9 BA6E DB16 CF5B B125 25C4")
199 (message-add-header "X-message-flag: Formating hard disk. please wait... 10%... 20%..."))
200
201 ;;** Und was ich hasse sind Antworten auf Mails in Mailinglisten die auch per CC an mich gesandt wird. Son
202 ;;** Scheiss, ich lese die Listen mit wo ich schreibe !
203 ;;;###autoload
204 (defun my-message-header-setup-hook ()
205 (let ((group (or gnus-newsgroup-name "")))
206 (when (or (message-fetch-field "newsgroups")
207 (gnus-group-find-parameter group 'to-address)
208 (gnus-group-find-parameter group 'to-list))
209 (insert "Mail-Copies-To: never\n"))))
210
211
212 ;;** Automagisch neue Mail/News holen.
213 ;;;###autoload
214 (defun us-get-only-mail ()
215 "Fetch new mails"
216 (gnus-group-get-new-news))
217
218 ;;;###autoload
219 (defun september-citation-line ()
220 (interactive)
221 (when message-reply-headers
222 (insert "On "
223 (int-to-string
224 (-
225 (time-to-days (mail-header-parse-date
226 (mail-header-date message-reply-headers)))
227 (time-to-days (encode-time 0 0 0 13 03 1977))))
228 ; (time-to-days (encode-time 0 0 0 01 09 1993))))
229 " March 1977, "
230 (let* ((email (mail-header-from message-reply-headers))
231 (data (mail-extract-address-components email))
232 (name (car data))
233 (net (car (cdr data))))
234 (or name net email))
235 " wrote:\n")))
236
237 ;;** Scorefileeinträge sollen nach bestimmter Zeit automagisch gelöscht werden. Speziell die vom
238 ;;** adaptiven Scoring. Sonst hab ich irgendwann MB grosse Scorefiles.
239 ;;;###autoload
240 (defun gnus-decay-score (score)
241 "Decay SCORE.
242 This is done according to `gnus-score-decay-constant'
243 and `gnus-score-decay-scale'."
244 (floor
245 (- score
246 (* (if (< score 0) 1 -1)
247 (min (abs score)
248 (max gnus-score-decay-constant
249 (* (abs score)
250 gnus-score-decay-scale)))))))
251
252 ;;** Ein Menu für die genialen Message-Utils erstellen.
253 ;;;###autoload
254 (defun message-utils-setup ()
255 "Add menu-entries for message-utils."
256 (easy-menu-add-item nil '("Message")
257 ["Insert Region Marked" message-mark-inserted-region t] "Spellcheck")
258 (easy-menu-add-item nil '("Message")
259 ["Insert File Marked" message-mark-insert-file t] "Spellcheck")
260 (easy-menu-add-item nil '("Field")
261 ["Crosspost / Followup" message-xpost-fup2 t] "----")
262 (easy-menu-add-item nil '("Field")
263 ["New Subject" message-mark-inserted-region t] "----")
264 (easy-menu-add-item nil '("Field")
265 ["Reduce To: to Cc:" message-reduce-to-to-cc t] "----")
266 (easy-menu-add-item nil '("Field")
267 [ "X-No-Archive:" message-add-archive-header t ]))
268
269 ;* This function should be called from the summary buffer with point
270 ;* on the article to nuke. It puts a rule in ~/News/FUCKSTAINS to lower
271 ;* scores of author
272 ;* It needs an entry in all.SCORE of (files "~/News/FUCKSTAINS").
273 ; I changed it to only add the from line.
274 ;;;###autoload
275 (defun gnus-scum-expunge ()
276 "Remove this spammer from existance as much as possible."
277 (interactive)
278 (let* ((hdr (gnus-summary-article-header))
279 (subj (aref hdr 1))
280 (auth (aref hdr 2))
281 (artid (aref hdr 4))
282 (atsign (string-match "@" artid))
283 (host (substring artid (+ atsign 1) (- (length artid) 1)))
284 (oldscfile gnus-current-score-file)
285 (scoredate (time-to-days (current-time))))
286 (gnus-summary-score-entry "references" (concat artid "$") 'R' -1000 scoredate)
287 (gnus-summary-score-entry "references" artid 'S' -500 scoredate)
288 ;; Change to our spammer score file
289 (gnus-score-change-score-file "FUCKSTAINS")
290 ;; Add our horrible spammer scores
291 (gnus-summary-score-entry "Subject" subj 'S' -1000 scoredate)
292 (gnus-summary-score-entry "From" auth 'S' -9999 scoredate)
293 (gnus-summary-score-entry "Message-ID" host 'S' -5 scoredate) ; mild
294 ;; Change back to old current score file
295 (gnus-score-change-score-file oldscfile)
296 (gnus-score-save)))
297
298 ;;;###autoload
299 (defun lld-notmuch-shortcut ()
300 (define-key gnus-group-mode-map "GG" 'notmuch-search)
301 )
302
303 ;;;###autoload
304 (defun lld-notmuch-file-to-group (file)
305 "Calculate the Gnus group name from the given file name."
306 (let ((group (file-name-directory (directory-file-name (file-name-directory file)))))
307 (setq group (replace-regexp-in-string ".*/Maildir/" "nnimap+gkar:" group))
308 (setq group (replace-regexp-in-string "/$" "" group))
309 (if (string-match ":$" group)
310 (concat group "INBOX"))
311 (setq group (replace-regexp-in-string ":\\." ":" group))))
312 ;; Seems like we don't even need this part:
313 ; (setq group (replace-regexp-in-string "nnimap\\+gkar:\\.?" "" group))))
314
315 ;;;###autoload
316 (defun lld-notmuch-goto-message-in-gnus ()
317 "Open a summary buffer containing the current notmuch article."
318 (interactive)
319 (unless (gnus-alive-p) (with-temp-buffer (gnus)))
320 (let ((group (lld-notmuch-file-to-group (notmuch-show-get-filename)))
321 (message-id
322 (replace-regexp-in-string "\"" ""
323 (replace-regexp-in-string "^id:" ""
324 (notmuch-show-get-message-id)))))
325 (if (and group message-id)
326 (progn
327 (gnus-summary-read-group group 100) ; have to show at least one old message
328 (gnus-summary-refer-article message-id)) ; simpler than org-gnus method?
329 (message "Couldn't get relevant infos for switching to Gnus."))))
330
331 ;; this corresponds to a topic line format of "%n %A"
332 ;;;###autoload
333 (defun gnus-user-format-function-topic-line (dummy)
334 (let ((topic-face (if (zerop total-number-of-articles)
335 'gnus-summary-low-ancient
336 'gnus-summary-high-ancient)))
337 (propertize
338 (format "%s %d" name total-number-of-articles)
339 'face topic-face)))
340
341 ;;;###autoload
342 (defun sign-or-crypt ()
343 (interactive)
344 (let ((ans (completing-read "Sign/Inlinesign/Encrypt/Nothing? "
345 '(("s" s) ("i" i) ("e" e) ("n" n))
346 nil t nil)))
347 (cond ((string= ans "s")
348 (mml-secure-message mml-default-sign-method 'sign)
349 ;(message-goto-body)
350 ;(insert "<#secure method=pgpmime mode=sign>\n")
351 )
352 ((string= ans "i")
353 (mml-secure-message "pgp" 'sign))
354 ((string= ans "e")
355 (mml-secure-message-encrypt-pgpmime)
356 ;(message-goto-body)
357 ;(insert "<#secure method=pgpmime mode=signencrypt>\n")
358 )
359 ((string= ans "n")
360 (message "Message sent unmodified."))
361 (t
362 (error "Invalid choice.")))))
363
364 (provide 'ganneff-gnus)