Mercurial > hg > xemacs
comparison lucid/my-news.el @ 0:107d592c5f4a
DICE versions, used by pers/common, recursive, I think/hope
| author | Henry S. Thompson <ht@inf.ed.ac.uk> |
|---|---|
| date | Mon, 08 Feb 2021 11:44:37 +0000 |
| parents | |
| children | 0a81352bd7d0 |
comparison
equal
deleted
inserted
replaced
| -1:000000000000 | 0:107d592c5f4a |
|---|---|
| 1 (load "gnus" nil t) | |
| 2 ;(require 'spam) | |
| 3 (require 'cl) | |
| 4 ;(spam-initialize) | |
| 5 (setq | |
| 6 gnus-select-method '(nntp "usenet.inf.ed.ac.uk") | |
| 7 gnus-post-method '(nntp "usenet.inf.ed.ac.uk") | |
| 8 gnus-nntp-server nil ; override local default | |
| 9 ) | |
| 10 | |
| 11 (setq gnus-use-scoring nil ; not used yet | |
| 12 gnus-summary-gather-subject-limit nil | |
| 13 gnus-thread-sort-functions | |
| 14 '(gnus-thread-sort-by-number gnus-thread-sort-by-simpl-subject) | |
| 15 gnus-summary-line-format "%U%R%5N%I%(%[%4L: %-12,12A%]%) %s\n" | |
| 16 gnus-summary-make-false-root 'none | |
| 17 gnus-mime-display-multipart-related-as-mixed t | |
| 18 gnus-simplify-subject-regexp "^\\(re[:;.]\\| \\|fwd:\\)*") | |
| 19 | |
| 20 (defsubst gnus-trim-simplify-subject (text) | |
| 21 (if (string-match gnus-simplify-subject-regexp text) | |
| 22 (substring text (match-end 0)) | |
| 23 text)) | |
| 24 | |
| 25 (defun gnus-thread-sort-by-simpl-subject (h1 h2) | |
| 26 "sort by slightly simplified subject" | |
| 27 ; (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)))) | |
| 28 (let ((case-fold-search t)) | |
| 29 (let ((result | |
| 30 (string-lessp | |
| 31 (downcase (gnus-trim-simplify-subject (mail-header-subject | |
| 32 (gnus-thread-header h1)))) | |
| 33 (downcase (gnus-trim-simplify-subject (mail-header-subject | |
| 34 (gnus-thread-header h2))))))) | |
| 35 ; (message (format " %s\n" result)) | |
| 36 result))) | |
| 37 | |
| 38 | |
| 39 ;; Database stuff | |
| 40 | |
| 41 | |
| 42 (defun open-white () | |
| 43 (setq whitelist-db (open-database "/disk/scratch/mail/white" 'berkeley-db))) | |
| 44 | |
| 45 (defun save-white () | |
| 46 (close-database whitelist-db) | |
| 47 (open-white)) | |
| 48 | |
| 49 (defun open-ad () | |
| 50 (setq adlist-db (open-database "/disk/scratch/mail/ad" 'berkeley-db))) | |
| 51 | |
| 52 (defun save-ad () | |
| 53 (close-database adlist-db) | |
| 54 (open-ad)) | |
| 55 | |
| 56 (defun open-quaker () | |
| 57 (setq quaker-db (open-database "/disk/scratch/mail/quaker" 'berkeley-db))) | |
| 58 (defun save-quaker () | |
| 59 (close-database quaker-db) | |
| 60 (open-quaker)) | |
| 61 | |
| 62 (defvar database-names '(whitelist-db adlist-db quaker-db) "sic") | |
| 63 | |
| 64 (defun db-status (&optional name) | |
| 65 "Check on the whereabouts of a name" | |
| 66 (interactive) | |
| 67 (let ((addr | |
| 68 (or name | |
| 69 (progn | |
| 70 (gnus-summary-goto-article (gnus-summary-article-number)) | |
| 71 (get-canonical-from-addr (get-current-from-components))))) | |
| 72 res) | |
| 73 (dolist (dbn database-names) | |
| 74 (if (get-database addr (eval dbn)) | |
| 75 (setq res (cons dbn res)))) | |
| 76 (if name | |
| 77 res | |
| 78 (message "%s" res)))) | |
| 79 | |
| 80 (defun add-white (&optional addToBBDB) | |
| 81 (interactive "P") | |
| 82 (gnus-summary-goto-article (gnus-summary-article-number)) | |
| 83 (let* ((components (get-current-from-components)) | |
| 84 (addr (get-canonical-from-addr components))) | |
| 85 (if (new-white addr) | |
| 86 (save-white)) | |
| 87 (if addToBBDB | |
| 88 (let ((bbdb-no-duplicates-p t)) | |
| 89 (bbdb-create-internal (car components) nil (cadr components) | |
| 90 nil nil nil))))) | |
| 91 | |
| 92 (defun add-ad () | |
| 93 (interactive) | |
| 94 (gnus-summary-goto-article (gnus-summary-article-number)) | |
| 95 (let ((addr (get-current-from-addr))) | |
| 96 (if (or (not (get-database addr whitelist-db)) | |
| 97 (yes-or-no-p "Already white, really convert to ad?")) | |
| 98 (if (new-ad addr) | |
| 99 (save-ad))))) | |
| 100 | |
| 101 (defun add-quaker() | |
| 102 (interactive) | |
| 103 (let ((addr (get-addr-before-point))) | |
| 104 (when (new-quaker addr) | |
| 105 (save-quaker)) | |
| 106 (quaker-sig-maybe))) | |
| 107 | |
| 108 (defun quaker-sig-if-to-quaker () | |
| 109 (let ((message-options)) | |
| 110 (save-excursion (message-options-set-recipient)) | |
| 111 (let* ((recipStr (message-options-get 'message-recipients)) | |
| 112 (recips (split-string (downcase recipStr) | |
| 113 ",[ \f\t\n\r\v]+" t))) | |
| 114 (while (and recips | |
| 115 (not (quaker-sig-if-quaker-1 (car recips)))) | |
| 116 (setq recips (cdr recips)))))) | |
| 117 | |
| 118 (defun quaker-sig-if-quaker () | |
| 119 (quaker-sig-if-quaker-1 (get-addr-before-point))) | |
| 120 | |
| 121 (defun quaker-sig-if-quaker-1 (addr) | |
| 122 (if (get-database addr quaker-db) | |
| 123 (progn (quaker-sig-maybe) | |
| 124 t))) | |
| 125 | |
| 126 (defun quaker-sig-maybe () | |
| 127 (save-excursion | |
| 128 (goto-char (point-max)) | |
| 129 (search-backward "\n-- \n") | |
| 130 (when (looking-at "\n-- \n Henry") | |
| 131 (forward-char 5) | |
| 132 (kill-entire-line 5) | |
| 133 (insert-file "/afs/inf.ed.ac.uk/user/h/ht/.quaker-sig")))) | |
| 134 | |
| 135 (defun kill-white () | |
| 136 (interactive) | |
| 137 (gnus-summary-goto-article (gnus-summary-article-number)) | |
| 138 (let ((addr (downcase (get-current-from-addr)))) | |
| 139 (rem-white addr))) | |
| 140 | |
| 141 (defun kill-ad () | |
| 142 (interactive) | |
| 143 (gnus-summary-goto-article (gnus-summary-article-number)) | |
| 144 (let ((addr (downcase (get-current-from-addr)))) | |
| 145 (rem-ad addr))) | |
| 146 | |
| 147 (defun get-from-gnus-addr () | |
| 148 (get-from-addr (gnus-fetch-field "From"))) | |
| 149 | |
| 150 (defun get-from-addr (addr) | |
| 151 (get-canonical-from-addr (gnus-extract-address-components addr))) | |
| 152 | |
| 153 (defun get-canonical-from-addr (components) | |
| 154 (downcase (cadr components))) | |
| 155 | |
| 156 (defun get-current-from-addr () | |
| 157 (with-current-buffer gnus-article-buffer | |
| 158 (get-from-gnus-addr))) | |
| 159 | |
| 160 (defun get-current-from-components () | |
| 161 (with-current-buffer gnus-article-buffer | |
| 162 (gnus-extract-address-components (gnus-fetch-field "From")))) | |
| 163 | |
| 164 (defun get-addr-before-point () | |
| 165 (let ((cur (point))) | |
| 166 (save-excursion | |
| 167 (get-from-addr (buffer-substring (+ (search-backward " ") 1) cur))) | |
| 168 )) | |
| 169 | |
| 170 (defun blacken-and-delete (group) | |
| 171 ;; mis-named now | |
| 172 ;; this is part of the expiry processing for xxxSPAM groups, and | |
| 173 ;; actually whitens the from addresses of #-marked articles | |
| 174 ;; The return value is crucial (and crucially outside of the scope of the if) | |
| 175 (if (memq number | |
| 176 (with-current-buffer gnus-summary-buffer | |
| 177 gnus-newsgroup-processable)) | |
| 178 (let ((addr (get-from-gnus-addr))) | |
| 179 (new-white addr))) | |
| 180 'delete) | |
| 181 | |
| 182 (defun unwhiten-and-delete (group) | |
| 183 ;; unused except in stale groups -- usable as an expiry | |
| 184 (if (memq number | |
| 185 (with-current-buffer gnus-summary-buffer | |
| 186 gnus-newsgroup-processable)) | |
| 187 (let ((addr (get-from-gnus-addr))) | |
| 188 (remove-database addr whitelist-db))) | |
| 189 'delete) | |
| 190 | |
| 191 (defun known-black (list) | |
| 192 (if (get-database (get-from-gnus-addr) blacklist-db) | |
| 193 list)) | |
| 194 | |
| 195 (defun white-spam (list) | |
| 196 (if (or (equal (get-database (get-from-gnus-addr) whitelist-db) "t") | |
| 197 (let ((case-fold-search t) | |
| 198 (subj (gnus-fetch-field "Subject")) | |
| 199 (from (get-from-gnus-addr))) | |
| 200 (or | |
| 201 (and subj (string-match white-subjects subj)) | |
| 202 (and from | |
| 203 (let ((fromDom (substring from (+ 1 (search "@" from))))) | |
| 204 (and fromDom (member fromDom white-domains))))))) | |
| 205 list)) | |
| 206 | |
| 207 (defun ad-spam (list) | |
| 208 (if (let ((from (get-from-gnus-addr))) | |
| 209 (or | |
| 210 (equal (get-database from adlist-db) "t") | |
| 211 (and from | |
| 212 (let ((fromDom (substring from (+ 1 (search "@" from))))) | |
| 213 (and fromDom (member fromDom ad-domains)))) | |
| 214 )) | |
| 215 list)) | |
| 216 | |
| 217 (defun bogoNote (group) | |
| 218 (if (memq number | |
| 219 (with-current-buffer gnus-summary-buffer | |
| 220 gnus-newsgroup-processable)) | |
| 221 (let ((addr (get-from-gnus-addr))) | |
| 222 (new-white addr))) | |
| 223 (shell-command-on-region (point-min) (point-max) | |
| 224 "/afs/inf.ed.ac.uk/user/h/ht/share/bin/local/makeBogo") | |
| 225 'delete) | |
| 226 | |
| 227 (defun whiten-recip () | |
| 228 ;;; a hook for outgoing mail | |
| 229 (let* ((recips (message-options-get 'message-recipients)) | |
| 230 (res (mapcar (function new-white) | |
| 231 (split-string (downcase recips) | |
| 232 ",[ \f\t\n\r\v]*" t)))) | |
| 233 (while (and res (not (car res))) | |
| 234 (setq res (cdr res))) | |
| 235 (if res (save-white)))) | |
| 236 | |
| 237 | |
| 238 (defun new-white (addr) | |
| 239 (if (get-database addr whitelist-db) | |
| 240 nil | |
| 241 (put-database addr "t" whitelist-db) | |
| 242 t)) | |
| 243 | |
| 244 (defun new-ad (addr) | |
| 245 (if (get-database addr adlist-db) | |
| 246 nil | |
| 247 (put-database addr "t" adlist-db) | |
| 248 t)) | |
| 249 | |
| 250 (defun rem-ad (addr) | |
| 251 (remove-database addr adlist-db) | |
| 252 (save-ad)) | |
| 253 | |
| 254 (defun new-quaker (addr) | |
| 255 (if (get-database addr quaker-db) | |
| 256 nil | |
| 257 (put-database addr "t" quaker-db) | |
| 258 t)) | |
| 259 | |
| 260 (defun rem-white (addr) | |
| 261 (remove-database (downcase addr) whitelist-db) | |
| 262 (save-white)) | |
| 263 | |
| 264 (defun bogoOK (group) | |
| 265 (shell-command-on-region (point-min) (point-max) | |
| 266 "/afs/inf.ed.ac.uk/user/h/ht/share/bin/local/makeNonBogo") | |
| 267 'delete) | |
| 268 | |
| 269 (defun del-dups () | |
| 270 (interactive) | |
| 271 (gnus-summary-sort-by-subject) | |
| 272 (gnus-summary-clear-mark-forward 1) | |
| 273 (goto-char (point-min)) | |
| 274 (let ((pos)) | |
| 275 (while (setq pos (search-forward "] " nil t)) | |
| 276 (end-of-line) | |
| 277 (let ((subj (buffer-substring pos (point)))) | |
| 278 (unless (equal subj "") | |
| 279 (let ((target (if (< (length subj) 26) | |
| 280 (concat "] " subj "\n") | |
| 281 (concat "] " (substring subj 0 25)))) | |
| 282 (done 0) | |
| 283 (case-fold-search nil)) | |
| 284 (while (and (= done 0) | |
| 285 (search-forward target nil t)) | |
| 286 (forward-char -3) | |
| 287 (setq done (gnus-summary-mark-as-read-forward 1)))))))) | |
| 288 (gnus-summary-limit-to-unread) | |
| 289 (gnus-summary-sort-by-original)) | |
| 290 | |
| 291 (defun mark-and-mark (n) | |
| 292 (interactive "p") | |
| 293 (while (>= n 1) | |
| 294 (gnus-summary-mark-as-read) | |
| 295 (gnus-summary-mark-as-processable 1) | |
| 296 (setq n (- n 1)))) | |
| 297 | |
| 298 (defun split-on-whole-field (field pat list) | |
| 299 (goto-char (point-max)) | |
| 300 (let ((hit (assq pat wsp-cache)) | |
| 301 rpat) | |
| 302 (if hit | |
| 303 (setq rpat (cdr hit)) | |
| 304 (setq rpat | |
| 305 (concat "^" | |
| 306 field | |
| 307 ":\\s-*" | |
| 308 (if (stringp pat) | |
| 309 pat | |
| 310 (cdr (assq pat | |
| 311 nnmail-split-abbrev-alist))) | |
| 312 "$")) | |
| 313 (setq wsp-cache (cons (cons pat rpat) wsp-cache))) | |
| 314 (if (re-search-backward rpat nil t) | |
| 315 list))) | |
| 316 | |
| 317 (defun ht-gnus-summary-delete-forward () | |
| 318 "REAL delete for nnmail gnus" | |
| 319 (interactive) | |
| 320 (gnus-summary-delete-article) | |
| 321 (gnus-summary-next-unread-article)) | |
| 322 | |
| 323 ;; run the first time we make a summary window | |
| 324 (defun gnus-summary-mode-fun1 () | |
| 325 "install ht's mods" | |
| 326 (define-key gnus-summary-mode-map "D" 'ht-gnus-summary-delete-forward) | |
| 327 (define-key gnus-summary-mode-map "~" 'mark-and-mark) | |
| 328 (define-key gnus-summary-mode-map "\M-d" 'gnus-edit-and-move-to-diary) | |
| 329 (define-key gnus-summary-mode-map "\M-e" 'gnus-extract-attachment) | |
| 330 (define-key gnus-summary-mode-map "\M-w" 'add-white) | |
| 331 (define-key gnus-summary-mode-map [(control meta w)] 'copy-region-to-kill) | |
| 332 (define-key gnus-summary-mode-map "\M-h" 'showMPAhtml) | |
| 333 ;(define-key gnus-summary-mode-map [(control meta w)] 'kill-white) | |
| 334 (define-key gnus-summary-mode-map "\M-a" 'add-ad) | |
| 335 (define-key gnus-summary-mode-map "\M-n" 'ht-next-unseen-maybe) | |
| 336 (define-key gnus-summary-mode-map "\M-c" 'ht-catchup-and-next-unseen) | |
| 337 (define-key gnus-summary-mime-map "O" 'ht-article-save-parts) | |
| 338 (define-key gnus-summary-backend-map "M" 'ht-move-to-pers) | |
| 339 (remove-hook 'gnus-summary-mode-hook 'gnus-summary-mode-fun1)) | |
| 340 | |
| 341 (defun message-mode-fun1 () | |
| 342 (define-key message-mode-map [(control meta q)] 'add-quaker) | |
| 343 (remove-hook 'message-mode-hook 'message-mode-fun1)) | |
| 344 | |
| 345 (defvar ht-gnus-just-read nil) | |
| 346 | |
| 347 (defun ht-catchup-and-next-unseen () | |
| 348 (interactive) | |
| 349 (when (gnus-summary-catchup nil t nil 'fast) | |
| 350 (gnus-summary-exit) | |
| 351 (previous-line 1) | |
| 352 (ht-next-with-unseen 1))) | |
| 353 | |
| 354 (defun ht-next-unseen-maybe (n) | |
| 355 (interactive "p") | |
| 356 (cond | |
| 357 ((eq (gnus-summary-next-unread-subject n) n) | |
| 358 (gnus-summary-exit) | |
| 359 (previous-line 1) | |
| 360 (if (ht-next-with-unseen n) | |
| 361 (ht-read-group-unseen-only))))) | |
| 362 | |
| 363 (defun ht-gnus-pers-refresh (n) | |
| 364 (interactive "p") | |
| 365 (let ((gn (concat "nnml+ht:pers-" | |
| 366 (format-time-string "%Y-%m" (current-time))))) | |
| 367 (gnus-group-get-new-news) | |
| 368 (let ((nn (gnus-number-of-unseen-articles-in-group gn))) | |
| 369 (gnus-group-goto-group gn) | |
| 370 (cond | |
| 371 ((> nn 0) | |
| 372 (gnus-group-read-group nn)) | |
| 373 ((> n 1) | |
| 374 (let ((gnus-auto-select-subject | |
| 375 (lambda () | |
| 376 (goto-char (point-max)) | |
| 377 (previous-line 1)))) | |
| 378 (gnus-group-read-group nil t))) | |
| 379 (t (goto-char (point-min)) | |
| 380 (ht-next-with-unseen 1)))) | |
| 381 (message "%s" ht-gnus-just-read)) | |
| 382 ) | |
| 383 | |
| 384 (defun no-select () | |
| 385 (if (member gnus-newsgroup-name no-select-groups) | |
| 386 (progn (make-variable-buffer-local 'gnus-auto-select-first) | |
| 387 (setq gnus-auto-select-first nil)))) | |
| 388 | |
| 389 (defun showMPAhtml () | |
| 390 "Show the text/html parts of an multipart/alternative message using lynx" | |
| 391 (interactive) | |
| 392 (gnus-summary-select-article) | |
| 393 (with-current-buffer gnus-original-article-buffer | |
| 394 (shell-command-on-region (point-min) (point-max) "/afs/inf.ed.ac.uk/user/h/ht/share/bin/showMPA.sh") | |
| 395 ) | |
| 396 ) | |
| 397 | |
| 398 | |
| 399 ;; run the first time we make a group window | |
| 400 (defun gnus-group-mode-fun1 () | |
| 401 "install ht's mods" | |
| 402 (require 'gnus-msg) | |
| 403 (define-key gnus-group-mode-map "\M-\C-g" 'ht-gnus-pers-refresh) | |
| 404 (define-key gnus-group-mode-map "\M-n" 'ht-next-with-unseen) | |
| 405 (define-key gnus-group-mode-map "\M-p" 'ht-previous-with-unseen) | |
| 406 (define-key gnus-group-mode-map "\M- " 'ht-read-group-unseen-only) | |
| 407 (define-key gnus-send-bounce-map "R" 'resend-to-schemadev) | |
| 408 (define-key gnus-send-bounce-map "x" 'flush-all-nogoods) | |
| 409 (remove-hook 'gnus-group-mode-hook 'gnus-group-mode-fun1)) | |
| 410 | |
| 411 (defun flush-all-nogoods () | |
| 412 (interactive) | |
| 413 (while (re-search-forward | |
| 414 "] \\(\\(Returned\\|\\([Uu]n\\|[Nn]on-?\\)deliver\\(able\\|ed\\)\\)\\( [Mm]ail\\|:?\\)\\|DELIVERY FAILURE\\|Delivery \\(Notification: Delivery has failed\\|Status Notification .\\(Failure\\|Delay\\).\\)\\|failure \\(notice\\|delivery\\)\\)" | |
| 415 nil t) | |
| 416 (gnus-summary-mark-as-read) | |
| 417 (end-of-line))) | |
| 418 | |
| 419 (defun gnus-user-format-function-t (header) | |
| 420 "display the to field (for archive messages)" | |
| 421 (let ((n (mail-header-number header))) | |
| 422 (with-current-buffer nntp-server-buffer | |
| 423 (save-excursion | |
| 424 (save-restriction | |
| 425 (let ((inhibit-point-motion-hooks t)) | |
| 426 (goto-char (point-min)) | |
| 427 (let ((beg (search-forward (format " %d Article retrieved." n))) | |
| 428 (end (search-forward "\n.\n"))) | |
| 429 (narrow-to-region beg end) | |
| 430 (goto-char beg) | |
| 431 (message-fetch-field "To")))))))) | |
| 432 | |
| 433 (defun gnus-extract-attachment () | |
| 434 "extract attachments from a multi-part mime message" | |
| 435 (interactive) | |
| 436 (let ((sm gnus-show-mime)) | |
| 437 (if sm | |
| 438 (progn (setq gnus-show-mime nil) | |
| 439 (gnus-summary-select-article t 'force)) | |
| 440 ) | |
| 441 (gnus-summary-show-all-headers) | |
| 442 (with-current-buffer gnus-article-buffer | |
| 443 (save-excursion | |
| 444 (save-restriction | |
| 445 (mime/viewer-mode) | |
| 446 (delete-other-windows) | |
| 447 (let ((pt 0)) | |
| 448 (while (progn | |
| 449 (mime-viewer/next-content) | |
| 450 (and | |
| 451 (equal "*Preview-*Article**" (buffer-name (current-buffer))) | |
| 452 (not (= pt (point))))) | |
| 453 (setq pt (point)) | |
| 454 (if (looking-at "^\\[[0-9]* \\([^ ]+ \\)+<") | |
| 455 (mime-viewer/extract-content))))))) | |
| 456 (kill-buffer "*Preview-*Article**") | |
| 457 (setq gnus-show-mime sm) | |
| 458 )) | |
| 459 | |
| 460 ;;; Why??? | |
| 461 (make-variable-buffer-local 'gnus-extra-headers) | |
| 462 (make-variable-buffer-local 'nnmail-extra-headers) | |
| 463 | |
| 464 | |
| 465 (defun resend-to-schemadev () | |
| 466 (interactive) | |
| 467 (message "forwarding to xmlschema-dev") | |
| 468 (gnus-summary-resend-message "xmlschema-dev@w3.org" 1) | |
| 469 (gnus-summary-next-unread-article)) | |
| 470 | |
| 471 (defun brutal-resend () | |
| 472 (interactive) | |
| 473 (message "editing for resend. . .") | |
| 474 (unless (eq (gnus-summary-article-number) | |
| 475 gnus-current-article) | |
| 476 (gnus-summary-select-article t)) | |
| 477 (gnus-summary-toggle-header 1) | |
| 478 (with-current-buffer gnus-article-buffer | |
| 479 (toggle-read-only) | |
| 480 (gnus-article-date-original) | |
| 481 (goto-char (point-min)) | |
| 482 (replace-regexp "^\\(X-Diagnostic\\|X-Envelope-To\\|X-Original-To\\|Delivered-To\\):.*\n" "") | |
| 483 (goto-char (point-min)) | |
| 484 (gnus-summary-edit-article-done | |
| 485 (or (mail-header-references gnus-current-headers) "") | |
| 486 (gnus-group-read-only-p) gnus-summary-buffer nil)) | |
| 487 (call-interactively (function gnus-summary-resend-message)) | |
| 488 (gnus-summary-next-unread-article)) | |
| 489 | |
| 490 ; (unless (fboundp 'builtin-coding-system-p) | |
| 491 ; (fset 'builtin-coding-system-p (symbol-function 'coding-system-p)) | |
| 492 ; (defun coding-system-p (obj) | |
| 493 ; (cond | |
| 494 ; ((builtin-coding-system-p obj) t) | |
| 495 ; ((memq obj '(utf-8 gb2312 koi8-r iso-8859-1)) | |
| 496 ; (message (format "Coding system: %s" obj)) | |
| 497 ; t)))) | |
| 498 | |
| 499 ;;; dangerous hack to improve display of names and subjects in mail/news | |
| 500 (if nil (progn | |
| 501 (require 'mm-util) | |
| 502 (defun mm-decode-coding-string (str cs) | |
| 503 (if (and str (eq cs 'utf-8)) | |
| 504 (if (or (string-match "Â" str) | |
| 505 (string-match "Ã" str)) | |
| 506 (let* ((r 0) ; read pointer | |
| 507 (w 0) ; write pointer | |
| 508 (l (length str))) | |
| 509 (while (< r l) | |
| 510 (let* ((c (aref str r)) | |
| 511 (i (char-int c))) | |
| 512 (cond ((= i 194) | |
| 513 (aset str w (aref str (+ r 1))) | |
| 514 (setq r (+ r 2))) | |
| 515 ((= i 195) | |
| 516 (aset str w | |
| 517 (int-char | |
| 518 (+ 64 | |
| 519 (char-int (aref str (+ r 1)))))) | |
| 520 (setq r (+ r 2))) | |
| 521 (t | |
| 522 (aset str w c) | |
| 523 (setq r (+ r 1))))) | |
| 524 (setq w (+ w 1))) | |
| 525 (substring str 0 w)) | |
| 526 str) | |
| 527 str)) | |
| 528 | |
| 529 (defun mm-sort-coding-systems-predicate (a b) | |
| 530 ;; from mm-util, abort if no priorities | |
| 531 (or (not mm-coding-system-priorities) | |
| 532 (let ((priorities | |
| 533 (mapcar (lambda (cs) | |
| 534 ;; Note: invalid entries are dropped silently | |
| 535 (and (setq cs (mm-coding-system-p cs)) | |
| 536 (coding-system-base cs))) | |
| 537 mm-coding-system-priorities))) | |
| 538 (and (setq a (mm-coding-system-p a)) | |
| 539 (if (setq b (mm-coding-system-p b)) | |
| 540 (> (length (memq (coding-system-base a) priorities)) | |
| 541 (length (memq (coding-system-base b) priorities))) | |
| 542 t))))))) | |
| 543 | |
| 544 (require 'browse-url) | |
| 545 | |
| 546 ;;; This version collects extra lines if you use right-button | |
| 547 ;;; to click on a URL | |
| 548 (defun browse-url (url &rest args) | |
| 549 "Ask a WWW browser to load URL. | |
| 550 Prompts for a URL, defaulting to the URL at or before point. Variable | |
| 551 `browse-url-browser-function' says which browser to use." | |
| 552 (interactive (browse-url-interactive-arg "URL: ")) | |
| 553 (unless (interactive-p) | |
| 554 (setq args (or args (list browse-url-new-window-flag)))) | |
| 555 (if (and (boundp 'event)(= 3 (event-button event))) | |
| 556 (let ((thisLine url)) | |
| 557 (while (and (progn (forward-char (length thisLine)) | |
| 558 (eolp)) | |
| 559 (progn (forward-line 1) | |
| 560 (beginning-of-line) | |
| 561 (not (looking-at "\\s-")))) | |
| 562 (looking-at "\\S-*") | |
| 563 (setq thisLine (buffer-substring (match-beginning 0) | |
| 564 (match-end 0))) | |
| 565 (setq url (concat url thisLine))))) | |
| 566 (if (functionp browse-url-browser-function) | |
| 567 (apply browse-url-browser-function url args) | |
| 568 ;; The `function' can be an alist; look down it for first match | |
| 569 ;; and apply the function (which might be a lambda). | |
| 570 (catch 'done | |
| 571 (dolist (bf browse-url-browser-function) | |
| 572 (when (string-match (car bf) url) | |
| 573 (apply (cdr bf) url args) | |
| 574 (throw 'done t))) | |
| 575 (error "No browse-url-browser-function matching URL %s" | |
| 576 url)))) | |
| 577 | |
| 578 (defun gnus-user-format-function-H (dummy) | |
| 579 (format "%c" | |
| 580 (cond ((eq gnus-tmp-summary-live ?*) | |
| 581 ?*) | |
| 582 ((> (gnus-number-of-unseen-articles-in-group gnus-tmp-group) 0) | |
| 583 ?.) | |
| 584 (t ? )))) | |
| 585 | |
| 586 (defun ht-next-with-unseen (n) | |
| 587 (interactive "p") | |
| 588 (let* ((gvl (mapcar (function string-to-number) | |
| 589 (split-string gnus-version-number "\\."))) | |
| 590 (pattern (if (or (> (car gvl) 5) | |
| 591 (and (eq (car gvl) 5) | |
| 592 (or (> (cadr gvl) 10) | |
| 593 (and (eq (cadr gvl) 10) | |
| 594 (> (caddr gvl) 7))))) | |
| 595 "\\." | |
| 596 ":\\."))) | |
| 597 (if (looking-at pattern) | |
| 598 (if (< n 0) | |
| 599 (backward-char 1) | |
| 600 (forward-char 1))) | |
| 601 (let ((missing 0) | |
| 602 (winning (looking-at pattern))) | |
| 603 (while (and (zerop missing) | |
| 604 (not winning)) | |
| 605 (setq missing (gnus-group-next-unread-group n)) | |
| 606 (setq winning (looking-at pattern))) | |
| 607 winning))) | |
| 608 | |
| 609 (defun ht-read-group-unseen-only () | |
| 610 (interactive) | |
| 611 (gnus-group-read-group | |
| 612 (gnus-number-of-unseen-articles-in-group (gnus-group-group-name)))) | |
| 613 | |
| 614 (defun ht-previous-with-unseen (n) | |
| 615 (interactive "p") | |
| 616 (ht-next-with-unseen (- n))) | |
| 617 | |
| 618 (defun ht-gnus-note-save-to-group () | |
| 619 (let ((g (caar group-art))) | |
| 620 (if (not (member g ht-gnus-just-read)) | |
| 621 (setq ht-gnus-just-read (cons g ht-gnus-just-read))))) | |
| 622 | |
| 623 (defvar ht-stash-directory "/disk/scratch/mail/stash/") | |
| 624 | |
| 625 (defun ht-save-part (handle n) | |
| 626 (let ((sup-type (mm-handle-media-supertype handle)) | |
| 627 (sub-type (mm-handle-media-subtype handle))) | |
| 628 (message (format "%s %s/%s" n sup-type sub-type)) | |
| 629 (cond ((and (equal sup-type "multipart") | |
| 630 (or (equal sub-type "alternative") | |
| 631 (equal sub-type "related"))) | |
| 632 (let ((alts (cddr handle)) | |
| 633 (j 0)) | |
| 634 (while alts | |
| 635 (let* ((alt (pop alts)) | |
| 636 (handle-type (mm-handle-type alt))) | |
| 637 (let* ((sub (mm-handle-media-subtype alt)) | |
| 638 (ext (cdr | |
| 639 (assoc sub '(("calendar" . "vcs") | |
| 640 ("v-calendar" . "vcs")))))) | |
| 641 (setq j (+ j 1)) | |
| 642 (if (not (or (mail-content-type-get | |
| 643 (mm-handle-disposition alt) 'filename) | |
| 644 (mail-content-type-get | |
| 645 handle-type 'name))) | |
| 646 (nconc | |
| 647 handle-type | |
| 648 (list (cons 'name (format "%s.%s.%s" | |
| 649 n j (or ext sub)))))) | |
| 650 (ht-save-part alt (format "%s.%s" n j))))))) | |
| 651 ((and (equal sup-type "text")(not | |
| 652 (member sub-type '("html" | |
| 653 "v-calendar" | |
| 654 "calendar")))) | |
| 655 (message "Skipping text part: %s" (mm-handle-disposition handle))) | |
| 656 (t | |
| 657 (mm-save-part handle))))) | |
| 658 | |
| 659 (defun ht-move-to-pers (n) | |
| 660 (interactive "p") | |
| 661 (gnus-summary-move-article n | |
| 662 (concat | |
| 663 "nnml+ht:pers-" | |
| 664 (format-time-string "%Y-%m" (current-time))))) | |
| 665 | |
| 666 (defun ht-article-save-parts (n) | |
| 667 "Save non t/p MIME parts starting at N, which is the numerical prefix." | |
| 668 (interactive "p2") | |
| 669 (let ((window (get-buffer-window gnus-article-buffer 'visible)) | |
| 670 frame) | |
| 671 (when window | |
| 672 ;; It is necessary to select the article window so that | |
| 673 ;; `gnus-article-goto-part' may really move the point. | |
| 674 (setq frame (selected-frame)) | |
| 675 (gnus-select-frame-set-input-focus (window-frame window)) | |
| 676 (unwind-protect | |
| 677 (save-window-excursion | |
| 678 (select-window window) | |
| 679 (let ((len (length gnus-article-mime-handle-alist))) | |
| 680 (setq mm-default-directory ht-stash-directory) | |
| 681 (while (<= n len) | |
| 682 (gnus-article-goto-part n) | |
| 683 (let ((handle (cdr (assq n gnus-article-mime-handle-alist)))) | |
| 684 (ht-save-part handle n)) | |
| 685 (setq n (+ n 1)) | |
| 686 ))) | |
| 687 (gnus-select-frame-set-input-focus frame)))) | |
| 688 ) | |
| 689 | |
| 690 | |
| 691 (defun gnus-article-part-wrapper (n function) | |
| 692 (let ((window (get-buffer-window gnus-article-buffer 'visible)) | |
| 693 frame) | |
| 694 (when window | |
| 695 ;; It is necessary to select the article window so that | |
| 696 ;; `gnus-article-goto-part' may really move the point. | |
| 697 (setq frame (selected-frame)) | |
| 698 (gnus-select-frame-set-input-focus (window-frame window)) | |
| 699 (unwind-protect | |
| 700 (save-window-excursion | |
| 701 (select-window window) | |
| 702 (when (> n (length gnus-article-mime-handle-alist)) | |
| 703 (error "No such part")) | |
| 704 (gnus-article-goto-part n) | |
| 705 (let ((handle (cdr (assq n gnus-article-mime-handle-alist)))) | |
| 706 (funcall function handle))) | |
| 707 (gnus-select-frame-set-input-focus frame))))) | |
| 708 | |
| 709 (defun mhstore-me (dir) | |
| 710 (interactive (list (read-directory-name "Save parts to " "/tmp" "/tmp" t))) | |
| 711 (let ((art (gnus-summary-article-number))) | |
| 712 (let* ((grp-parts (split-string gnus-newsgroup-name ":")) | |
| 713 (meth (car grp-parts)) | |
| 714 (grp (cadr grp-parts))) | |
| 715 (if (string= meth "nnml+ht") | |
| 716 (let ((doit | |
| 717 (format "cd %s && mhstore -f /disk/scratch/mail/Mail/%s/%s -auto" | |
| 718 dir grp art))) | |
| 719 (message doit) | |
| 720 (shell-command doit)) | |
| 721 )))) | |
| 722 | |
| 723 (defun my-message-send-and-exit (&optional arg) | |
| 724 (interactive "P") | |
| 725 (let ((message-required-mail-headers | |
| 726 (if arg | |
| 727 (mapcar | |
| 728 (lambda(x) | |
| 729 (if(and(consp x)(eq(cdr x)'In-Reply-To)) | |
| 730 (cons 'optional 'xyzzy) | |
| 731 x)) | |
| 732 message-required-mail-headers) | |
| 733 message-required-mail-headers))) | |
| 734 (orig-message-send-and-exit))) | |
| 735 | |
| 736 (require 'message) | |
| 737 (if (not (fboundp 'orig-message-send-and-exit)) | |
| 738 (progn | |
| 739 (fset 'orig-message-send-and-exit (symbol-function 'message-send-and-exit)) | |
| 740 (fset 'message-send-and-exit (symbol-function 'my-message-send-and-exit)))) | |
| 741 | |
| 742 (provide 'my-news) |