;; -*- emacs-lisp -*- ;;; gnus-homebrew.el --- small customised functions, code snippets etc. ;; Description: This isn't intended to work for anyone but me, but you're ;; welcome to try :o) ;; Author: Mark Triggs ;; Keywords: news ;; $Id: gnus-homebrew.el,v 1.98 2007/03/04 11:06:41 mst Exp $ ;; This file 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 file 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. ;;; Code: (defun gnus-mst-summary-aol-cleanup () "Word wrap, capitalize, remove excess whitespace" (interactive) (gnus-article-strip-leading-space) (gnus-article-strip-trailing-space) (gnus-article-fill-cited-article) (gnus-article-strip-multiple-blank-lines) (gnus-article-treat-dumbquotes) (gnus-article-capitalize-sentences)) (add-hook 'gnus-exit-gnus-hook 'gnus-mst-demon-stuff) (defun gnus-mst-demon-stuff () (interactive) (ignore-errors (gnus-group-expire-all-mail-groups) ; (gnus-agent-expire) )) (gnus-demon-add-handler 'gnus-mst-demon-stuff 30 t) (gnus-demon-init) (defun gnus-mst-summary-show-correspondence () (interactive) (let ((person (read-string "Regular expression to match: "))) (goto-char (point-min)) (gnus-summary-execute-command "From" person "#" nil) (gnus-summary-execute-command "To" person "#" nil) (gnus-summary-execute-command "Cc" person "#" nil) (gnus-summary-limit-to-articles nil))) (defun gnus-auto-check () (interactive) (gnus-demon-add-handler 'gnus-group-get-new-news 1 nil)) (defun message-mst-irritate-non-gnus-users () "tee hee hee" (interactive) (require 'gnus-uu) ;; Caesar Rotate (message-caesar-buffer-body) ;; Uuencode the buffer (goto-char (point-min)) (search-forward "text follows this line") (next-line 1) (beginning-of-line) (shell-command-on-region (point) (point-max) "uuencode -" nil t nil) (newline) (previous-line 2) (save-restriction (narrow-to-region (point) (point-max)) (gnus-uu-post-make-mime "foobar.txt" "x-uue") (kill-line))) ;; Nuke leading whitespace from a message (defun message-mst-nuke-whitespace () (interactive) (ignore-errors (save-excursion (message-goto-body) (previous-line 1) (delete-blank-lines)))) (defvar message-mst-suppress-confirm nil "Ask for confirmation before sending a message") (defun message-mst-toggle-confirm () (interactive) (cond (gnus-mst-suppress-confirm (setq message-mst-suppress-confirm nil) (message "Confirm message send enabled")) (t (setq message-mst-suppress-confirm t) (message "Confirm message send disabled")))) ;; Confirm before sending a message (defun message-mst-confirm () (unless message-mst-suppress-confirm (unless (y-or-n-p "Send this message? ") (signal 'quit nil)))) (defun gnus-mst-summary-nuke-thread () "Kill the current thread" (interactive) (gnus-summary-top-thread) (gnus-summary-kill-thread)) (defun gnus-mst-summary-collapse-low-thread (value) "Collapse a thread whose score is lower than a certain value" (interactive) (let* ((mst-header (gnus-summary-article-header)) (mst-id (mail-header-id mst-header)) (mst-thread (gnus-id-to-thread mst-id)) (mst-score (gnus-thread-total-score mst-thread))) (when (< mst-score value) (gnus-summary-hide-thread)))) (defun gnus-mst-summary-collapse-thread (value threshold) "Collapse a thread if 'threshold'% of articles in the thread have a score of 'value'" (interactive) (unless (and (>= threshold 0) (<= threshold 1)) (error "Threshold must be between 0 and 1")) (let* ((mst-header (gnus-summary-article-header)) (mst-id (mail-header-id mst-header)) (mst-thread (gnus-id-to-thread mst-id)) (mst-articles (gnus-summary-number-of-articles-in-thread mst-thread)) (crossposts 0) (value-str (number-to-string value))) (dotimes (counter mst-articles) (when (string-equal value-str (gnus-summary-current-score)) (incf crossposts)) (next-line 1)) (previous-line mst-articles) (when (> crossposts (* threshold mst-articles)) (gnus-summary-hide-thread)))) (defun gnus-mst-backup (&optional mail-backup-directory) "Export mail in the topics 'gnus-mst-backup-topics' to 'mail-backup-directory'" (interactive) (when (not mail-backup-directory) (setq mail-backup-directory (read-string "Enter a directory to backup mail to (it will be created): "))) (if (file-exists-p mail-backup-directory) (when (not noninteractive) (error "The directory you specified already exists")) (let ((gnus-mst-backup-groups nil) (articles)) (mapc (lambda (n) (when (member (car n) gnus-mst-backup-topics) (setq gnus-mst-backup-groups (append gnus-mst-backup-groups (remove-if-not (lambda (x) (eq (car (gnus-group-method x)) 'nnml)) (cdr n)))))) gnus-topic-alist) (make-directory mail-backup-directory) (save-excursion (mapc (lambda (group) (switch-to-buffer gnus-group-buffer) (gnus-group-jump-to-group group) (when (gnus-group-quick-select-group t) (gnus-summary-execute-command "From" ".*" "#" nil) (setq articles (gnus-summary-work-articles nil)) (mapc (lambda (current-article) (save-excursion (ignore-errors (let ((gnus-display-mime-function nil) (gnus-article-prepare-hook nil)) (gnus-summary-goto-article current-article t) (gnus-eval-in-buffer-window gnus-article-buffer (gnus-output-to-mail (concat mail-backup-directory "/" group))))))) articles) (gnus-summary-exit))) gnus-mst-backup-groups))) (message (concat "Backup to " mail-backup-directory " complete")))) (defun gnus-mst-close-all-servers () "Close all servers" (interactive) (save-window-excursion (save-excursion (gnus-group-enter-server-mode)) (gnus-eval-in-buffer-window "*Server*" (gnus-server-close-all-servers) (gnus-server-exit)))) (try-require 'bbdb) (when (featurep 'bbdb) (defun gnus-mst-gpg-recipient () "set gpg stuff for the recipient if appropriate" (when (and (not message-has-gpg) (message-mail-p)) (setq message-has-gpg t) (let* ((to_field (mail-fetch-field "to")) (to_components (mail-extract-address-components to_field t)) (recipient)) (when (= (length to_components) 1) ;; Only a single recipient (good) (setq recipient (nth 1 (car to_components))) (let* ((record (bbdb-search-simple nil recipient)) (gpg)) (when record (setq gpg (bbdb-get-field record 'gnus-gpg))) (when (> (length gpg) 0) (cond ((string= gpg "sign") (mml-secure-message-sign-pgpmime)) ((string= gpg "encrypt") (mml-secure-message-encrypt-pgpmime)) (t nil))))))))) (add-hook 'message-mode-hook (lambda () (make-variable-buffer-local 'message-has-gpg) (setq message-has-gpg nil))) (defun gnus-mst-expunge-lamer () "Expunge all posts and followups to the current author" (interactive) (save-window-excursion (gnus-summary-show-article) (gnus-summary-select-article-buffer) (let ((author (gnus-fetch-field "From"))) (gnus-summary-score-entry "from" author 'substring -500000 (+ (date-to-day (time-stamp-string)) gnus-score-expiry-days)) (gnus-summary-score-entry "followup" author 'substring -500000 (+ (date-to-day (time-stamp-string)) gnus-score-expiry-days))))) (defun sync-mail () "Export local mailboxes to mbox files for consumption by gnus on my main machine" (interactive) (gnus-mst-backup "/home/mst/tempmail") (shell-command (concat "(cd /home/mst/tempmail;" "for i in *;do cat $i >> ~/main/docs/mail/laptop/$i;done)")) (shell-command "rm -rf /home/mst/tempmail") ;; This is really ugly code. Re-used from old ugly code. (let (gnus-mst-backup-groups) (mapc (lambda (n) (when (member (car n) gnus-mst-backup-topics) (setq gnus-mst-backup-groups (append gnus-mst-backup-groups (remove-if-not (lambda (x) (eq (car (gnus-group-method x)) 'nnml)) (cdr n)))))) gnus-topic-alist) (save-excursion (mapc (lambda (group) (switch-to-buffer gnus-group-buffer) (gnus-group-jump-to-group group) (when (gnus-group-quick-select-group t) (gnus-uu-mark-all) (let ((gnus-novice-user nil)) (gnus-summary-delete-article nil)))) gnus-mst-backup-groups)))) (defun gnus-list-groups () "Return a list of groups" (let ((groups '())) (mapatoms (lambda (n) (and (boundp n) (symbol-value n) (push (symbol-name n) groups))) gnus-active-hashtb) groups)) (defun gnus-agent-get-groups (method) "Download stuff from covered groups of a particular method" (interactive "SMethod: ") (let* ((groups (mapcan (lambda (group) (if (eql (car (gnus-group-method group)) method) (list group) nil)) (gnus-list-groups))) (covered-groups (mapcan (lambda (group) (if (gnus-agent-group-covered-p group) (list group) nil)) groups))) (save-excursion (mapc (lambda (group) (gnus-group-jump-to-group group) (call-interactively 'gnus-agent-fetch-groups)) covered-groups)))) ;;; You wouldn't think I'd need this.. (defun message-has-attachment-p () (save-excursion (goto-char (point-min)) (re-search-forward "<#part.*disposition=\\(attachment\\|inline\\)" nil t))) (defun message-check-for-forgotten-attachments () (save-excursion (goto-char (point-min)) (when (and (or (re-search-forward "^[^>].*attached" nil t) (re-search-forward "^[^>].*ll attach" nil t)) (not (message-has-attachment-p))) (when (y-or-n-p "Did you forget your attachment? ") (error "Forgotten attachment!"))))) (defun message-move-parts-to-bottom () "Move <#part ..> tags to the bottom of the buffer (after the signature)" (interactive) (message-goto-body) (unless (looking-at "<#multipart type=digest>") (previous-line 1) (let ((temp-buffer (get-buffer-create (generate-new-buffer-name " *temp*")))) (while (not (save-excursion (end-of-line) (eobp))) (if (or (looking-at "<#part.*disposition=\\(attachment\\|inline\\)") (looking-at "<#/part")) (let ((start (line-beginning-position)) (end (line-end-position)) (buf (current-buffer))) (with-current-buffer temp-buffer (insert-buffer-substring buf start end)) (delete-region start end) (delete-blank-lines)) (next-line 1))) (newline) (insert-buffer temp-buffer) (kill-buffer temp-buffer) (save-excursion (goto-char (point-max)) (delete-blank-lines))))) (defun save-as-spam (&rest ignored) (gnus-summary-save-in-pipe "bogofilter -Ns")) (defun spam () "Record the current article as spam" (interactive) (let ((gnus-default-article-saver 'save-as-spam) (gnus-save-all-headers t)) (gnus-summary-save-process-marks (gnus-summary-save-article nil t))) (gnus-summary-move-article nil "spam" nil nil)) (defmacro gnus-summary-save-process-marks (&rest body) `(progn (gnus-summary-save-process-mark) ,@body (gnus-summary-yank-process-mark))) (defun save-as-ham (&rest ignored) (gnus-summary-save-in-pipe "bogofilter -Sn")) (defun ham () "Record the current article as ham" (interactive) (let ((gnus-default-article-saver 'save-as-ham) (gnus-save-all-headers t)) (gnus-summary-save-process-marks (gnus-summary-save-article nil t))) (call-interactively 'gnus-mst-summary-move-article)) (eval-after-load "nnrss" '(progn ;; (defun nnrss-node-text (namespace local-name element) ;; (let* ((node (assq (intern (concat namespace (symbol-name local-name))) ;; element)) ;; (text (if (and node (listp node)) ;; (nnrss-node-just-text node) ;; node))) ;; (if (string-equal "" text) ;; nil ;; text))) ;; This stops newlines from being nuked by split-string. (defadvice nnrss-request-article (around nnrss-request-article-keep-newlines activate) (flet ((split-string (string &rest ignored) (list string))) ad-do-it)))) ;; ;; Hack for lambda-the-ultimate.org ;; (eval-after-load "xml" ;; '(progn ;; (defadvice xml-parse-region (before work-for-ltu activate) ;; (save-excursion ;; (goto-char beg) ;; (when (search-forward-regexp ;; "" nil (point-min) (point-max)) (replace-string "/blog" "http://repose.cx/blog" nil (point-min) (point-max)) (setq gnus-cite-prefix-alist nil gnus-cite-attribution-alist nil gnus-cite-loose-prefix-alist nil gnus-cite-loose-attribution-alist nil gnus-cite-article nil)))) (gnus-article-wash-html) (gnus-article-fill-cited-article)) (defun gnus-group-expire-all-mail-groups () "Expire all mail groups." (interactive) (save-excursion (gnus-message 5 "Expiring...") (let ((gnus-group-marked (remove-if-not (lambda (group) (eq (car (gnus-find-method-for-group group)) 'nnml)) (mapcar (lambda (info) (gnus-info-group info)) (cdr gnus-newsrc-alist))))) (gnus-group-expire-articles nil))) (gnus-group-position-point) (gnus-message 5 "Expiring...done")) (defun google-for-this-message () (interactive) (gnus-summary-show-article t) (with-current-buffer gnus-article-buffer (let ((id (subseq (message-fetch-field "message-id") 1 -1))) (browse-url (format "http://groups-beta.google.com/groups?as_umsgid=%s" id)))) (gnus-summary-show-article nil)) (defun show-ask-et-article () (interactive) (unless (boundp 'et-article-contents) (set (make-local-variable 'et-article-contents) (make-hash-table :test 'equal))) (save-excursion (mm-setup-w3m) (goto-char (point-min)) (search-forward "http://") (let ((url (buffer-substring (line-beginning-position) (line-end-position)))) (let ((inhibit-read-only t)) (gnus-narrow-to-body) (unwind-protect (progn (delete-region (point-min) (point-max)) (if (gethash url et-article-contents) (insert (gethash url et-article-contents)) (mm-url-insert url) (puthash url (buffer-substring (point-min) (point-max)) et-article-contents)) (let ((w3m-display-inline-images t)) (w3m-region (point-min) (point-max) url)) ) (widen)))) (w3m-minor-mode))) (defun inline-rss-article () (interactive) (unless (boundp 'inline-article-contents) (set (make-local-variable 'inline-article-contents) (make-hash-table :test 'equal))) (let ((url (save-excursion (let ((gnus-article-prepare-hook '()) (gnus-display-mime-function nil)) (gnus-summary-select-article nil 'force) (with-current-buffer gnus-article-buffer (search-forward "http://") (replace-regexp-in-string "=3D" "=" (buffer-substring (line-beginning-position) (line-end-position)))))))) (let ((gnus-article-prepare-hook (remove 'inline-rss-article gnus-article-prepare-hook))) (gnus-summary-select-article nil 'force)) (mm-setup-w3m) (let ((inhibit-read-only t)) (with-current-buffer gnus-article-buffer (gnus-narrow-to-body) (unwind-protect (progn (goto-char (point-max)) (unless (gethash url inline-article-contents) (puthash url (with-temp-buffer (mm-url-insert url) (buffer-string)) inline-article-contents)) (insert "\n\n\n") (insert (gethash url inline-article-contents)) (let ((w3m-display-inline-images t)) (w3m-region (point-min) (point-max) url))) (widen)) (w3m-minor-mode))))) ;; From my group customisation settings: ;; ;; Variables: ;; Set variables local to the group you are entering. [More] ;; [INS] [DEL] Variable: dummy ;; Value: (add-hook 'gnus-article-prepare-hook ;; 'gnus-article-zap-yahoo-junk) (defun gnus-article-yahoo-junk-start () (save-excursion (goto-char (point-max)) (dolist (regexp '("Yahoo! Groups Sponsor" "^To Post a message, send it to" "^Yahoo! Groups Links")) (when (search-backward-regexp regexp nil t) (beginning-of-line) (return (point)))))) (defun gnus-article-zap-yahoo-junk () "Spam is spam." (let ((pos (gnus-article-yahoo-junk-start))) (when pos (delete-region pos (point-max)) (goto-char pos) (delete-blank-lines)))) (defun top-posted-p () "Check whether I've top-posted in the current message buffer." (save-excursion (narrow-to-region (message-goto-body) (or (and (gnus-article-search-signature) (point)) (point-max))) (goto-char (point-min)) (unwind-protect (if (save-excursion (search-forward-regexp message-cite-prefix-regexp nil t)) (let ((lines-before-citation 0) (lines-after-citation 0)) (while (not (or (looking-at message-cite-prefix-regexp) (looking-at (concat "^.*" gnus-cite-attribution-suffix)) (eobp))) (incf lines-before-citation) (forward-line 1)) (while (not (eobp)) (when (not (or (looking-at message-cite-prefix-regexp) (looking-at "^$") (looking-at (concat "^.*" gnus-cite-attribution-suffix)))) (incf lines-after-citation)) (forward-line 1)) (not (and (< lines-before-citation 4) (> lines-after-citation 0)))) nil) (widen)))) (require 'cl) (defvar gnus-group-display-names (make-hash-table :test 'equal)) (defun gnus-user-format-function-g (dummy) (or (gethash gnus-tmp-group gnus-group-display-names) (replace-regexp-in-string "^.*:" "" gnus-tmp-group))) (defun gnus-mst-summary-scroll-article () (interactive) (with-selected-window (gnus-configure-windows 'article) (with-current-buffer gnus-article-buffer (goto-char (window-start)) (forward-line 1) (recenter 0)))) (defun recent (query) (interactive "sQuery?: ") (gnus-group-make-nnir-group nil (format "%s date:[%s TO %s]" query (format-time-string "%Y%m%d" (seconds-to-time (- (time-to-seconds (current-time)) (* 14 24 60 60)))) (format-time-string "%Y%m%d" (current-time))))) (provide 'gnus-homebrew)